{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Aztecs.ECS.View
-- Copyright   : (c) Matt Hunzinger, 2025
-- License     : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  : matt@hunzinger.me
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Aztecs.ECS.View
  ( View (..),
    view,
    viewSingle,
    filterView,
    null,
    unview,
    allDyn,
    singleDyn,
    mapDyn,
    mapSingleDyn,
  )
where

import Aztecs.ECS.Access.Internal (Access)
import Aztecs.ECS.Query.Dynamic (DynamicQuery (..))
import Aztecs.ECS.World.Archetypes
import qualified Aztecs.ECS.World.Archetypes as AS
import Aztecs.ECS.World.Components
import Aztecs.ECS.World.Entities (Entities)
import qualified Aztecs.ECS.World.Entities as E
import Control.Monad.Identity (Identity (runIdentity))
import Data.Foldable hiding (null)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Prelude hiding (null)

-- | View into a `World`, containing a subset of archetypes.
newtype View m = View
  { -- | Archetypes contained in this view.
    forall (m :: * -> *). View m -> Map ArchetypeID (Node m)
viewArchetypes :: Map ArchetypeID (Node m)
  }
  deriving (Int -> View m -> ShowS
[View m] -> ShowS
View m -> String
(Int -> View m -> ShowS)
-> (View m -> String) -> ([View m] -> ShowS) -> Show (View m)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *). Int -> View m -> ShowS
forall (m :: * -> *). [View m] -> ShowS
forall (m :: * -> *). View m -> String
$cshowsPrec :: forall (m :: * -> *). Int -> View m -> ShowS
showsPrec :: Int -> View m -> ShowS
$cshow :: forall (m :: * -> *). View m -> String
show :: View m -> String
$cshowList :: forall (m :: * -> *). [View m] -> ShowS
showList :: [View m] -> ShowS
Show, NonEmpty (View m) -> View m
View m -> View m -> View m
(View m -> View m -> View m)
-> (NonEmpty (View m) -> View m)
-> (forall b. Integral b => b -> View m -> View m)
-> Semigroup (View m)
forall b. Integral b => b -> View m -> View m
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (m :: * -> *). NonEmpty (View m) -> View m
forall (m :: * -> *). View m -> View m -> View m
forall (m :: * -> *) b. Integral b => b -> View m -> View m
$c<> :: forall (m :: * -> *). View m -> View m -> View m
<> :: View m -> View m -> View m
$csconcat :: forall (m :: * -> *). NonEmpty (View m) -> View m
sconcat :: NonEmpty (View m) -> View m
$cstimes :: forall (m :: * -> *) b. Integral b => b -> View m -> View m
stimes :: forall b. Integral b => b -> View m -> View m
Semigroup, Semigroup (View m)
View m
Semigroup (View m) =>
View m
-> (View m -> View m -> View m)
-> ([View m] -> View m)
-> Monoid (View m)
[View m] -> View m
View m -> View m -> View m
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall (m :: * -> *). Semigroup (View m)
forall (m :: * -> *). View m
forall (m :: * -> *). [View m] -> View m
forall (m :: * -> *). View m -> View m -> View m
$cmempty :: forall (m :: * -> *). View m
mempty :: View m
$cmappend :: forall (m :: * -> *). View m -> View m -> View m
mappend :: View m -> View m -> View m
$cmconcat :: forall (m :: * -> *). [View m] -> View m
mconcat :: [View m] -> View m
Monoid)

-- | View into all archetypes containing the provided component IDs.
view :: Set ComponentID -> Archetypes m -> View m
view :: forall (m :: * -> *). Set ComponentID -> Archetypes m -> View m
view Set ComponentID
cIds Archetypes m
as = Map ArchetypeID (Node m) -> View m
forall (m :: * -> *). Map ArchetypeID (Node m) -> View m
View (Map ArchetypeID (Node m) -> View m)
-> Map ArchetypeID (Node m) -> View m
forall a b. (a -> b) -> a -> b
$ Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m)
forall (m :: * -> *).
Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m)
AS.find Set ComponentID
cIds Archetypes m
as

