diff --git a/aztecs.cabal b/aztecs.cabal index a54b2246..1c94d859 100644 --- a/aztecs.cabal +++ b/aztecs.cabal @@ -66,6 +66,7 @@ library base >=4.2 && <5, containers >=0.6, mtl >=2, + free, vector >=0.12 test-suite aztecs-test @@ -80,8 +81,7 @@ test-suite aztecs-test containers >=0.6, deepseq >=1, hspec >=2, - QuickCheck >=2, - vector >=0.12 + QuickCheck >=2 benchmark aztecs-bench type: exitcode-stdio-1.0 @@ -93,5 +93,4 @@ benchmark aztecs-bench base >=4.2 && <5, aztecs, criterion >=1, - deepseq >=1, - vector >=0.12 + deepseq >=1 \ No newline at end of file diff --git a/bench/Bench.hs b/bench/Bench.hs index 00d47579..1d7635bd 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -3,15 +3,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} import Aztecs.ECS import qualified Aztecs.ECS.Query as Q import Aztecs.ECS.World import qualified Aztecs.ECS.World as W import Control.DeepSeq +import Control.Monad.Fix import Criterion.Main -import Data.Functor.Identity (Identity (runIdentity)) -import Data.Vector (Vector) +import Data.Functor.Identity import GHC.Generics newtype Position = Position Int deriving (Show, Generic, NFData) @@ -22,13 +24,21 @@ newtype Velocity = Velocity Int deriving (Show, Generic, NFData) instance (Monad m) => Component m Velocity -move :: (Monad m) => Query m Position -move = queryMapWith (\(Velocity v) (Position p) -> (Position $ p + v)) query +move :: (Applicative f, Monad m) => Query f m (f Position) +move = do + vs <- Q.query + queryMap $ \ps -> (\(Velocity v) (Position p) -> Position $ p + v) <$> vs <*> ps -run :: Query Identity Position -> World Identity -> Vector Position +moveRec :: (Applicative f, MonadFix m) => Query f m (f Position) +moveRec = mdo + vs <- queryMap $ \vs' -> (\(Position p) (Velocity v) -> Velocity $ p + v) <$> ps <*> vs' + ps <- queryMap $ \ps' -> (\(Velocity v) (Position p) -> Position $ p + v) <$> vs <*> ps' + return ps + +run :: (forall f. (Applicative f) => Query f Identity (f Position)) -> World Identity -> [Position] run q = (\(a, _, _) -> a) . runIdentity . Q.runQuery q . entities -runSys :: Query Identity Position -> World Identity -> Vector Position +runSys :: (forall f. (Applicative f) => Query f Identity (f Position)) -> World Identity -> [Position] runSys q = fst . runIdentity . runAccess (system $ runQuery q) main :: IO () @@ -37,5 +47,7 @@ main = do !w = foldr (const go) W.empty [0 :: Int .. 10000] defaultMain [ bench "iter" $ nf (run move) w, - bench "iterSystem" $ nf (runSys move) w + bench "iterSystem" $ nf (runSys move) w, + bench "iterRec" $ nf (run moveRec) w, + bench "iterRecSystem" $ nf (runSys moveRec) w ] diff --git a/src/Aztecs/ECS.hs b/src/Aztecs/ECS.hs index 4de10b2d..08cd3cb3 100644 --- a/src/Aztecs/ECS.hs +++ b/src/Aztecs/ECS.hs @@ -59,19 +59,11 @@ module Aztecs.ECS MonoidDynamicBundle (..), Component (..), EntityID, - Query, + Query (..), + entity, query, - queryMaybe, queryMap, - queryMapM, - queryMapWith, - queryMapWith_, - queryMapWithM, queryMapAccum, - queryMapAccumM, - queryMapWithAccum, - queryMapWithAccumM, - DynamicQueryF (..), QueryFilter, with, without, @@ -102,20 +94,12 @@ import Aztecs.ECS.Observer observerGlobal, ) import Aztecs.ECS.Query - ( DynamicQueryF (..), - Query, + ( Query (..), QueryFilter, + entity, query, queryMap, queryMapAccum, - queryMapAccumM, - queryMapM, - queryMapWith, - queryMapWithAccum, - queryMapWithAccumM, - queryMapWithM, - queryMapWith_, - queryMaybe, with, without, ) diff --git a/src/Aztecs/ECS/Component.hs b/src/Aztecs/ECS/Component.hs index 5039e0fe..d8d35ad2 100644 --- a/src/Aztecs/ECS/Component.hs +++ b/src/Aztecs/ECS/Component.hs @@ -21,14 +21,13 @@ import Aztecs.ECS.Component.Internal (ComponentID (..)) import Aztecs.ECS.Entity import Aztecs.ECS.World.Storage import Data.Typeable -import Data.Vector (Vector) -- | Component that can be stored in the `World`. class (Monad m, Typeable a, Storage a (StorageT a)) => Component m a where -- | `Storage` of this component. type StorageT a - type StorageT a = Vector a + type StorageT a = [a] -- | Lifecycle hook called when a component is inserted. componentOnInsert :: EntityID -> a -> Access m () diff --git a/src/Aztecs/ECS/Observer.hs b/src/Aztecs/ECS/Observer.hs index dbbe63be..df19bfca 100644 --- a/src/Aztecs/ECS/Observer.hs +++ b/src/Aztecs/ECS/Observer.hs @@ -39,7 +39,6 @@ import Control.Monad.State import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable -import Data.Vector (Vector) -- | The kind of observer - either entity-specific or global. data ObserverKind m e @@ -64,7 +63,7 @@ instance Show (Observer m e) where show o = "Observer { kind = " ++ show (observerKind o) ++ ", id = " ++ show (observerId o) ++ " }" instance (Monad m, Typeable m, Event e) => Component m (Observer m e) where - type StorageT (Observer m e) = Vector (Observer m e) + type StorageT (Observer m e) = [Observer m e] componentOnInsert ownerEntity o = Access $ do !w <- get diff --git a/src/Aztecs/ECS/Query.hs b/src/Aztecs/ECS/Query.hs index cc35da2a..1f18143e 100644 --- a/src/Aztecs/ECS/Query.hs +++ b/src/Aztecs/ECS/Query.hs @@ -3,8 +3,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -18,37 +22,24 @@ -- Maintainer : matt@hunzinger.me -- Stability : provisional -- Portability : non-portable (GHC extensions) --- -- Query for matching entities. module Aztecs.ECS.Query ( -- * Queries Query (..), - DynamicQueryF (..), -- ** Operations + entity, query, - queryMaybe, + queryDyn, queryMap, - queryMap_, - queryMapM, - queryMapWith, - queryMapWith_, - queryMapWithM, queryMapAccum, - queryMapAccumM, - queryMapWithAccum, - queryMapWithAccumM, -- ** Running + runQuery', readQuery, - readQuery', readQuerySingle, - readQuerySingle', - readQuerySingleMaybe, - readQuerySingleMaybe', runQuery, runQuerySingle, - runQuerySingleMaybe, -- * Filters QueryFilter (..), @@ -58,215 +49,178 @@ module Aztecs.ECS.Query -- * Reads and writes ReadsWrites (..), disjoint, + + -- * Re-exports + DynamicQueryF, ) where -import Aztecs.ECS.Access.Internal (Access) +import Aztecs.ECS.Access.Internal import Aztecs.ECS.Component -import Aztecs.ECS.Query.Dynamic +import Aztecs.ECS.Entity +import Aztecs.ECS.Query.Dynamic hiding (entity, queryDyn) +import qualified Aztecs.ECS.Query.Dynamic as DQ +import Aztecs.ECS.World.Archetype (Archetype) +import qualified Aztecs.ECS.World.Archetype as A import Aztecs.ECS.World.Components (Components) import qualified Aztecs.ECS.World.Components as CS import Aztecs.ECS.World.Entities (Entities (..)) -import qualified Aztecs.ECS.World.Entities as E +import Control.Applicative +import Control.Applicative.Free +import Control.Monad.Fix +import Control.Monad.Free +import Control.Monad.Reader +import Control.Monad.State import Data.Set (Set) import qualified Data.Set as Set -import Data.Vector (Vector) import GHC.Stack import Prelude hiding (reads) --- | Query for matching entities. -newtype Query m a = Query - { -- | Run a query, producing a `DynamicQuery`. - -- - -- @since 0.10 - runQuery' :: Components -> (ReadsWrites, Components, DynamicQuery m a) - } - deriving (Functor) - -instance (Monad m) => Applicative (Query m) where - pure a = Query (mempty,,pure a) - {-# INLINE pure #-} - - (Query f) <*> (Query g) = Query $ \cs -> - let !(cIdsG, cs', aQS) = g cs - !(cIdsF, cs'', bQS) = f cs' - in (cIdsG <> cIdsF, cs'', bQS <*> aQS) - {-# INLINE (<*>) #-} - -instance (Monad m) => DynamicQueryF m (Query m) where - entity = Query (mempty,,entity) - {-# INLINE entity #-} - - queryDyn = dynQueryReader queryDyn - {-# INLINE queryDyn #-} - - queryMaybeDyn = dynQueryReader queryMaybeDyn - {-# INLINE queryMaybeDyn #-} - - queryMapDyn f = dynQueryWriter' $ queryMapDyn f - {-# INLINE queryMapDyn #-} - - queryMapDyn_ f = dynQueryWriter' $ queryMapDyn_ f - {-# INLINE queryMapDyn_ #-} - - queryMapDynM f = dynQueryWriter' $ queryMapDynM f - {-# INLINE queryMapDynM #-} - - queryMapDynWith f = dynQueryWriter $ queryMapDynWith f - {-# INLINE queryMapDynWith #-} +data Op f m a where + EntityOp :: Op f m (f EntityID) + QueryOp :: (Component m a) => ComponentID -> Op f m (f a) + QueryMapOp :: (Component m a) => ComponentID -> (f a -> f a) -> Op f m (f a) + QueryMapAccumOp :: (Component m b) => ComponentID -> (f b -> f (a, b)) -> Op f m (f (a, b)) + QueryFix :: (MonadFix m) => (a -> QueryPlan f m a) -> Op f m a - queryMapDynWith_ f = dynQueryWriter $ queryMapDynWith_ f - {-# INLINE queryMapDynWith_ #-} +newtype QueryPlan f m a = QueryPlan {unQueryPlan :: Free (Ap (Op f m)) a} + deriving (Functor, Applicative, Monad) - queryMapDynWithM f = dynQueryWriter $ queryMapDynWithM f - {-# INLINE queryMapDynWithM #-} +instance (MonadFix m) => MonadFix (QueryPlan f m) where + mfix = QueryPlan . liftF . liftAp . QueryFix + {-# INLINE mfix #-} - queryMapDynWithAccum f = dynQueryWriter $ queryMapDynWithAccum f - {-# INLINE queryMapDynWithAccum #-} - - queryUntracked (Query q) = Query $ \cs -> - let !(rws, cs', dynQ) = q cs - in (rws, cs', queryUntracked dynQ) - {-# INLINE queryUntracked #-} - - queryMapDynWithAccumM f = dynQueryWriter $ queryMapDynWithAccumM f - {-# INLINE queryMapDynWithAccumM #-} +-- | Query for matching entities. +newtype Query f m a = Query {unQuery :: ReaderT Components (QueryPlan f m) a} + deriving (Functor, Applicative, Monad, MonadFix) - queryFilterMap p (Query q) = Query $ \cs -> - let !(rws, cs', dynQ) = q cs - in (rws, cs', queryFilterMap p dynQ) - {-# INLINE queryFilterMap #-} +-- | Query the entity ID. +entity :: forall f m. (Applicative f) => Query f m (f EntityID) +entity = Query . lift . QueryPlan . liftF . liftAp $ EntityOp +{-# INLINE entity #-} -- | Query a component. -query :: forall m a. (Monad m, Component m a) => Query m a -query = queryReader @m @a queryDyn +query :: forall f m a. (Applicative f, Component m a) => Query f m (f a) +query = Query $ do + cs <- ask + let !(cId, _) = CS.insert @a @m cs + lift . QueryPlan . liftF . liftAp $ QueryOp cId {-# INLINE query #-} --- | Optionally query a component, returning @Nothing@ if it does not exist. -queryMaybe :: forall m a. (Monad m, Component m a) => Query m (Maybe a) -queryMaybe = queryReader @m @a queryMaybeDyn -{-# INLINE queryMaybe #-} - -- | Query a component and update it. -queryMap :: forall m a. (Monad m, Component m a) => (a -> a) -> Query m a -queryMap f = queryWriter' @m @a $ queryMapDyn f +queryMap :: forall f m a. (Applicative f, Component m a) => (f a -> f a) -> Query f m (f a) +queryMap f = Query $ do + cs <- ask + let !(cId, _) = CS.insert @a @m cs + lift . QueryPlan . liftF . liftAp $ QueryMapOp cId f {-# INLINE queryMap #-} --- | Query a component and update it, ignoring any output. -queryMap_ :: forall m a. (Monad m, Component m a) => (a -> a) -> Query m () -queryMap_ f = queryWriter' @m @a $ queryMapDyn_ f -{-# INLINE queryMap_ #-} - --- | Query a component and update it with a monadic action. -queryMapM :: forall m a. (Monad m, Component m a) => (a -> m a) -> Query m a -queryMapM f = queryWriter' @m @a $ queryMapDynM f -{-# INLINE queryMapM #-} - --- | Query a component with input and update it. -queryMapWith :: forall m a b. (Monad m, Component m b) => (a -> b -> b) -> Query m a -> Query m b -queryMapWith f = queryWriter @m @b $ queryMapDynWith f -{-# INLINE queryMapWith #-} - --- | Query a component with input and update it, ignoring any output. -queryMapWith_ :: forall m a b. (Monad m, Component m b) => (a -> b -> b) -> Query m a -> Query m () -queryMapWith_ f = queryWriter @m @b $ queryMapDynWith_ f -{-# INLINE queryMapWith_ #-} - --- | Query a component with input and update it with a monadic action. -queryMapWithM :: - forall m a b. - (Monad m, Component m b) => - (a -> b -> m b) -> - Query m a -> - Query m b -queryMapWithM f = queryWriter @m @b $ queryMapDynWithM f -{-# INLINE queryMapWithM #-} - -- | Query a component with input, returning a tuple of the result and the updated component. -queryMapAccum :: - forall m a b. - (Monad m, Component m b) => - (b -> (a, b)) -> - Query m (a, b) -queryMapAccum f = queryMapWithAccum (const f) (pure ()) +queryMapAccum :: forall f m a b. (Applicative f, Component m b) => (f b -> f (a, b)) -> Query f m (f (a, b)) +queryMapAccum f = Query $ do + cs <- ask + let !(cId, _) = CS.insert @b @m cs + lift . QueryPlan . liftF . liftAp $ QueryMapAccumOp cId f {-# INLINE queryMapAccum #-} --- | Query a component with input and update it with a monadic action, returning a tuple. -queryMapAccumM :: - forall m a b. - (Monad m, Component m b) => - (b -> m (a, b)) -> - Query m (a, b) -queryMapAccumM f = queryMapWithAccumM (const f) (pure ()) -{-# INLINE queryMapAccumM #-} +newtype Fetch a = Fetch (Const () a) + deriving (Functor, Applicative) + +buildQueryPlan :: (Monad m) => QueryPlan ZipList m (ZipList a) -> DynamicQuery m a +buildQueryPlan a = DynamicQuery $ \arch -> do + (as, (arch', hooks)) <- runStateT (foldFree (runAp go) $ unQueryPlan a) (arch, pure ()) + return (getZipList as, arch', hooks) + where + go :: (Monad m) => Op ZipList m x -> StateT (Archetype m, Access m ()) m x + go = \case + EntityOp -> do + (arch, _) <- get + return $ ZipList $ Set.toList $ A.entities arch + QueryOp cId -> do + (arch, hooks) <- get + (as, arch', hooks') <- lift $ runDynQuery (DQ.queryDyn cId) arch + put (arch', hooks >> hooks') + return (ZipList as) + QueryMapOp cId f -> do + (arch, hooks) <- get + let (arch', as') = A.alterComponentsAsc (getZipList . f . ZipList) cId arch + put (arch', hooks) + return (ZipList as') + QueryMapAccumOp cId f -> do + (arch, hooks) <- get + let f' = fmap (\(a', b) -> (b, (a', b))) . getZipList . f . ZipList + (arch', xs) = A.zipAlterComponentsAsc f' cId arch + put (arch', hooks) + return (ZipList xs) + QueryFix f -> mfix $ \x -> foldFree (runAp go) $ unQueryPlan (f x) + +runQuery' :: (Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> Components -> (ReadsWrites, Components, DynamicQuery m a) +runQuery' q cs = + let actionFetch = runReaderT (unQuery q) cs + (_, rws) = runState (foldFree (runAp go) (unQueryPlan actionFetch)) mempty + in (rws, cs, buildQueryPlan $ runReaderT (unQuery q) cs) + where + go :: Op Fetch m x -> State ReadsWrites x + go = \case + EntityOp -> return (Fetch (Const ())) + (QueryOp cId) -> do + modify (\rws -> rws {reads = Set.insert cId (reads rws)}) + return (Fetch (Const ())) + (QueryMapOp cId _) -> do + modify (\rws -> rws {writes = Set.insert cId (writes rws)}) + return (Fetch (Const ())) + (QueryMapAccumOp cId _) -> do + modify (\rws -> rws {writes = Set.insert cId (writes rws)}) + return (Fetch (Const ())) + (QueryFix f) -> mfix $ \x -> foldFree (runAp go) $ unQueryPlan (f x) + +-- | Query a component dynamically by 'ComponentID'. +queryDyn :: forall f m a. (Applicative f, Component m a, Monad m) => ComponentID -> Query f m (f a) +queryDyn cId = Query . lift . QueryPlan . liftF . liftAp $ QueryOp cId +{-# INLINE queryDyn #-} + +-- | Read all matching entities. +readQuery :: (Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> Entities m -> m [a] +readQuery = runner readQueryDyn +{-# INLINE readQuery #-} --- | Query a component with input, returning a tuple of the result and the updated component. -queryMapWithAccum :: - forall m a b c. - (Monad m, Component m c) => - (b -> c -> (a, c)) -> - Query m b -> - Query m (a, c) -queryMapWithAccum f = queryWriter @m @c $ queryMapDynWithAccum f -{-# INLINE queryMapWithAccum #-} - --- | Query a component with input and update it with a monadic action, returning a tuple. -queryMapWithAccumM :: - forall m a b c. - (Monad m, Component m c) => - (b -> c -> m (a, c)) -> - Query m b -> - Query m (a, c) -queryMapWithAccumM f = queryWriter @m @c $ queryMapDynWithAccumM f -{-# INLINE queryMapWithAccumM #-} - -dynQueryReader :: (ComponentID -> DynamicQuery m a) -> ComponentID -> Query m a -dynQueryReader f cId = Query (ReadsWrites {reads = Set.singleton cId, writes = Set.empty},,f cId) -{-# INLINE dynQueryReader #-} - -dynQueryWriter :: - ( ComponentID -> - DynamicQuery m a -> - DynamicQuery m b - ) -> - ComponentID -> - Query m a -> - Query m b -dynQueryWriter f cId q = Query $ \cs -> - let !(rws, cs', dynQ) = runQuery' q cs - in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs', f cId dynQ) -{-# INLINE dynQueryWriter #-} - -dynQueryWriter' :: (ComponentID -> DynamicQuery m a) -> ComponentID -> Query m a -dynQueryWriter' f cId = Query (ReadsWrites {reads = Set.empty, writes = Set.singleton cId},,f cId) -{-# INLINE dynQueryWriter' #-} - -queryReader :: forall m a b. (Component m a) => (ComponentID -> DynamicQuery m b) -> Query m b -queryReader f = Query $ \cs -> - let !(cId, cs') = CS.insert @a @m cs - in (ReadsWrites {reads = Set.singleton cId, writes = Set.empty}, cs', f cId) -{-# INLINE queryReader #-} - -queryWriter :: - forall m a b c. - (Component m a) => - ( ComponentID -> - DynamicQuery m b -> - DynamicQuery m c - ) -> - Query m b -> - Query m c -queryWriter f (Query g) = Query $ \cs -> - let !(rws, cs', dynQ) = g cs - !(cId, cs'') = CS.insert @a @m cs' - in (rws <> ReadsWrites Set.empty (Set.singleton cId), cs'', f cId dynQ) -{-# INLINE queryWriter #-} - -queryWriter' :: forall m a b. (Component m a) => (ComponentID -> DynamicQuery m b) -> Query m b -queryWriter' f = Query $ \cs -> - let !(cId, cs') = CS.insert @a @m cs - in (ReadsWrites {reads = Set.empty, writes = Set.singleton cId}, cs', f cId) -{-# INLINE queryWriter' #-} +-- | Read a single matching entity. +readQuerySingle :: + (HasCallStack, Monad m) => + (forall f. (Applicative f) => Query f m (f a)) -> + Entities m -> + m a +readQuerySingle = runner readQuerySingleDyn +{-# INLINE readQuerySingle #-} + +-- | Run a query on all matching entities, potentially modifying them. +runQuery :: + (Monad m) => + (forall f. (Applicative f) => Query f m (f a)) -> + Entities m -> + m ([a], Entities m, Access m ()) +runQuery = runner runQueryDyn +{-# INLINE runQuery #-} + +-- | Run a query on a single matching entity, potentially modifying it. +runQuerySingle :: + (HasCallStack, Monad m) => + (forall f. (Applicative f) => Query f m (f a)) -> + Entities m -> + m (a, Entities m, Access m ()) +runQuerySingle = runner runQuerySingleDyn +{-# INLINE runQuerySingle #-} + +runner :: + (Monad m) => + (Set ComponentID -> DynamicQuery m a -> Entities m -> t) -> + (forall f. (Applicative f) => Query f m (f a)) -> + Entities m -> + t +runner f q es = + let (rws, cs', dynQ) = runQuery' q $ components es + in f (reads rws <> writes rws) dynQ es {components = cs'} +{-# INLINE runner #-} -- | Reads and writes of a `Query`. data ReadsWrites = ReadsWrites @@ -292,89 +246,6 @@ disjoint a b = || Set.disjoint (reads b) (writes a) || Set.disjoint (writes b) (writes a) --- | Match all entities. -readQuery :: (Monad m) => Query m a -> Entities m -> m (Vector a, Entities m) -readQuery q es = do - (as, cs) <- readQuery' q es - return (as, es {E.components = cs}) -{-# INLINE readQuery #-} - --- | Match all entities. -readQuery' :: (Monad m) => Query m a -> Entities m -> m (Vector a, Components) -readQuery' q es = do - let !(rws, cs', dynQ) = runQuery' q (E.components es) - !cIds = reads rws <> writes rws - as <- readQueryDyn cIds dynQ es - return (as, cs') -{-# INLINE readQuery' #-} - --- | Match a single entity. -readQuerySingle :: (HasCallStack, Monad m) => Query m a -> Entities m -> m (a, Entities m) -readQuerySingle q es = do - (a, cs) <- readQuerySingle' q es - return (a, es {E.components = cs}) -{-# INLINE readQuerySingle #-} - --- | Match a single entity. -readQuerySingle' :: (HasCallStack, Monad m) => Query m a -> Entities m -> m (a, Components) -readQuerySingle' q es = do - let !(rws, cs', dynQ) = runQuery' q (E.components es) - !cIds = reads rws <> writes rws - a <- readQuerySingleDyn cIds dynQ es - return (a, cs') -{-# INLINE readQuerySingle' #-} - --- | Match a single entity. -readQuerySingleMaybe :: (Monad m) => Query m a -> Entities m -> m (Maybe a, Entities m) -readQuerySingleMaybe q es = do - (a, cs) <- readQuerySingleMaybe' q es - return (a, es {E.components = cs}) -{-# INLINE readQuerySingleMaybe #-} - --- | Match a single entity. -readQuerySingleMaybe' :: (Monad m) => Query m a -> Entities m -> m (Maybe a, Components) -readQuerySingleMaybe' q es = do - let !(rws, cs', dynQ) = runQuery' q (E.components es) - !cIds = reads rws <> writes rws - a <- readQuerySingleMaybeDyn cIds dynQ es - return (a, cs') -{-# INLINE readQuerySingleMaybe' #-} - --- | Map all matched entities. -runQuery :: (Monad m) => Query m o -> Entities m -> m (Vector o, Entities m, Access m ()) -runQuery q es = do - let !(rws, cs', dynQ) = runQuery' q $ components es - !cIds = reads rws <> writes rws - (as, es', hook) <- runQueryDyn cIds dynQ es - return (as, es' {components = cs'}, hook) -{-# INLINE runQuery #-} - --- | Map a single matched entity. -runQuerySingle :: - (HasCallStack, Monad m) => - Query m a -> - Entities m -> - m (a, Entities m, Access m ()) -runQuerySingle q es = do - let !(rws, cs', dynQ) = runQuery' q $ components es - !cIds = reads rws <> writes rws - (as, es', hook) <- runQuerySingleDyn cIds dynQ es - return (as, es' {components = cs'}, hook) -{-# INLINE runQuerySingle #-} - --- | Map a single matched entity, or `Nothing`. -runQuerySingleMaybe :: - (Monad m) => - Query m a -> - Entities m -> - m (Maybe a, Entities m, Access m ()) -runQuerySingleMaybe q es = do - let !(rws, cs', dynQ) = runQuery' q $ components es - !cIds = reads rws <> writes rws - (as, es', hook) <- runQuerySingleMaybeDyn cIds dynQ es - return (as, es' {components = cs'}, hook) -{-# INLINE runQuerySingleMaybe #-} - -- | Filter for a `Query`. newtype QueryFilter = QueryFilter { -- | Run a query filter. diff --git a/src/Aztecs/ECS/Query/Dynamic.hs b/src/Aztecs/ECS/Query/Dynamic.hs index b3ca40c8..f66eac8e 100644 --- a/src/Aztecs/ECS/Query/Dynamic.hs +++ b/src/Aztecs/ECS/Query/Dynamic.hs @@ -47,8 +47,6 @@ import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Vector (Vector) -import qualified Data.Vector as V import GHC.Stack -- | Dynamic query for components by ID. @@ -57,12 +55,12 @@ newtype DynamicQuery m a { -- | Run a dynamic query. -- -- @since 0.10 - runDynQuery :: Archetype m -> m (Vector a, Archetype m, Access m ()) + runDynQuery :: Archetype m -> m ([a], Archetype m, Access m ()) } deriving (Functor) instance (Monad m) => Applicative (DynamicQuery m) where - pure a = DynamicQuery $ \arch -> pure (V.replicate (length $ A.entities arch) a, arch, return ()) + pure a = DynamicQuery $ \arch -> pure (replicate (length $ A.entities arch) a, arch, return ()) {-# INLINE pure #-} f <*> g = DynamicQuery $ \arch -> do @@ -71,33 +69,33 @@ instance (Monad m) => Applicative (DynamicQuery m) where return $ let (as, arch', hook1) = x (bs, arch'', hook2) = y - in (V.zipWith ($) bs as, arch' <> arch'', hook1 >> hook2) + in (zipWith ($) bs as, arch' <> arch'', hook1 >> hook2) {-# INLINE (<*>) #-} instance (Monad m) => DynamicQueryF m (DynamicQuery m) where - entity = DynamicQuery $ \arch -> pure (V.fromList . Set.toList $ A.entities arch, arch, return ()) + entity = DynamicQuery $ \arch -> pure (Set.toList $ A.entities arch, arch, return ()) {-# INLINE entity #-} queryDyn cId = DynamicQuery $ \arch -> pure (A.lookupComponentsAsc cId arch, arch, return ()) {-# INLINE queryDyn #-} queryMaybeDyn cId = DynamicQuery $ \arch -> case A.lookupComponentsAscMaybe cId arch of - Just as -> pure (V.map Just as, arch, return ()) - Nothing -> pure (V.replicate (length $ A.entities arch) Nothing, arch, return ()) + Just as -> pure (map Just as, arch, return ()) + Nothing -> pure (replicate (length $ A.entities arch) Nothing, arch, return ()) {-# INLINE queryMaybeDyn #-} queryMapDyn f cId = DynamicQuery $ \arch -> do - let (cs, arch', hook) = A.zipWith (V.replicate (length $ A.entities arch) ()) (const f) cId arch + let (cs, arch', hook) = A.zipWith (replicate (length $ A.entities arch) ()) (const f) cId arch return (cs, arch', hook) {-# INLINE queryMapDyn #-} queryMapDyn_ f cId = DynamicQuery $ \arch -> do - let (arch', hook) = A.zipWith_ (V.replicate (length $ A.entities arch) ()) (const f) cId arch - return (V.replicate (length $ A.entities arch) (), arch', hook) + let (arch', hook) = A.zipWith_ (replicate (length $ A.entities arch) ()) (const f) cId arch + return (replicate (length $ A.entities arch) (), arch', hook) {-# INLINE queryMapDyn_ #-} queryMapDynM f cId = DynamicQuery $ \arch -> do - (cs, arch', hook) <- A.zipWithM (V.replicate (length $ A.entities arch) ()) (const f) cId arch + (cs, arch', hook) <- A.zipWithM (replicate (length $ A.entities arch) ()) (const f) cId arch return (cs, arch', hook) {-# INLINE queryMapDynM #-} @@ -110,7 +108,7 @@ instance (Monad m) => DynamicQueryF m (DynamicQuery m) where queryMapDynWith_ f cId q = DynamicQuery $ \arch -> do (as, arch', hook1) <- runDynQuery q arch let (arch'', hook2) = A.zipWith_ as f cId arch' - return (V.map (const ()) as, arch'', hook1 >> hook2) + return (map (const ()) as, arch'', hook1 >> hook2) {-# INLINE queryMapDynWith_ #-} queryMapDynWithM f cId q = DynamicQuery $ \arch -> do @@ -138,51 +136,54 @@ instance (Monad m) => DynamicQueryF m (DynamicQuery m) where queryFilterMap p q = DynamicQuery $ \arch -> do (as, _, _) <- runDynQuery q arch - let eIds = V.fromList . Set.toList $ A.entities arch - mapped = V.map p as - (filteredEIds, indices, filteredBs) = V.unzip3 . V.imapMaybe (\i (e, mb) -> (\b -> (e, i, b)) <$> mb) $ V.zip eIds mapped + let eIds = Set.toList $ A.entities arch + mapped = map p as + withIndices = zip3 eIds [0 ..] mapped + filtered = [(e, i, b) | (e, i, Just b) <- withIndices] + (filteredEIds, indices, filteredBs) = unzip3 filtered filteredArch = filterArchetype indices arch - (_, filteredArch', hook) <- runDynQuery q filteredArch {A.entities = Set.fromList $ V.toList filteredEIds} + (_, filteredArch', hook) <- runDynQuery q filteredArch {A.entities = Set.fromList filteredEIds} let resultArch = unfilterArchetype indices arch filteredArch' return (filteredBs, resultArch, hook) where filterArchetype indices arch = arch {A.storages = IntMap.map (filterStorage indices) $ A.storages arch} filterStorage indices s = - let allVec = toAscVectorDyn s - filteredVec = V.map (allVec V.!) indices - in fromAscVectorDyn filteredVec s + let allList = toAscListDyn s + filteredList = map (allList !!) indices + in fromAscListDyn filteredList s unfilterArchetype indices original filtered = original {A.storages = IntMap.mapWithKey go $ A.storages original} where go cId s = case IntMap.lookup cId (A.storages filtered) of Just filteredStorage -> - let origVec = toAscVectorDyn s - filteredVec = toAscVectorDyn filteredStorage - mergedVec = V.accum (\_ new -> new) origVec (V.toList $ V.zip indices filteredVec) - in fromAscVectorDyn mergedVec s + let origList = toAscListDyn s + filteredList = toAscListDyn filteredStorage + updates = zip indices filteredList + mergedList = foldr (\(i, v) acc -> take i acc ++ [v] ++ drop (i + 1) acc) origList updates + in fromAscListDyn mergedList s Nothing -> s {-# INLINE queryFilterMap #-} -- | Match all entities. -readQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Vector a) +readQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m [a] readQueryDyn cIds q es = if Set.null cIds then (\(a, _, _) -> a) <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} else do let go n = (\(a, _, _) -> a) <$> runDynQuery q (AS.nodeArchetype n) results <- mapM go . Map.elems $ AS.find cIds $ archetypes es - return $ V.concat results + return $ concat results -- | Match all entities with a filter. -readQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m (Vector a) +readQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m [a] readQueryFilteredDyn cIds f q es = if Set.null cIds then (\(a, _, _) -> a) <$> runDynQuery q A.empty {A.entities = Map.keysSet $ entities es} else do let go n = (\(a, _, _) -> a) <$> runDynQuery q (AS.nodeArchetype n) results <- mapM go . Map.elems . Map.filter f $ AS.find cIds $ archetypes es - return $ V.concat results + return $ concat results -- | Match a single entity. readQuerySingleDyn :: (HasCallStack, Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m a @@ -199,16 +200,20 @@ readQuerySingleMaybeDyn cIds q es = then case Map.keys $ entities es of [eId] -> do (v, _, _) <- runDynQuery q $ A.singleton eId - return $ if V.length v == 1 then Just (V.head v) else Nothing + return $ case v of + [x] -> Just x + _ -> Nothing _ -> return Nothing else case Map.elems $ AS.find cIds $ archetypes es of [n] -> do (v, _, _) <- runDynQuery q $ AS.nodeArchetype n - return $ if V.length v == 1 then Just (V.head v) else Nothing + return $ case v of + [x] -> Just x + _ -> Nothing _ -> return Nothing -- | Map all matched entities. -runQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m (Vector a, Entities m, Access m ()) +runQueryDyn :: (Monad m) => Set ComponentID -> DynamicQuery m a -> Entities m -> m ([a], Entities m, Access m ()) runQueryDyn cIds q es = let go = runDynQuery q in if Set.null cIds @@ -219,12 +224,12 @@ runQueryDyn cIds q es = let go' (acc, esAcc, hooks) (aId, n) = do (as', arch', hook) <- go $ nodeArchetype n let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc - return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) - in foldlM go' (V.empty, es, return ()) $ Map.toList . AS.find cIds $ archetypes es + return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) + in foldlM go' ([], es, return ()) $ Map.toList . AS.find cIds $ archetypes es {-# INLINE runQueryDyn #-} -- | Map all matched entities. -runQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m (Vector a, Entities m, Access m ()) +runQueryFilteredDyn :: (Monad m) => Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> Entities m -> m ([a], Entities m, Access m ()) runQueryFilteredDyn cIds f q es = let go = runDynQuery q in if Set.null cIds @@ -235,8 +240,8 @@ runQueryFilteredDyn cIds f q es = let go' (acc, esAcc, hooks) (aId, n) = do (as', arch', hook) <- go $ nodeArchetype n let !nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes esAcc - return (as' V.++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) - in foldlM go' (V.empty, es, return ()) $ Map.toList . Map.filter f . AS.find cIds $ archetypes es + return (as' ++ acc, esAcc {archetypes = (archetypes esAcc) {AS.nodes = nodes}}, hooks >> hook) + in foldlM go' ([], es, return ()) $ Map.toList . Map.filter f . AS.find cIds $ archetypes es {-# INLINE runQueryFilteredDyn #-} -- | Map a single matched entity. @@ -255,17 +260,16 @@ runQuerySingleMaybeDyn cIds q es = [eId] -> do res <- runDynQuery q $ A.singleton eId return $ case res of - (v, _, hook) | V.length v == 1 -> (Just (V.head v), es, hook) + ([x], _, hook) -> (Just x, es, hook) _ -> (Nothing, es, return ()) _ -> pure (Nothing, es, return ()) else case Map.toList $ AS.find cIds $ archetypes es of [(aId, n)] -> do res <- runDynQuery q $ AS.nodeArchetype n return $ case res of - (v, arch', hook) - | V.length v == 1 -> - let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es - in (Just (V.head v), es {archetypes = (archetypes es) {AS.nodes = nodes}}, hook) + ([x], arch', hook) -> + let nodes = Map.insert aId n {nodeArchetype = arch' <> nodeArchetype n} . AS.nodes $ archetypes es + in (Just x, es {archetypes = (archetypes es) {AS.nodes = nodes}}, hook) _ -> (Nothing, es, return ()) _ -> pure (Nothing, es, return ()) {-# INLINE runQuerySingleMaybeDyn #-} diff --git a/src/Aztecs/ECS/System.hs b/src/Aztecs/ECS/System.hs index bf968aed..5f13b8b4 100644 --- a/src/Aztecs/ECS/System.hs +++ b/src/Aztecs/ECS/System.hs @@ -46,7 +46,7 @@ module Aztecs.ECS.System where import Aztecs.ECS.Component -import Aztecs.ECS.Query (Query (..), QueryFilter (..)) +import Aztecs.ECS.Query (Query, QueryFilter (..)) import qualified Aztecs.ECS.Query as Q import Aztecs.ECS.Query.Dynamic (DynamicQuery, DynamicQueryFilter (..)) import Aztecs.ECS.System.Dynamic (DynamicSystem (..), runDynamicSystem) @@ -56,7 +56,6 @@ import Aztecs.ECS.World.Archetypes (Node (..)) import Aztecs.ECS.World.Components (Components) import qualified Data.Foldable as F import Data.Set (Set) -import Data.Vector (Vector) import GHC.Stack import Prelude hiding (all, filter, map, mapM) @@ -78,65 +77,65 @@ instance Applicative (System m) where in (cs'', dynF <*> dynG) {-# INLINE (<*>) #-} -runner :: (Set ComponentID -> DynamicQuery m a -> DynamicSystem m b) -> Query m a -> System m b +runner :: (Monad m) => (Set ComponentID -> DynamicQuery m a -> DynamicSystem m b) -> (forall f. (Applicative f) => Query f m (f a)) -> System m b runner f q = System $ \cs -> - let (rws, cs', dynQ) = runQuery' q cs + let (rws, cs', dynQ) = Q.runQuery' q cs in (cs', f (Q.reads rws <> Q.writes rws) dynQ) -- | Match all entities. -readQuery :: (Monad m) => Query m a -> System m (Vector a) +readQuery :: (Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> System m [a] readQuery = runner DS.readQuery -readQuerySingle :: (HasCallStack, Monad m) => Query m a -> System m a +readQuerySingle :: (HasCallStack, Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> System m a readQuerySingle = runner DS.readQuerySingle -readQuerySingleMaybe :: (Monad m) => Query m a -> System m (Maybe a) +readQuerySingleMaybe :: (Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> System m (Maybe a) readQuerySingleMaybe = runner DS.readQuerySingleMaybe -- | Match all entities with a filter. -readQueryFiltered :: (Monad m) => Query m a -> QueryFilter -> System m (Vector a) -readQueryFiltered q f = System $ \cs -> - let (rws, cs', dynQ) = runQuery' q cs - (dynF, cs'') = runQueryFilter f cs' +readQueryFiltered :: (Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> QueryFilter -> System m [a] +readQueryFiltered q qf = System $ \cs -> + let (rws, cs', dynQ) = Q.runQuery' q cs + (dynF, cs'') = runQueryFilter qf cs' flt n = F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF) && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF) in (cs'', DS.readQueryFiltered (Q.reads rws <> Q.writes rws) flt dynQ) -- | Map all matching entities. -runQuery :: (Monad m) => Query m a -> System m (Vector a) +runQuery :: (Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> System m [a] runQuery = runner DS.runQuery -runQuerySingle :: (HasCallStack, Monad m) => Query m a -> System m a +runQuerySingle :: (HasCallStack, Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> System m a runQuerySingle = runner DS.runQuerySingle -- | Map a single matching entity, or @Nothing@. -runQuerySingleMaybe :: (Monad m) => Query m a -> System m (Maybe a) +runQuerySingleMaybe :: (Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> System m (Maybe a) runQuerySingleMaybe = runner DS.runQuerySingleMaybe -- | Filter and map all matching entities. -runQueryFiltered :: (Monad m) => Query m a -> QueryFilter -> System m (Vector a) -runQueryFiltered q f = System $ \cs -> - let (rws, cs', dynQ) = runQuery' q cs - (dynF, cs'') = runQueryFilter f cs' +runQueryFiltered :: (Monad m) => (forall f. (Applicative f) => Query f m (f a)) -> QueryFilter -> System m [a] +runQueryFiltered q qf = System $ \cs -> + let (rws, cs', dynQ) = Q.runQuery' q cs + (dynF, cs'') = runQueryFilter qf cs' flt n = F.all (\cId -> A.member cId $ nodeArchetype n) (filterWith dynF) && F.all (\cId -> not (A.member cId $ nodeArchetype n)) (filterWithout dynF) in (cs'', DS.runQueryFiltered (Q.reads rws <> Q.writes rws) dynQ flt) -- | Match all entities with a dynamic query. -readQueryDyn :: Set ComponentID -> DynamicQuery m a -> System m (Vector a) +readQueryDyn :: Set ComponentID -> DynamicQuery m a -> System m [a] readQueryDyn cIds q = System (,DS.readQuery cIds q) readQuerySingleMaybeDyn :: Set ComponentID -> DynamicQuery m a -> System m (Maybe a) readQuerySingleMaybeDyn cIds q = System (,DS.readQuerySingleMaybe cIds q) -- | Match all entities with a dynamic query and filter. -readQueryFilteredDyn :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> System m (Vector a) +readQueryFilteredDyn :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> System m [a] readQueryFilteredDyn cIds q f = System (,DS.readQueryFiltered cIds f q) -- | Map all entities with a dynamic query. -runQueryDyn :: Set ComponentID -> DynamicQuery m a -> System m (Vector a) +runQueryDyn :: Set ComponentID -> DynamicQuery m a -> System m [a] runQueryDyn cIds q = System (,DS.runQuery cIds q) -- | Map a single entity with a dynamic query. @@ -144,5 +143,5 @@ runQuerySingleMaybeDyn :: Set ComponentID -> DynamicQuery m a -> System m (Maybe runQuerySingleMaybeDyn cIds q = System (,DS.runQuerySingleMaybe cIds q) -- | Filter and map all entities with a dynamic query. -runQueryFilteredDyn :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> System m (Vector a) +runQueryFilteredDyn :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> System m [a] runQueryFilteredDyn cIds f q = System (,DS.runQueryFiltered cIds q f) diff --git a/src/Aztecs/ECS/System/Dynamic.hs b/src/Aztecs/ECS/System/Dynamic.hs index 85a82c92..9ab2772b 100644 --- a/src/Aztecs/ECS/System/Dynamic.hs +++ b/src/Aztecs/ECS/System/Dynamic.hs @@ -41,17 +41,16 @@ import qualified Aztecs.ECS.Query.Dynamic as DQ import Aztecs.ECS.World.Archetypes (Node (..)) import Aztecs.ECS.World.Entities (Entities) import Data.Set (Set) -import Data.Vector (Vector) import Prelude hiding (all, filter, map, mapM) -- | Query operation. data Op m a where - RunQuery :: DynamicQuery m a -> Op m (Vector a) - RunFiltered :: (Node m -> Bool) -> DynamicQuery m a -> Op m (Vector a) + RunQuery :: DynamicQuery m a -> Op m [a] + RunFiltered :: (Node m -> Bool) -> DynamicQuery m a -> Op m [a] RunQuerySingle :: DynamicQuery m a -> Op m a RunQuerySingleMaybe :: DynamicQuery m a -> Op m (Maybe a) - ReadQuery :: DynamicQuery m a -> Op m (Vector a) - ReadQueryFiltered :: DynamicQuery m a -> (Node m -> Bool) -> Op m (Vector a) + ReadQuery :: DynamicQuery m a -> Op m [a] + ReadQueryFiltered :: DynamicQuery m a -> (Node m -> Bool) -> Op m [a] ReadQuerySingle :: DynamicQuery m a -> Op m a ReadQuerySingleMaybe :: DynamicQuery m a -> Op m (Maybe a) @@ -113,11 +112,11 @@ runDynamicSystem (Ap sf sa) es = do runDynamicSystem (Op cIds op) es = runOp cIds op es {-# INLINE runDynamicSystem #-} -runQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Vector a) +runQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m [a] runQuery cIds q = Op cIds (RunQuery q) {-# INLINE runQuery #-} -runQueryFiltered :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> DynamicSystem m (Vector a) +runQueryFiltered :: Set ComponentID -> DynamicQuery m a -> (Node m -> Bool) -> DynamicSystem m [a] runQueryFiltered cIds q flt = Op cIds (RunFiltered flt q) {-# INLINE runQueryFiltered #-} @@ -129,11 +128,11 @@ runQuerySingleMaybe :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (M runQuerySingleMaybe cIds q = Op cIds (RunQuerySingleMaybe q) {-# INLINE runQuerySingleMaybe #-} -readQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m (Vector a) +readQuery :: Set ComponentID -> DynamicQuery m a -> DynamicSystem m [a] readQuery cIds q = Op cIds (ReadQuery q) {-# INLINE readQuery #-} -readQueryFiltered :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> DynamicSystem m (Vector a) +readQueryFiltered :: Set ComponentID -> (Node m -> Bool) -> DynamicQuery m a -> DynamicSystem m [a] readQueryFiltered cIds flt q = Op cIds (ReadQueryFiltered q flt) {-# INLINE readQueryFiltered #-} diff --git a/src/Aztecs/ECS/View.hs b/src/Aztecs/ECS/View.hs index 4ec2083c..596acd25 100644 --- a/src/Aztecs/ECS/View.hs +++ b/src/Aztecs/ECS/View.hs @@ -37,8 +37,6 @@ 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. @@ -82,32 +80,32 @@ unview v es = } -- | Query all matching entities in a `View`. -allDyn :: DynamicQuery Identity a -> View Identity -> Vector a +allDyn :: DynamicQuery Identity a -> View Identity -> [a] allDyn q v = foldl' ( \acc n -> let (as, _, _) = runIdentity . runDynQuery q $ nodeArchetype n - in as V.++ acc + in as ++ acc ) - V.empty + [] (viewArchetypes v) -- | Query all matching entities in a `View`. singleDyn :: DynamicQuery Identity a -> View Identity -> Maybe a singleDyn q v = case allDyn q v of - as | V.length as == 1 -> Just (V.head as) + [x] -> Just x _ -> 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 :: (Monad m) => DynamicQuery m a -> View m -> m ([a], View m, Access m ()) mapDyn q v = do (as, arches, hooks) <- foldlM ( \(acc, archAcc, hooksAcc) (aId, n) -> do (as', arch', hook) <- runDynQuery q $ nodeArchetype n - return (as' V.++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc, hooksAcc >> hook) + return (as' ++ acc, Map.insert aId (n {nodeArchetype = arch'}) archAcc, hooksAcc >> hook) ) - (V.empty, Map.empty, return ()) + ([], Map.empty, return ()) (Map.toList $ viewArchetypes v) return (as, View arches, hooks) @@ -116,5 +114,5 @@ mapSingleDyn :: (Monad m) => DynamicQuery m a -> View m -> m (Maybe a, View m, A mapSingleDyn q v = do (as, arches, hooks) <- mapDyn q v return $ case as of - a | V.length a == 1 -> (Just (V.head a), arches, hooks) + [x] -> (Just x, arches, hooks) _ -> (Nothing, arches, hooks) diff --git a/src/Aztecs/ECS/World/Archetype.hs b/src/Aztecs/ECS/World/Archetype.hs index 2a7acfd3..479cd785 100644 --- a/src/Aztecs/ECS/World/Archetype.hs +++ b/src/Aztecs/ECS/World/Archetype.hs @@ -28,13 +28,17 @@ module Aztecs.ECS.World.Archetype lookupComponentsAsc, lookupComponentsAscMaybe, lookupStorage, + alterStorage, + alterStorageF, + alterComponentsAsc, + zipAlterComponentsAsc, member, remove, removeStorages, insertComponent, insertComponentUntracked, insertComponents, - insertAscVector, + insertAscList, zipWith, zipWith_, zipWithM, @@ -51,6 +55,7 @@ import Aztecs.ECS.World.Archetype.Internal import qualified Aztecs.ECS.World.Storage as S import Aztecs.ECS.World.Storage.Dynamic import qualified Aztecs.ECS.World.Storage.Dynamic as S +import Control.Monad.Identity import Control.Monad.Writer import Data.Dynamic import Data.Foldable @@ -60,8 +65,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set -import Data.Vector (Vector) -import qualified Data.Vector as V import Prelude hiding (map, zipWith) -- | Archetype with a single entity. @@ -75,6 +78,27 @@ lookupStorage cId w = do fromDynamic $ storageDyn dynS {-# INLINE lookupStorage #-} +-- | Alter a component `Storage` by its `ComponentID`. +alterStorage :: forall m a. (Component m a) => (StorageT a -> (StorageT a)) -> ComponentID -> Archetype m -> (Archetype m) +alterStorage f cId w = runIdentity $ alterStorageF @_ @m @a (return . f) cId w +{-# INLINE alterStorage #-} + +-- | Alter a component `Storage` by its `ComponentID`. +alterStorageF :: forall f m a. (Monad f, Component m a) => (StorageT a -> f (StorageT a)) -> ComponentID -> Archetype m -> f (Archetype m) +alterStorageF f cId w = + (\s -> w {storages = s}) <$> IntMap.alterF go (unComponentId cId) (storages w) + where + go dyn = case dyn of + Just d -> case fromDynamic $ storageDyn d of + Just s -> do + s' <- f s + return $ Just $ d {storageDyn = toDyn s'} + Nothing -> return dyn + Nothing -> do + s' <- f (S.fromAsc @a @(StorageT a) []) + return $ Just $ dynStorage @a s' +{-# INLINE alterStorageF #-} + -- | Lookup a component by its `EntityID` and `ComponentID`. lookupComponent :: forall m a. (Component m a) => EntityID -> ComponentID -> Archetype m -> Maybe a lookupComponent e cId w = lookupComponents cId w Map.!? e @@ -83,20 +107,51 @@ lookupComponent e cId w = lookupComponents cId w Map.!? e -- | Lookup all components by their `ComponentID`. lookupComponents :: forall m a. (Component m a) => ComponentID -> Archetype m -> Map EntityID a lookupComponents cId arch = case lookupComponentsAscMaybe cId arch of - Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) (V.toList as) + Just as -> Map.fromAscList $ zip (Set.toList $ entities arch) as Nothing -> Map.empty {-# INLINE lookupComponents #-} -- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. -lookupComponentsAsc :: forall m a. (Component m a) => ComponentID -> Archetype m -> Vector a -lookupComponentsAsc cId = fromMaybe V.empty . lookupComponentsAscMaybe @m @a cId +lookupComponentsAsc :: forall m a. (Component m a) => ComponentID -> Archetype m -> [a] +lookupComponentsAsc cId = fromMaybe [] . lookupComponentsAscMaybe @m @a cId {-# INLINE lookupComponentsAsc #-} -- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`. -lookupComponentsAscMaybe :: forall m a. (Component m a) => ComponentID -> Archetype m -> Maybe (Vector a) -lookupComponentsAscMaybe cId arch = S.toAscVector @a @(StorageT a) <$> lookupStorage @m @a cId arch +lookupComponentsAscMaybe :: forall m a. (Component m a) => ComponentID -> Archetype m -> Maybe [a] +lookupComponentsAscMaybe cId arch = S.toAsc @a @(StorageT a) <$> lookupStorage @m @a cId arch {-# INLINE lookupComponentsAscMaybe #-} +alterComponentsAsc :: + forall m a. + (Component m a) => + ([a] -> [a]) -> + ComponentID -> + Archetype m -> + (Archetype m, [a]) +alterComponentsAsc f cId arch = runWriter $ alterStorageF @_ @m @a go cId arch + where + go s = do + let as' = f $ S.toAsc @a @(StorageT a) s + tell as' + return $ S.fromAsc @a @(StorageT a) as' +{-# INLINE alterComponentsAsc #-} + +zipAlterComponentsAsc :: + forall m a b. + (Component m a) => + ([a] -> [(a, b)]) -> + ComponentID -> + Archetype m -> + (Archetype m, [b]) +zipAlterComponentsAsc f cId arch = runWriter $ alterStorageF @_ @m @a go cId arch + where + go s = do + let xs = f $ S.toAsc @a @(StorageT a) s + (as', bs) = unzip xs + tell bs + return $ S.fromAsc @a @(StorageT a) as' +{-# INLINE zipAlterComponentsAsc #-} + -- | Insert a component into the archetype. insertComponent :: forall m a. (Component m a) => EntityID -> ComponentID -> a -> Archetype m -> (Archetype m, Access m ()) @@ -104,7 +159,7 @@ insertComponent e cId c arch = let oldComponents = lookupComponents @m @a cId arch oldValue = oldComponents Map.!? e !storage = - S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ oldComponents + S.fromAsc @a @(StorageT a) . Map.elems . Map.insert e c $ oldComponents hook = case oldValue of Just old -> do componentOnChange e old c @@ -119,17 +174,23 @@ insertComponentUntracked :: forall m a. (Component m a) => EntityID -> ComponentID -> a -> Archetype m -> Archetype m insertComponentUntracked e cId c arch = let !storage = - S.fromAscVector @a @(StorageT a) . V.fromList . Map.elems . Map.insert e c $ lookupComponents cId arch + S.fromAsc @a @(StorageT a) . Map.elems . Map.insert e c $ lookupComponents cId arch in arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)} -- | @True@ if this archetype contains an entity with the provided `ComponentID`. member :: ComponentID -> Archetype m -> Bool member cId = IntMap.member (unComponentId cId) . storages --- | Zip a vector of components with a function and a component storage. --- Returns the result vector, updated archetype, and the onChange hooks to run. +-- | Zip a list of components with a function and a component storage. +-- Returns the result list, updated archetype, and the onChange hooks to run. zipWith :: - forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype m -> (Vector c, Archetype m, Access m ()) + forall m a c. + (Monad m, Component m c) => + [a] -> + (a -> c -> c) -> + ComponentID -> + Archetype m -> + ([c], Archetype m, Access m ()) zipWith as f cId arch = let oldCs = lookupComponentsAsc @m @c cId arch go maybeDyn = case maybeDyn of @@ -141,15 +202,15 @@ zipWith as f cId arch = Nothing -> return maybeDyn Nothing -> return Nothing (storages', cs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch - eIds = V.fromList . Set.toList $ entities arch - hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs) + eIds = Set.toList $ entities arch + hooks = foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (zip3 eIds oldCs cs) in (cs, arch {storages = storages'}, hooks) {-# INLINE zipWith #-} --- | Zip a vector of components with a monadic function and a component storage. --- Returns the result vector, updated archetype, and the onChange hooks to run. +-- | Zip a list of components with a monadic function and a component storage. +-- Returns the result list, updated archetype, and the onChange hooks to run. zipWithM :: - forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> m c) -> ComponentID -> Archetype m -> m (Vector c, Archetype m, Access m ()) + forall m a c. (Monad m, Component m c) => [a] -> (a -> c -> m c) -> ComponentID -> Archetype m -> m ([c], Archetype m, Access m ()) zipWithM as f cId arch = do let oldCs = lookupComponentsAsc @m @c cId arch go maybeDyn = case maybeDyn of @@ -163,14 +224,14 @@ zipWithM as f cId arch = do Nothing -> pure Nothing res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch let cs = snd res - eIds = V.fromList . Set.toList $ entities arch - hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs) + eIds = Set.toList $ entities arch + hooks = foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (zip3 eIds oldCs cs) return (cs, arch {storages = fst res}, hooks) --- | Zip a vector of components with a function and a component storage. +-- | Zip a list of components with a function and a component storage. -- Returns the updated archetype and the onChange hooks to run. zipWith_ :: - forall m a c. (Monad m, Component m c) => Vector a -> (a -> c -> c) -> ComponentID -> Archetype m -> (Archetype m, Access m ()) + forall m a c. (Monad m, Component m c) => [a] -> (a -> c -> c) -> ComponentID -> Archetype m -> (Archetype m, Access m ()) zipWith_ as f cId arch = let oldCs = lookupComponentsAsc @m @c cId arch maybeStorage = case IntMap.lookup (unComponentId cId) $ storages arch of @@ -181,15 +242,15 @@ zipWith_ as f cId arch = Nothing -> Nothing in case maybeStorage of Just (cs, s) -> - let eIds = V.fromList . Set.toList $ entities arch - hooks = V.foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs cs) + let eIds = Set.toList $ entities arch + hooks = foldl (\acc (e, old, new) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (zip3 eIds oldCs cs) in (empty {storages = IntMap.singleton (unComponentId cId) s}, hooks) Nothing -> (empty {storages = IntMap.empty}, return ()) {-# INLINE zipWith_ #-} --- | Zip a vector of components with a function returning a tuple. +-- | Zip a list of components with a function returning a tuple. zipWithAccum :: - forall m a c o. (Monad m, Component m c) => Vector a -> (a -> c -> (o, c)) -> ComponentID -> Archetype m -> (Vector (o, c), Archetype m, Access m ()) + forall m a c o. (Monad m, Component m c) => [a] -> (a -> c -> (o, c)) -> ComponentID -> Archetype m -> ([(o, c)], Archetype m, Access m ()) zipWithAccum as f cId arch = let oldCs = lookupComponentsAsc @m @c cId arch go maybeDyn = case maybeDyn of @@ -201,14 +262,14 @@ zipWithAccum as f cId arch = Nothing -> return maybeDyn Nothing -> return Nothing (storages', pairs) = runWriter $ IntMap.alterF go (unComponentId cId) $ storages arch - eIds = V.fromList . Set.toList $ entities arch - hooks = V.foldl (\acc (e, old, (_, new)) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs pairs) + eIds = Set.toList $ entities arch + hooks = foldl (\acc (e, old, (_, new)) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (zip3 eIds oldCs pairs) in (pairs, arch {storages = storages'}, hooks) {-# INLINE zipWithAccum #-} --- | Zip a vector of components with a monadic function returning a tuple. +-- | Zip a list of components with a monadic function returning a tuple. zipWithAccumM :: - forall m a c o. (Monad m, Component m c) => Vector a -> (a -> c -> m (o, c)) -> ComponentID -> Archetype m -> m (Vector (o, c), Archetype m, Access m ()) + forall m a c o. (Monad m, Component m c) => [a] -> (a -> c -> m (o, c)) -> ComponentID -> Archetype m -> m ([(o, c)], Archetype m, Access m ()) zipWithAccumM as f cId arch = do let oldCs = lookupComponentsAsc @m @c cId arch go maybeDyn = case maybeDyn of @@ -222,25 +283,25 @@ zipWithAccumM as f cId arch = do Nothing -> pure Nothing res <- runWriterT $ IntMap.alterF go (unComponentId cId) $ storages arch let pairs = snd res - eIds = V.fromList . Set.toList $ entities arch - hooks = V.foldl (\acc (e, old, (_, new)) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (V.zip3 eIds oldCs pairs) + eIds = Set.toList $ entities arch + hooks = foldl (\acc (e, old, (_, new)) -> acc >> componentOnChange e old new >> triggerEntityEvent e (OnChange old new)) (return ()) (zip3 eIds oldCs pairs) return (pairs, arch {storages = fst res}, hooks) {-# INLINE zipWithAccumM #-} --- | Insert a vector of components into the archetype, sorted in ascending order by their `EntityID`. -insertAscVector :: forall m a. (Component m a) => ComponentID -> Vector a -> Archetype m -> Archetype m -insertAscVector cId as arch = - let !storage = dynStorage @a $ S.fromAscVector @a @(StorageT a) as +-- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`. +insertAscList :: forall m a. (Component m a) => ComponentID -> [a] -> Archetype m -> Archetype m +insertAscList cId as arch = + let !storage = dynStorage @a $ S.fromAsc @a @(StorageT a) as in arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch} -{-# INLINE insertAscVector #-} +{-# INLINE insertAscList #-} -- | Remove an entity from an archetype, returning its components. remove :: EntityID -> Archetype m -> (IntMap Dynamic, Archetype m) remove e arch = let go (dynAcc, archAcc) (cId, dynS) = - let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS + let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs - dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS + dynS' = S.fromAscListDyn (Map.elems cs') dynS !dynAcc' = case dynA of Just d -> IntMap.insert cId d dynAcc Nothing -> dynAcc @@ -252,9 +313,9 @@ remove e arch = removeStorages :: EntityID -> Archetype m -> (IntMap DynamicStorage, Archetype m) removeStorages e arch = let go (dynAcc, archAcc) (cId, dynS) = - let cs = Map.fromAscList . zip (Set.toList $ entities arch) . V.toList $ toAscVectorDyn dynS + let cs = Map.fromAscList . zip (Set.toList $ entities arch) $ toAscListDyn dynS !(dynA, cs') = Map.updateLookupWithKey (\_ _ -> Nothing) e cs - dynS' = S.fromAscVectorDyn (V.fromList $ Map.elems cs') dynS + dynS' = S.fromAscListDyn (Map.elems cs') dynS !dynAcc' = case dynA of Just d -> IntMap.insert cId (S.singletonDyn d dynS') dynAcc Nothing -> dynAcc @@ -269,7 +330,7 @@ insertComponents e cs arch = let storages' = IntMap.adjust go itemCId (storages archAcc) es = Set.toList $ entities archAcc go s = - let ecs = V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip es . V.toList $ toAscVectorDyn s - in fromAscVectorDyn ecs s + let ecs = Map.elems . Map.insert e dyn . Map.fromAscList . zip es $ toAscListDyn s + in fromAscListDyn ecs s in archAcc {storages = storages', entities = Set.insert e $ entities archAcc} in foldl' f arch (IntMap.toList cs) diff --git a/src/Aztecs/ECS/World/Archetypes.hs b/src/Aztecs/ECS/World/Archetypes.hs index 4d958669..ba9c6042 100644 --- a/src/Aztecs/ECS/World/Archetypes.hs +++ b/src/Aztecs/ECS/World/Archetypes.hs @@ -44,7 +44,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set -import qualified Data.Vector as V import Prelude hiding (all, lookup, map) -- | Empty `Archetypes`. @@ -174,7 +173,7 @@ remove e aId cId arches = case lookup aId arches of !arches' = arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)} (a, cs') = IntMap.updateLookupWithKey (\_ _ -> Nothing) (unComponentId cId) cs go' archAcc (itemCId, dyn) = - let adjustStorage s = fromAscVectorDyn (V.fromList . Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) . V.toList $ toAscVectorDyn s) s + let adjustStorage s = fromAscListDyn (Map.elems . Map.insert e dyn . Map.fromAscList . zip (Set.toList $ entities archAcc) $ toAscListDyn s) s in archAcc {storages = IntMap.adjust adjustStorage itemCId (storages archAcc)} go nextNode = nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (IntMap.toList cs')} @@ -195,7 +194,7 @@ remove e aId cId arches = case lookup aId arches of } !(nextAId, arches') = insertArchetype destCIds n arches node' = node {nodeArchetype = arch'} - maybeA = a >>= (\dynS -> V.headM (toAscVectorDyn dynS) >>= fromDynamic) + maybeA = a >>= (\dynS -> listToMaybe (toAscListDyn dynS) >>= fromDynamic) hook = maybe (return ()) (\comp -> componentOnRemove e comp >> triggerEntityEvent e (OnRemove comp)) maybeA in ( (,nextAId) <$> maybeA, arches' {nodes = Map.insert aId node' (nodes arches')}, diff --git a/src/Aztecs/ECS/World/Storage.hs b/src/Aztecs/ECS/World/Storage.hs index e22349cd..ff026a25 100644 --- a/src/Aztecs/ECS/World/Storage.hs +++ b/src/Aztecs/ECS/World/Storage.hs @@ -11,9 +11,9 @@ -- Portability : non-portable (GHC extensions) module Aztecs.ECS.World.Storage (Storage (..)) where +import Control.Monad (zipWithM) import Data.Data -import Data.Vector (Vector) -import qualified Data.Vector as V +import qualified Data.List as L import Prelude hiding (map, zipWith) -- | Component storage, containing zero or many components of the same type. @@ -21,61 +21,61 @@ class (Typeable s, Typeable a) => Storage a s where -- | Storage with a single component. singleton :: a -> s - -- | Vector of all components in the storage in ascending order. - toAscVector :: s -> Vector a + -- | List of all components in the storage in ascending order. + toAsc :: s -> [a] - -- | Convert a sorted vector of components (in ascending order) into a storage. - fromAscVector :: Vector a -> s + -- | Convert a sorted list of components (in ascending order) into a storage. + fromAsc :: [a] -> s -- | Map a function over all components in the storage. map :: (a -> a) -> s -> s -- | Map a function with some input over all components in the storage. - zipWith :: (i -> a -> a) -> Vector i -> s -> (Vector a, s) + zipWith :: (i -> a -> a) -> [i] -> s -> ([a], s) -- | Map an applicative functor with some input over all components in the storage. - zipWithM :: (Monad m) => (i -> a -> m a) -> Vector i -> s -> m (Vector a, s) + zipWithM :: (Monad m) => (i -> a -> m a) -> [i] -> s -> m ([a], s) -- | Map a function with some input over all components in the storage. - zipWith_ :: (i -> a -> a) -> Vector i -> s -> s + zipWith_ :: (i -> a -> a) -> [i] -> s -> s zipWith_ f is as = snd $ zipWith f is as -- | Map a function with some input over all components, returning a tuple result and updated storage. - zipWithAccum :: (i -> a -> (o, a)) -> Vector i -> s -> (Vector (o, a), s) + zipWithAccum :: (i -> a -> (o, a)) -> [i] -> s -> ([(o, a)], s) -- | Map a monadic function with some input over all components, returning a tuple result and updated storage. - zipWithAccumM :: (Monad m) => (i -> a -> m (o, a)) -> Vector i -> s -> m (Vector (o, a), s) + zipWithAccumM :: (Monad m) => (i -> a -> m (o, a)) -> [i] -> s -> m ([(o, a)], s) -instance (Typeable a) => Storage a (Vector a) where - singleton a = V.singleton a +instance (Typeable a) => Storage a [a] where + singleton a = [a] {-# INLINE singleton #-} - toAscVector = id - {-# INLINE toAscVector #-} + toAsc = id + {-# INLINE toAsc #-} - fromAscVector = id - {-# INLINE fromAscVector #-} + fromAsc = id + {-# INLINE fromAsc #-} - map = V.map + map = fmap {-# INLINE map #-} - zipWith f is as = let as' = V.zipWith f is as in (as', as') + zipWith f is as = let as' = L.zipWith f is as in (as', as') {-# INLINE zipWith #-} - zipWith_ f is as = V.zipWith f is as + zipWith_ f is as = L.zipWith f is as {-# INLINE zipWith_ #-} - zipWithM f is as = (\as' -> (as', as')) <$> V.zipWithM f is as + zipWithM f is as = (\as' -> (as', as')) <$> Control.Monad.zipWithM f is as {-# INLINE zipWithM #-} zipWithAccum f is as = - let pairs = V.zipWith f is as - as' = V.map snd pairs + let pairs = L.zipWith f is as + as' = fmap snd pairs in (pairs, as') {-# INLINE zipWithAccum #-} zipWithAccumM f is as = do - pairs <- V.zipWithM f is as - let as' = V.map snd pairs + pairs <- Control.Monad.zipWithM f is as + let as' = fmap snd pairs return (pairs, as') {-# INLINE zipWithAccumM #-} diff --git a/src/Aztecs/ECS/World/Storage/Dynamic.hs b/src/Aztecs/ECS/World/Storage/Dynamic.hs index 7b730f21..d78c2601 100644 --- a/src/Aztecs/ECS/World/Storage/Dynamic.hs +++ b/src/Aztecs/ECS/World/Storage/Dynamic.hs @@ -20,16 +20,14 @@ module Aztecs.ECS.World.Storage.Dynamic ( DynamicStorage (..), dynStorage, singletonDyn, - fromAscVectorDyn, - toAscVectorDyn, + fromAscListDyn, + toAscListDyn, ) where import qualified Aztecs.ECS.World.Storage as S import Data.Dynamic import Data.Maybe -import Data.Vector (Vector) -import qualified Data.Vector as V -- | Dynamic storage of components. data DynamicStorage = DynamicStorage @@ -37,10 +35,10 @@ data DynamicStorage = DynamicStorage storageDyn :: !Dynamic, -- | Singleton storage. singletonDyn' :: !(Dynamic -> Dynamic), - -- | Convert this storage to an ascending vector. - toAscVectorDyn' :: !(Dynamic -> Vector Dynamic), - -- | Convert from an ascending vector. - fromAscVectorDyn' :: !(Vector Dynamic -> Dynamic) + -- | Convert this storage to an ascending list. + toAscListDyn' :: !(Dynamic -> [Dynamic]), + -- | Convert from an ascending list. + fromAscListDyn' :: !([Dynamic] -> Dynamic) } instance Show DynamicStorage where @@ -52,8 +50,8 @@ dynStorage s = DynamicStorage { storageDyn = toDyn s, singletonDyn' = toDyn . S.singleton @a @s . fromMaybe (error "TODO") . fromDynamic, - toAscVectorDyn' = \d -> V.map toDyn (S.toAscVector @a @s (fromMaybe (error "TODO") $ fromDynamic d)), - fromAscVectorDyn' = toDyn . S.fromAscVector @a @s . V.map (fromMaybe (error "TODO") . fromDynamic) + toAscListDyn' = \d -> fmap toDyn (S.toAsc @a @s (fromMaybe (error "TODO") $ fromDynamic d)), + fromAscListDyn' = toDyn . S.fromAsc @a @s . fmap (fromMaybe (error "TODO") . fromDynamic) } {-# INLINE dynStorage #-} @@ -61,10 +59,10 @@ dynStorage s = singletonDyn :: Dynamic -> DynamicStorage -> DynamicStorage singletonDyn dyn s = s {storageDyn = singletonDyn' s dyn} --- | Convert from an ascending vector. -fromAscVectorDyn :: Vector Dynamic -> DynamicStorage -> DynamicStorage -fromAscVectorDyn dyns s = s {storageDyn = fromAscVectorDyn' s dyns} +-- | Convert from an ascending list. +fromAscListDyn :: [Dynamic] -> DynamicStorage -> DynamicStorage +fromAscListDyn dyns s = s {storageDyn = fromAscListDyn' s dyns} --- | Convert this storage to an ascending vector. -toAscVectorDyn :: DynamicStorage -> Vector Dynamic -toAscVectorDyn = toAscVectorDyn' <*> storageDyn +-- | Convert this storage to an ascending list. +toAscListDyn :: DynamicStorage -> [Dynamic] +toAscListDyn = toAscListDyn' <*> storageDyn diff --git a/src/Aztecs/Hierarchy.hs b/src/Aztecs/Hierarchy.hs index 99175489..61a83349 100644 --- a/src/Aztecs/Hierarchy.hs +++ b/src/Aztecs/Hierarchy.hs @@ -38,13 +38,12 @@ import Aztecs.ECS import qualified Aztecs.ECS.Access as A import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S +import Control.Applicative import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set -import Data.Vector (Vector) -import qualified Data.Vector as V import GHC.Generics -- | Parent component. @@ -119,9 +118,9 @@ instance Traversable Hierarchy where traverse f n = Node (nodeEntityId n) <$> f (nodeEntity n) <*> traverse (traverse f) (nodeChildren n) --- | Convert a hierarchy to a vector of entity IDs and components. -toList :: Hierarchy a -> Vector (EntityID, a) -toList n = V.singleton (nodeEntityId n, nodeEntity n) <> V.concatMap toList (V.fromList $ nodeChildren n) +-- | Convert a hierarchy to a list of entity IDs and components. +toList :: Hierarchy a -> [(EntityID, a)] +toList n = (nodeEntityId n, nodeEntity n) : concatMap toList (nodeChildren n) -- | Fold a hierarchy with a function that takes the entity ID, entity, and accumulator. foldWithKey :: (EntityID -> a -> b -> b) -> Hierarchy a -> b -> b @@ -139,36 +138,39 @@ mapWithAccum f b n = case f (nodeEntityId n) (nodeEntity n) b of -- | System to read a hierarchy of parents to children with the given query. hierarchy :: + forall m a. (Monad m) => EntityID -> - Query m a -> + (forall f. (Applicative f) => Query f m (f a)) -> Access m (Maybe (Hierarchy a)) hierarchy e q = do - children <- A.system . S.readQuery $ do - e' <- Q.entity - cs <- Q.query - a <- q - return (e', (unChildren cs, a)) - let childMap = Map.fromList $ V.toList children + let mkQuery :: forall f. (Applicative f) => Query f m (f (EntityID, (Set EntityID, a))) + mkQuery = do + e' <- Q.entity + cs <- Q.query @_ @_ @Children + a' <- q + return $ liftA3 (\eid c a'' -> (eid, (unChildren c, a''))) e' cs a' + children <- A.system $ S.readQuery mkQuery + let childMap = Map.fromList children return $ hierarchy' e childMap -- | Build all hierarchies of parents to children, joined with the given query. hierarchies :: forall m a. (Monad m) => - Query m a -> - Access m (Vector (Hierarchy a)) + (forall f. (Applicative f) => Query f m (f a)) -> + Access m [Hierarchy a] hierarchies q = do - children <- - A.system . S.readQuery $ do - e <- Q.entity - cs <- Q.query - a <- q - return (e, (unChildren cs, a)) - - let childMap = Map.fromList $ V.toList children - roots <- A.system $ S.readQueryFiltered Q.entity (with @m @Children <> without @m @Parent) - return $ V.mapMaybe (`hierarchy'` childMap) roots + let mkQuery :: forall f. (Applicative f) => Query f m (f (EntityID, (Set EntityID, a))) + mkQuery = do + e' <- Q.entity + cs <- Q.query @_ @_ @Children + a' <- q + return $ liftA3 (\eid c a -> (eid, (unChildren c, a))) e' cs a' + children <- A.system $ S.readQuery mkQuery + let childMap = Map.fromList children + roots <- A.system $ S.readQueryFiltered (Q.entity) (with @m @Children <> without @m @Parent) + return $ mapMaybe (`hierarchy'` childMap) roots -- | Build a hierarchy of parents to children. hierarchy' :: EntityID -> Map EntityID (Set EntityID, a) -> Maybe (Hierarchy a) diff --git a/test/Main.hs b/test/Main.hs index ebcafdcb..ccd27b1b 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -12,11 +12,11 @@ module Main (main) where import Aztecs -import Aztecs.ECS.Component (ComponentID (ComponentID)) +import Aztecs.ECS.Component import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.World as W -import Data.Functor.Identity (Identity (runIdentity)) -import qualified Data.Vector as V +import Control.Applicative +import Data.Functor.Identity import Data.Word import GHC.Generics import Test.Hspec @@ -58,24 +58,29 @@ describe "Aztecs.ECS.Hierarchy.update" $ do prop_queryEmpty :: Expectation prop_queryEmpty = let res = - fst - . runIdentity - . Q.readQuery (Q.query @_ @X) + runIdentity + . Q.readQuery (Q.query @_ @_ @X) $ W.entities W.empty - in V.toList res `shouldMatchList` [] + in res `shouldMatchList` [] -- | Query all components from a list of `ComponentID`s. queryComponentIds :: - forall m q a. - (Applicative q, DynamicQueryF m q, Component m a) => + forall a m. + (Component m a) => [ComponentID] -> - q (EntityID, [a]) -queryComponentIds = + (forall f. (Applicative f) => Q.Query f m (f (EntityID, [a]))) +queryComponentIds cIds = let go cId qAcc = do x' <- Q.queryDyn @_ @_ @a cId - (e, xs) <- qAcc - return (e, x' : xs) - in foldr go ((,) <$> Q.entity <*> pure []) + acc <- qAcc + return $ liftA2 (\x (e, xs) -> (e, x : xs)) x' acc + in foldr + go + ( do + e <- Q.entity + return $ fmap (\eid -> (eid, [])) e + ) + cIds prop_queryDyn :: [[X]] -> Expectation prop_queryDyn xs = @@ -91,46 +96,56 @@ prop_queryDyn xs = in ((e, cs) : acc, wAcc') (es, w) = foldr spawner ([], W.empty) xs go (e, cs) = do - let q = queryComponentIds @Identity $ map snd cs - (res, _) = runIdentity . Q.readQuery q $ W.entities w - return $ V.toList res `shouldContain` [(e, map fst cs)] + let res = runIdentity . Q.readQuery (queryComponentIds @X @Identity $ map snd cs) $ W.entities w + return $ res `shouldContain` [(e, map fst cs)] in mapM_ go es prop_queryTypedComponent :: [X] -> Expectation prop_queryTypedComponent xs = do let w = foldr (\x -> (\(_, w', _) -> w') . W.spawn (bundle x)) W.empty xs - (res, _) = runIdentity . Q.readQuery Q.query $ W.entities w - V.toList res `shouldMatchList` xs + res = runIdentity . Q.readQuery (Q.query @_ @_ @X) $ W.entities w + res `shouldMatchList` xs prop_queryTwoTypedComponents :: [(X, Y)] -> Expectation prop_queryTwoTypedComponents xys = do let w = foldr (\(x, y) -> (\(_, w', _) -> w') . W.spawn (bundle x <> bundle y)) W.empty xys - (res, _) = runIdentity $ Q.readQuery ((,) <$> Q.query <*> Q.query) $ W.entities w - V.toList res `shouldMatchList` xys + res = + runIdentity + $ Q.readQuery + ( do + x <- Q.query @_ @_ @X + y <- Q.query @_ @_ @Y + return $ liftA2 (,) x y + ) + $ W.entities w + res `shouldMatchList` xys prop_queryThreeTypedComponents :: [(X, Y, Z)] -> Expectation prop_queryThreeTypedComponents xyzs = do let w = foldr (\(x, y, z) -> (\(_, w', _) -> w') . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs - q = do - x <- Q.query - y <- Q.query - z <- Q.query - pure (x, y, z) - (res, _) = runIdentity $ Q.readQuery q $ W.entities w - V.toList res `shouldMatchList` xyzs + res = + runIdentity + $ Q.readQuery + ( do + x <- Q.query @_ @_ @X + y <- Q.query @_ @_ @Y + z <- Q.query @_ @_ @Z + return $ liftA3 (,,) x y z + ) + $ W.entities w + res `shouldMatchList` xyzs prop_querySingle :: Expectation prop_querySingle = let (_, w, _) = W.spawn (bundle $ X 1) W.empty - (res, _) = runIdentity $ Q.readQuerySingle Q.query $ W.entities w + res = runIdentity $ Q.readQuerySingle (Q.query @_ @_ @X) $ W.entities w in res `shouldBe` X 1 prop_queryMapSingle :: Word8 -> Expectation prop_queryMapSingle n = let (_, w, _) = W.spawn (bundle $ X 0) W.empty - q = Q.queryMap $ \(X x) -> X $ x + 1 - w' = foldr (\_ es -> (\(_, es', _) -> es') . runIdentity $ Q.runQuerySingle q es) (W.entities w) [1 .. n] - (res, _) = runIdentity $ Q.readQuerySingle Q.query w' + w' = foldr (\_ es -> (\(_, es', _) -> es') . runIdentity $ Q.runQuerySingle (Q.queryMap @_ @_ @X $ fmap (\(X x) -> X $ x + 1)) es) (W.entities w) [1 .. n] + res = runIdentity $ Q.readQuerySingle (Q.query @_ @_ @X) w' in res `shouldBe` X (fromIntegral n) {-TODO