-- | View into a single archetype containing the provided component IDs.
viewSingle :: Set ComponentID -> Archetypes m -> Maybe (View m)
viewSingle :: forall (m :: * -> *).
Set ComponentID -> Archetypes m -> Maybe (View m)
viewSingle Set ComponentID
cIds Archetypes m
as = case Map ArchetypeID (Node m) -> [(ArchetypeID, Node m)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ArchetypeID (Node m) -> [(ArchetypeID, Node m)])
-> Map ArchetypeID (Node m) -> [(ArchetypeID, Node m)]
forall a b. (a -> b) -> a -> b
$ Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m)
forall (m :: * -> *).
Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m)
AS.find Set ComponentID
cIds Archetypes m
as of
  [(ArchetypeID, Node m)
a] -> View m -> Maybe (View m)
forall a. a -> Maybe a
Just (View m -> Maybe (View m))
-> (Map ArchetypeID (Node m) -> View m)
-> Map ArchetypeID (Node m)
-> Maybe (View m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ArchetypeID (Node m) -> View m
forall (m :: * -> *). Map ArchetypeID (Node m) -> View m
View (Map ArchetypeID (Node m) -> Maybe (View m))
-> Map ArchetypeID (Node m) -> Maybe (View m)
forall a b. (a -> b) -> a -> b
$ (ArchetypeID -> Node m -> Map ArchetypeID (Node m))
-> (ArchetypeID, Node m) -> Map ArchetypeID (Node m)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ArchetypeID -> Node m -> Map ArchetypeID (Node m)
forall k a. k -> a -> Map k a
Map.singleton (ArchetypeID, Node m)
a
  [(ArchetypeID, Node m)]
_ -> Maybe (View m)
forall a. Maybe a
Nothing

-- | View into all archetypes containing the provided component IDs and matching the provided predicate.
filterView ::
  Set ComponentID ->
  (Node m -> Bool) ->
  Archetypes m ->
  View m
filterView :: forall (m :: * -> *).
Set ComponentID -> (Node m -> Bool) -> Archetypes m -> View m
filterView Set ComponentID
cIds Node m -> Bool
f Archetypes m
as = Map ArchetypeID (Node m) -> View m
forall (m :: * -> *). Map ArchetypeID (Node m) -> View m
View (Map ArchetypeID (Node m) -> View m)
-> Map ArchetypeID (Node m) -> View m
forall a b. (a -> b) -> a -> b
$ (Node m -> Bool)
-> Map ArchetypeID (Node m) -> Map ArchetypeID (Node m)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Node m -> Bool
f (Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m)
forall (m :: * -> *).
Set ComponentID -> Archetypes m -> Map ArchetypeID (Node m)
AS.find Set ComponentID
cIds Archetypes m
as)

-- | @True@ if the `View` is empty.
null :: View m -> Bool
null :: forall (m :: * -> *). View m -> Bool
null = Map ArchetypeID (Node m) -> Bool
forall k a. Map k a -> Bool
Map.null (Map ArchetypeID (Node m) -> Bool)
-> (View m -> Map ArchetypeID (Node m)) -> View m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View m -> Map ArchetypeID (Node m)
forall (m :: * -> *). View m -> Map ArchetypeID (Node m)
viewArchetypes

-- | "Un-view" a `View` back into a `World`.
unview :: View m -> Entities m -> Entities m
unview :: forall (m :: * -> *). View m -> Entities m -> Entities m
unview View m
v Entities m
es =
  Entities m
es
    { E.archetypes =
        foldl'
          (\Archetypes m
as (ArchetypeID
aId, Node m
n) -> Archetypes m
as {AS.nodes = Map.insert aId n (AS.nodes as)})
          (E.archetypes es)
          (Map.toList $ viewArchetypes v)
    }

-- | Query all matching entities in a `View`.
allDyn :: DynamicQuery Identity a -> View Identity -> Vector a
allDyn :: forall a. DynamicQuery Identity a -> View Identity -> Vector a
allDyn DynamicQuery Identity a
q View Identity
v =
  (Vector a -> Node Identity -> Vector a)
-> Vector a -> Map ArchetypeID (Node Identity) -> Vector a
forall b a. (b -> a -> b) -> b -> Map ArchetypeID a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    ( \Vector a
acc Node Identity
n ->
        let (Vector a
as, Archetype Identity
_, Access Identity ()
_) = Identity (Vector a, Archetype Identity, Access Identity ())
-> (Vector a, Archetype Identity, Access Identity ())
forall a. Identity a -> a
runIdentity (Identity (Vector a, Archetype Identity, Access Identity ())
 -> (Vector a, Archetype Identity, Access Identity ()))
-> (Archetype Identity
    -> Identity (Vector a, Archetype Identity, Access Identity ()))
-> Archetype Identity
-> (Vector a, Archetype Identity, Access Identity ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicQuery Identity a
-> Archetype Identity
-> Identity (Vector a, Archetype Identity, Access Identity ())
forall (m :: * -> *) a.
DynamicQuery m a
-> Archetype m -> m (Vector a, Archetype m, Access m ())
runDynQuery DynamicQuery Identity a
q (Archetype Identity
 -> (Vector a, Archetype Identity, Access Identity ()))
-> Archetype Identity
-> (Vector a, Archetype Identity, Access Identity ())
forall a b. (a -> b) -> a -> b
$ Node Identity -> Archetype Identity
forall (m :: * -> *). Node m -> Archetype m
nodeArchetype Node Identity
n
         in Vector a
as Vector a -> Vector a -> Vector a
forall a. Vector a -> Vector a -> Vector a
V.++ Vector a
acc
    )
    Vector a
forall a. Vector a
V.empty
    (View Identity -> Map ArchetypeID (Node Identity)
forall (m :: * -> *). View m -> Map ArchetypeID (Node m)
viewArchetypes View Identity
v)

-- | Query all matching entities in a `View`.
singleDyn :: DynamicQuery Identity a -> View Identity -> Maybe a
singleDyn :: forall a. DynamicQuery Identity a -> View Identity -> Maybe a
singleDyn DynamicQuery Identity a
q View Identity
v = case DynamicQuery Identity a -> View Identity -> Vector a
forall a. DynamicQuery Identity a -> View Identity -> Vector a
allDyn DynamicQuery Identity a
q View Identity
v of
  Vector a
as | Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> a -> Maybe a
forall a. a -> Maybe a
Just (Vector a -> a
forall a. Vector a -> a
V.head Vector a
as)
  Vector a
_ -> Maybe a
forall a. Maybe a
Nothing

-- | Map all matching entities in a `View`. Returns the results, updated view, and hooks to run.
mapDyn :: (Monad m) => DynamicQuery m a -> View m -> m (Vector a, View m, Access m ())
mapDyn :: forall (m :: * -> *) a.
Monad m =>
DynamicQuery m a -> View m -> m (Vector a, View m, Access m ())
mapDyn DynamicQuery m a
q View m
v = do
  (Vector a
as, Map ArchetypeID (Node m)
arches, Access m ()
hooks) <-
    ((Vector a, Map ArchetypeID (Node m), Access m ())
 -> (ArchetypeID, Node m)
 -> m (Vector a, Map ArchetypeID (Node m), Access m ()))
-> (Vector a, Map ArchetypeID (Node m), Access m ())
-> [(ArchetypeID, Node m)]
-> m (Vector a, Map ArchetypeID (Node m), Access m ())
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
      ( \(Vector a
acc, Map ArchetypeID (Node m)
archAcc, Access m ()
hooksAcc) (ArchetypeID
aId, Node m
n) -> do
          (Vector a
as', Archetype m
arch', Access m ()
hook) <- DynamicQuery m a
-> Archetype m -> m (Vector a, Archetype m, Access m ())
forall (m :: * -> *) a.
DynamicQuery m a
-> Archetype m -> m (Vector a, Archetype m, Access m ())
runDynQuery DynamicQuery m a
q (Archetype m -> m (Vector a, Archetype m, Access m ()))
-> Archetype m -> m (Vector a, Archetype m, Access m ())
forall a b. (a -> b) -> a -> b
$ Node m -> Archetype m
forall (m :: * -> *). Node m -> Archetype m
nodeArchetype Node m
n
          (Vector a, Map ArchetypeID (Node m), Access m ())
-> m (Vector a, Map ArchetypeID (Node m), Access m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector a
as' Vector a -> Vector a -> Vector a
forall a. Vector a -> Vector a -> Vector a
V.++ Vector a
acc, ArchetypeID
-> Node m -> Map ArchetypeID (Node m) -> Map ArchetypeID (Node m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ArchetypeID
aId (Node m
n {nodeArchetype = arch'}) Map ArchetypeID (Node m)
archAcc, Access m ()
hooksAcc Access m () -> Access m () -> Access m ()
forall a b. Access m a -> Access m b -> Access m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Access m ()
hook)
      )
      (Vector a
forall a. Vector a
V.empty, Map ArchetypeID (Node m)
forall k a. Map k a
Map.empty, () -> Access m ()
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
      (Map ArchetypeID (Node m) -> [(ArchetypeID, Node m)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ArchetypeID (Node m) -> [(ArchetypeID, Node m)])
-> Map ArchetypeID (Node m) -> [(ArchetypeID, Node m)]
forall a b. (a -> b) -> a -> b
$ View m -> Map ArchetypeID (Node m)
forall (m :: * -> *). View m -> Map ArchetypeID (Node m)
viewArchetypes View m
v)
  (Vector a, View m, Access m ())
-> m (Vector a, View m, Access m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector a
as, Map ArchetypeID (Node m) -> View m
forall (m :: * -> *). Map ArchetypeID (Node m) -> View m
View Map ArchetypeID (Node m)
arches, Access m ()
hooks)

-- | Map a single matching entity in a `View`. Returns the result, updated view, and hooks to run.
mapSingleDyn :: (Monad m) => DynamicQuery m a -> View m -> m (Maybe a, View m, Access m ())
mapSingleDyn :: forall (m :: * -> *) a.
Monad m =>
DynamicQuery m a -> View m -> m (Maybe a, View m, Access m ())
mapSingleDyn DynamicQuery m a
q View m
v = do
  (Vector a
as, View m
arches, Access m ()
hooks) <- DynamicQuery m a -> View m -> m (Vector a, View m, Access m ())
forall (m :: * -> *) a.
Monad m =>
DynamicQuery m a -> View m -> m (Vector a, View m, Access m ())
mapDyn DynamicQuery m a
q View m
v
  (Maybe a, View m, Access m ()) -> m (Maybe a, View m, Access m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe a, View m, Access m ())
 -> m (Maybe a, View m, Access m ()))
-> (Maybe a, View m, Access m ())
-> m (Maybe a, View m, Access m ())
forall a b. (a -> b) -> a -> b
$ case Vector a
as of
    Vector a
a | Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> (a -> Maybe a
forall a. a -> Maybe a
Just (Vector a -> a
forall a. Vector a -> a
V.head Vector a
a), View m
arches, Access m ()
hooks)
    Vector a
_ -> (Maybe a
forall a. Maybe a
Nothing, View m
arches, Access m ()
hooks)