diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ # apecs -##### [hackage](https://hackage.haskell.org/package/apecs) | [documentation](https://hackage.haskell.org/package/apecs-0.2.0.2/docs/Apecs.html) | [tutorials](https://github.com/jonascarpay/apecs/blob/master/tutorials/) +##### [hackage](https://hackage.haskell.org/package/apecs) | [documentation](https://hackage.haskell.org/package/apecs/docs/Apecs.html) | [tutorials](https://github.com/jonascarpay/apecs/blob/master/tutorials/) apecs is an Entity Component System inspired by [specs](https://github.com/slide-rs/specs) and [Entitas](https://github.com/sschmid/Entitas-CSharp). It exposes a DSL that translates to fast storage operations, resulting in expressivity without sacrificing performance or safety. @@ -19,64 +19,48 @@ ### Example ```haskell import Apecs +import Apecs.TH (makeWorld) import Apecs.Stores (Cache) import Linear --- Component data definitions -newtype Velocity = Velocity (V2 Double) deriving (Eq, Show) -newtype Position = Position (V2 Double) deriving (Eq, Show) -data Enemy = Enemy -- A single constructor for tagging entites as enemies +newtype Position = Position (V2 Double) deriving Show +-- Turn Position into a component by specifiying the type of its Storage +instance Component Position where + -- The simplest store is a Map + type Storage Position = Map Position --- Define Velocity as a component by giving it a storage type +newtype Velocity = Velocity (V2 Double) instance Component Velocity where - -- Store velocities in a cached map + -- We can add a Cache for faster access type Storage Velocity = Cache 100 (Map Velocity) -instance Component Position where - type Storage Position = Cache 100 (Map Position) - -instance Flag Enemy where flag = Enemy -instance Component Enemy where - -- Because enemy is just a flag, we can use a set - type Storage Enemy = Set Enemy - --- Define your world as containing the storages of your components -data World = World - { positions :: Storage Position - , velocities :: Storage Velocity - , enemies :: Storage Enemy - , entityCounter :: Storage EntityCounter } - --- Define Has instances for components to allow type-driven access to their storages -instance World `Has` Position where getStore = System $ asks positions -instance World `Has` Velocity where getStore = System $ asks velocities -instance World `Has` Enemy where getStore = System $ asks enemies -instance World `Has` EntityCounter where getStore = System $ asks entityCounter +data Player = Player -- A single constructor component for tagging the player +instance Component Player where + -- Unique contains at most one component. See the Stores module. + type Storage Player = Unique Player -type System' a = System World a +-- Generate a world type and instances +makeWorld "World" [''Position, ''Velocity, ''Player] -game :: System' () +game :: System World () game = do -- Create new entities ety <- newEntity (Position 0) -- Components can be composed using tuples newEntity (Position 0, Velocity 1) - -- Tagging one as an enemy is a matter of adding the constructor - newEntity (Position 1, Velocity 1, Enemy) + newEntity (Position 1, Velocity 1, Player) + -- set (over)writes components + set ety (Velocity 2) + -- Side effects liftIO$ putStrLn "Stepping velocities" -- rmap maps a pure function over all entities in its domain rmap $ \(Position p, Velocity v) -> Position (v+p) - -- Set can be used to (over)write components - set ety (Position 2, Enemy) - - -- Print the positions of all enemies - cmapM_ $ \(Enemy, Position p) -> liftIO (print p) + -- Print all positions + cmapM_ $ \(Position p) -> liftIO (print p) main :: IO () -main = do w <- World <$> initStore <*> initStore <*> initStore <*> initCounter - runSystem game w - +main = initWorld >>= runSystem game ``` diff --git a/apecs.cabal b/apecs.cabal --- a/apecs.cabal +++ b/apecs.cabal @@ -1,5 +1,5 @@ name: apecs -version: 0.2.2.0 +version: 0.2.3.0 homepage: https://github.com/jonascarpay/apecs#readme license: BSD3 license-file: LICENSE @@ -22,18 +22,21 @@ Apecs.Logs, Apecs.System, Apecs.Slice, + Apecs.TH, Apecs.Util + other-modules: + Apecs.THTuples default-language: Haskell2010 build-depends: base >= 4.7 && < 5, containers, mtl, + template-haskell, vector ghc-options: -Wall -Odph - -fno-warn-unused-top-binds test-suite apecs-test type: diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,61 +1,18 @@ {-# LANGUAGE Strict, ScopedTypeVariables, DataKinds, TypeFamilies, MultiParamTypeClasses, TypeOperators #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} import Criterion import qualified Criterion.Main as C import Control.Monad +import Linear -import Apecs as A +import Apecs +import Apecs.TH import Apecs.Stores import Apecs.Util import qualified Apecs.Slice as S -import Linear - -data Group w1 w2 = Group - { groupName :: String - , naiveWorld :: IO w1 - , naiveInit :: System w1 () - , naiveRun :: System w1 () - , improvedWorld :: IO w1 - , improvedInit :: System w1 () - , improvedRun :: System w1 () } - -toBench (Group name w1 i1 r1 w2 i2 r2) = - bgroup name - [ bgroup "naive" [bench "init" $ whnfIO (w1 >>= runSystem i1), bench "init and run" $ whnfIO (w2 >>= runSystem (i1 >> r1))] - , bgroup "improved" [bench "init" $ whnfIO (w1 >>= runSystem i1), bench "init and run" $ whnfIO (w2 >>= runSystem (i2 >> r2))] - ] - -data W1 c = W1 {w1c1 :: (Storage c), w1ec :: Storage EntityCounter} -instance Component c => Has (W1 c) c where getStore = System $ asks w1c1 -instance Has (W1 c) EntityCounter where getStore = System $ asks w1ec - -w1with args = W1 <$> initStoreWith args <*> initCounter -w1 = w1with () -w2with a1 a2 = W2 <$> initStoreWith a1 <*> initStoreWith a2 <*> initCounter -w2 = w2with () () - -data W2 a b = W2 { w2c1 :: Storage a , w2c2 :: Storage b, w2ec :: Storage EntityCounter} -instance (Component a, Component b) => Has (W2 a b) a where getStore = System $ asks w2c1 -instance (Component a, Component b) => Has (W2 a b) b where getStore = System $ asks w2c2 -instance Has (W2 a b) EntityCounter where getStore = System $ asks w2ec - ---Explicit vs implicit map -newtype Counter = Counter Int -instance Component Counter where type Storage Counter = Map Counter - -mapExample = Group - { groupName = "Single component map" - , naiveWorld = w1 :: IO (W1 Counter) - , naiveInit = replicateM_ 10 (newEntity (Counter 0)) - , naiveRun = owners >>= S.mapM_ (\(e :: Entity Counter) -> set e (Counter 1)) - , improvedWorld = w1 :: IO (W1 Counter) - , improvedInit = replicateM_ 10 (newEntity (Counter 0)) - , improvedRun = cmap (const (Counter 1)) - } - - -- ecs_bench newtype ECSPos = ECSPos (V2 Float) deriving (Eq, Show) instance Component ECSPos where type Storage ECSPos = Cache 10000 (Map ECSPos) @@ -63,19 +20,17 @@ newtype ECSVel = ECSVel (V2 Float) deriving (Eq, Show) instance Component ECSVel where type Storage ECSVel = Cache 1000 (Map ECSVel) +makeWorld "ECSB" [''ECSPos, ''ECSVel] + pvInit = do replicateM_ 1000 (newEntity (ECSPos 0, ECSVel 1)) replicateM_ 9000 (newEntity (ECSPos 0)) pvStep = rmap $ \(ECSVel v, ECSPos p) -> ECSPos (p+v) -pvWorld :: IO (W2 ECSPos ECSVel) -pvWorld = w2 - main :: IO () main = C.defaultMain [ bgroup "ecs_bench" - [ bench "init" $ whnfIO (pvWorld >>= runSystem pvInit) - , bench "step" $ whnfIO (pvWorld >>= runSystem (pvInit >> pvStep)) + [ bench "init" $ whnfIO (initECSB >>= runSystem pvInit) + , bench "step" $ whnfIO (initECSB >>= runSystem (pvInit >> pvStep)) ] - , toBench mapExample ] diff --git a/src/Apecs.hs b/src/Apecs.hs --- a/src/Apecs.hs +++ b/src/Apecs.hs @@ -9,13 +9,9 @@ Map, Set, Unique, Global, Flag(..), - -- * Initializable - initStoreWith, - - -- ** HasMembers wrapper functions + -- * Store wrapper functions + initStore, destroy, exists, owners, resetStore, - - -- ** Store wrapper functions get, set, set', modify, cmap, cmapM, cmapM_, cimapM, cimapM_, rmap', rmap, wmap, wmap', cmap', @@ -26,7 +22,7 @@ -- * Other runSystem, runWith, - initStore, runGC, EntityCounter, initCounter, newEntity, + runGC, EntityCounter, newEntity, -- Reader asks, ask, liftIO, lift, diff --git a/src/Apecs/Logs.hs b/src/Apecs/Logs.hs --- a/src/Apecs/Logs.hs +++ b/src/Apecs/Logs.hs @@ -66,9 +66,8 @@ data Logger l s = Logger (l (Stores s)) s instance (Log l (Stores s), Cachable s) => Store (Logger l s) where - type InitArgs (Logger l s) = InitArgs s type Stores (Logger l s) = Stores s - initStoreWith args = Logger <$> logEmpty <*> initStoreWith args + initStore = Logger <$> logEmpty <*> initStore {-# INLINE explDestroy #-} explDestroy (Logger l s) ety = do diff --git a/src/Apecs/Stores.hs b/src/Apecs/Stores.hs --- a/src/Apecs/Stores.hs +++ b/src/Apecs/Stores.hs @@ -30,13 +30,12 @@ defaultSetMaybe s e Nothing = explDestroy s e defaultSetMaybe s e (Just c) = explSet s e c --- | A map from Data.Intmap.Strict. O(n log(n)) for most operations. +-- | A map from Data.Intmap.Strict. O(log(n)) for most operations. -- Yields safe runtime representations of type @Maybe c@. newtype Map c = Map (IORef (M.IntMap c)) instance Store (Map c) where - type InitArgs (Map c) = () type Stores (Map c) = c - initStoreWith _ = Map <$> newIORef mempty + initStore = Map <$> newIORef mempty explDestroy (Map ref) ety = modifyIORef' ref (M.delete ety) explMembers (Map ref) = U.fromList . M.keys <$> readIORef ref explExists (Map ref) ety = M.member ety <$> readIORef ref @@ -75,9 +74,8 @@ -- Produces @flag@ runtime values. newtype Set c = Set (IORef S.IntSet) instance Flag c => Store (Set c) where - type InitArgs (Set c) = () type Stores (Set c) = c - initStoreWith _ = Set <$> newIORef mempty + initStore = Set <$> newIORef mempty explDestroy (Set ref) ety = modifyIORef' ref (S.delete ety) explMembers (Set ref) = U.fromList . S.toList <$> readIORef ref explReset (Set ref) = writeIORef ref mempty @@ -113,9 +111,8 @@ -- Writing to it overwrites both the previous component and its owner. data Unique c = Unique (IORef Int) (IORef c) instance Store (Unique c) where - type InitArgs (Unique c) = () type Stores (Unique c) = c - initStoreWith _ = Unique <$> newIORef (-1) <*> newIORef undefined + initStore = Unique <$> newIORef (-1) <*> newIORef undefined explDestroy (Unique eref _) ety = do e <- readIORef eref; when (e==ety) (writeIORef eref (-1)) explMembers (Unique eref _) = U.singleton <$> readIORef eref explReset (Unique eref _) = writeIORef eref (-1) @@ -171,11 +168,11 @@ -- | Constant value. Not very practical, but fun to write. +-- Contains `mempty` newtype Const c = Const c -instance Store (Const c) where - type InitArgs (Const c) = c +instance Monoid c => Store (Const c) where type Stores (Const c) = c - initStoreWith c = return$ Const c + initStore = return$ Const mempty explDestroy _ _ = return () explExists _ _ = return False explMembers _ = return mempty @@ -187,16 +184,15 @@ explSetMaybe _ _ _ = return () explModify _ _ _ = return () explCmap _ _ = return () -instance GlobalStore (Const c) where +instance Monoid c => GlobalStore (Const c) where -- | Global value. --- Must be given an initial value upon construction. +-- Initialized with 'mempty' newtype Global c = Global (IORef c) -instance GlobalStore (Global c) where -instance Store (Global c) where - type InitArgs (Global c) = c +instance Monoid c => GlobalStore (Global c) where +instance Monoid c => Store (Global c) where type Stores (Global c) = c - initStoreWith c = Global <$> newIORef c + initStore = Global <$> newIORef mempty type SafeRW (Global c) = c explDestroy _ _ = return () @@ -219,13 +215,12 @@ instance (KnownNat n, Cachable s) => Cachable (Cache n s) instance (KnownNat n, Cachable s) => Store (Cache n s) where - type InitArgs (Cache n s) = (InitArgs s) type Stores (Cache n s) = Stores s - initStoreWith args = do + initStore = do let n = fromIntegral$ natVal (Proxy @n) tags <- UM.replicate n (-1) cache <- VM.new n - child <- initStoreWith args + child <- initStore return (Cache n tags cache child) {-# INLINE explDestroy #-} diff --git a/src/Apecs/TH.hs b/src/Apecs/TH.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/TH.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Apecs.TH + ( makeWorld, makeWorldNoEC + )where + +import Language.Haskell.TH + +import Apecs.Util (EntityCounter) + +genName :: String -> Q Name +genName s = mkName . show <$> newName s + +-- | Same as 'makeWorld', but has no 'EntityCounter' +makeWorldNoEC :: String -> [Name] -> Q [Dec] +makeWorldNoEC worldName cTypes = do + cTypesNames <- mapM (\t -> do rec <- genName "rec"; return (ConT t, rec)) cTypes + + let wld = mkName worldName + has = mkName "Has" + sys = mkName "System" + wldDecl = DataD [] wld [] Nothing [RecC wld records] [] + + makeRecord (t,n) = (n, Bang NoSourceUnpackedness SourceStrict, ConT (mkName "Storage") `AppT` t) + records = makeRecord <$> cTypesNames + + makeInstance (t,n) = + InstanceD Nothing [] ((ConT has `AppT` ConT wld) `AppT` t) + [ FunD (mkName "getStore") [Clause [] + (NormalB$ ConE sys `AppE` (VarE (mkName "asks") `AppE` VarE n)) + [] ] + ] + + initDecl = FunD (mkName $ "init" ++ worldName) [Clause [] + (NormalB$ iterate (\wE -> AppE (AppE (VarE $ mkName "<*>") wE) (VarE $ mkName "initStore")) (AppE (VarE $ mkName "return") (ConE wld)) !! length records) + [] ] + + hasDecl = makeInstance <$> cTypesNames + + return $ wldDecl : initDecl : hasDecl + +{-| + +> makeWorld "WorldName" [''Component1, ''Component2, ...] + +turns into + +> data WorldName = WorldName ... +> instance WorldName `Has` Component1 where ... +> instance WorldName `Has` Component2 where ... +> ... +> +> instance WorldName `Has` EntityCounter where ... +> +> initWorldName :: IO WorldName +> initWorldName = WorldName <$> initStore <*> ... + +|-} +makeWorld :: String -> [Name] -> Q [Dec] +makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter]) + diff --git a/src/Apecs/THTuples.hs b/src/Apecs/THTuples.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/THTuples.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Apecs.THTuples where + +import Language.Haskell.TH +import qualified Data.Vector.Unboxed as U + +makeInstances is = concat <$> traverse tupleInstances is + +{-- +instance (Component a, Component b) => Component (a,b) where + type Storage (a,b) = (Storage a, Storage b) + +instance (Has w a, Has w b) => Has w (a,b) where + {-# INLINE getStore #-} + getStore = (,) <$> getStore <*> getStore + +instance (Store a, Store b) => Store (a,b) where + type Stores (a, b) = (Stores a, Stores b) + type SafeRW (a, b) = (SafeRW a, SafeRW b) + initStore = (,) <$> initStore <*> initStore + + explGet (sa,sb) ety = (,) <$> explGet sa ety <*> explGet sb ety + explSet (sa,sb) ety (wa,wb) = explSet sa ety wa >> explSet sb ety wb + explReset (sa,sb) = explReset sa >> explReset sb + explDestroy (sa,sb) ety = explDestroy sa ety >> explDestroy sb ety + explExists (sa,sb) ety = explExists sa ety >>= \case False -> return False + True -> explExists sb ety + explMembers (sa,sb) = explMembers sa >>= U.filterM (explExists sb) + explGetUnsafe (sa,sb) ety = (,) <$> explGetUnsafe sa ety <*> explGetUnsafe sb ety + explSetMaybe (sa,sb) ety (wa,wb) = explSetMaybe sa ety wa >> explSetMaybe sb ety wb + {-# INLINE explGetUnsafe #-} + {-# INLINE explGet #-} + {-# INLINE explSet #-} + {-# INLINE explSetMaybe #-} + {-# INLINE explMembers #-} + {-# INLINE explReset #-} + {-# INLINE explDestroy #-} + {-# INLINE explExists #-} +--} +tupleInstances :: Int -> Q [Dec] +tupleInstances n = do + let vars = [ VarT . mkName $ "t_" ++ show i | i <- [0..n-1]] + tupleUpT = foldl AppT (TupleT n) + varTuple = tupleUpT vars + tuplN = tupleDataName n + tuplE = ConE tuplN + pureTuplE = AppE (VarE (mkName "pure")) tuplE + + compN = mkName "Component" + compT var = ConT compN `AppT` var + strgN = mkName "Storage" + strgT var = ConT strgN `AppT` var + compI = InstanceD Nothing (fmap compT vars) (compT varTuple) + [ TySynInstD strgN $ + TySynEqn [varTuple] (tupleUpT . fmap strgT $ vars) + ] + + hasN = mkName "Has" + hasT var = ConT hasN `AppT` VarT (mkName "w") `AppT` var + getStoreN = mkName "getStore" + getStoreE = VarE getStoreN + apN = mkName "<*>" + apE = VarE apN + hasI = InstanceD Nothing (hasT <$> vars) (hasT varTuple) + [ FunD getStoreN + [Clause [] (NormalB$ liftAll tuplE (replicate n $ getStoreE )) [] ] + , PragmaD$ InlineP getStoreN Inline FunLike AllPhases + ] + + liftAll f mas = foldl (\a x -> AppE (AppE apE a) x) (AppE (VarE (mkName "pure")) f) mas + sequenceAll :: [Exp] -> Exp + sequenceAll = foldl1 (\a x -> AppE (AppE (VarE$ mkName ">>") a) x) + + strN = mkName "Store" + strsN = mkName "Stores" + safeN = mkName "SafeRW" + + strT var = ConT strN `AppT` var + strsT var = ConT strsN `AppT` var + safeT var = ConT safeN `AppT` var + + sNs = [ mkName $ "s_" ++ show i | i <- [0..n-1]] + sPat = ConP tuplN (VarP <$> sNs) + sEs = VarE <$> sNs + etyN = mkName "ety" + etyE = VarE etyN + etyPat = VarP etyN + wNs = [ mkName $ "w_" ++ show i | i <- [0..n-1]] + wPat = ConP tuplN (VarP <$> wNs) + wEs = VarE <$> wNs + + explGetN = mkName "explGet" + explSetN = mkName "explSet" + explResetN = mkName "explReset" + explDestroyN = mkName "explDestroy" + explExistsN = mkName "explExists" + explMembersN = mkName "explMembers" + explGetUnsafeN = mkName "explGetUnsafe" + explSetMaybeN = mkName "explSetMaybe" + initStoreN = mkName "initStore" + + explGetE = VarE explGetN + explSetE = VarE explSetN + explResetE = VarE explResetN + explDestroyE = VarE explDestroyN + explExistsE = VarE explExistsN + explMembersE = VarE explMembersN + explGetUnsafeE = VarE explGetUnsafeN + explSetMaybeE = VarE explSetMaybeN + + explGetF sE = AppE explGetE sE `AppE` etyE + explSetF sE wE = AppE explSetE sE `AppE` etyE `AppE` wE + explResetF sE = AppE explResetE sE + explDestroyF sE = AppE explDestroyE sE `AppE` etyE + explExistsF sE = AppE explExistsE sE + explMembersF sE = AppE explMembersE sE + explGetUnsafeF sE = AppE explGetUnsafeE sE `AppE` etyE + explSetMaybeF sE wE = AppE explSetMaybeE sE `AppE` etyE `AppE` wE + + explExistsAnd va vb = AppE (AppE (VarE '(>>=)) va) + (LamCaseE [ Match (ConP 'False []) (NormalB$ AppE (VarE 'return) (ConE 'False)) [] + , Match (ConP 'True []) (NormalB vb) [] + ]) + + explMembersFold va vb = AppE (VarE '(>>=)) va `AppE` AppE (VarE 'U.filterM) vb + + strI = InstanceD Nothing (strT <$> vars) (strT varTuple) + [ TySynInstD strsN $ TySynEqn [varTuple] (tupleUpT $ fmap strsT vars) + , TySynInstD safeN $ TySynEqn [varTuple] (tupleUpT $ fmap safeT vars) + + , FunD explGetN [Clause [sPat, etyPat] + (NormalB$ liftAll tuplE (explGetF <$> sEs)) [] ] + , PragmaD$ InlineP explGetN Inline FunLike AllPhases + + , FunD explSetN [Clause [sPat, etyPat, wPat] + (NormalB$ sequenceAll (zipWith explSetF sEs wEs)) [] ] + , PragmaD$ InlineP explSetN Inline FunLike AllPhases + + , FunD explResetN [Clause [sPat] + (NormalB$ sequenceAll (explResetF <$> sEs)) [] ] + , PragmaD$ InlineP explResetN Inline FunLike AllPhases + + , FunD explDestroyN [Clause [sPat, etyPat] + (NormalB$ sequenceAll (explDestroyF <$> sEs)) [] ] + , PragmaD$ InlineP explDestroyN Inline FunLike AllPhases + + , FunD explExistsN [Clause [sPat, etyPat] + (NormalB$ foldr explExistsAnd (AppE (VarE 'pure) (ConE 'True)) ((`AppE` etyE) . explExistsF <$> sEs)) [] ] + , PragmaD$ InlineP explExistsN Inline FunLike AllPhases + + , FunD explMembersN [Clause [sPat] + (NormalB$ foldl explMembersFold (explMembersF (head sEs)) (explExistsF <$> tail sEs)) [] ] + , PragmaD$ InlineP explMembersN Inline FunLike AllPhases + + , FunD explGetUnsafeN [Clause [sPat, etyPat] + (NormalB$ liftAll tuplE (explGetUnsafeF <$> sEs)) [] ] + , PragmaD$ InlineP explGetUnsafeN Inline FunLike AllPhases + + , FunD explSetMaybeN [Clause [sPat, etyPat, wPat] + (NormalB$ sequenceAll (zipWith explSetMaybeF sEs wEs)) [] ] + , PragmaD$ InlineP explSetMaybeN Inline FunLike AllPhases + + , FunD initStoreN [Clause [] + (NormalB$ liftAll tuplE (VarE initStoreN <$ sEs)) [] ] + , PragmaD$ InlineP initStoreN Inline FunLike AllPhases + + ] + + return [compI, hasI, strI] diff --git a/src/Apecs/Types.hs b/src/Apecs/Types.hs --- a/src/Apecs/Types.hs +++ b/src/Apecs/Types.hs @@ -4,6 +4,8 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} module Apecs.Types where @@ -11,6 +13,8 @@ import Data.Traversable (for) import qualified Data.Vector.Unboxed as U +import qualified Apecs.THTuples as T + -- | An Entity is really just an Int. The type variable is used to keep track of reads and writes, but can be freely cast. newtype Entity c = Entity Int deriving (Eq, Ord, Show) @@ -56,10 +60,8 @@ -- | Either writes or deletes a component explSetMaybe :: s -> Int -> SafeRW s -> IO () - -- | The initialization argument required by this store - type InitArgs s -- Initialize the store with its initialization arguments. - initStoreWith :: InitArgs s -> IO s + initStore :: IO s -- | Removes all components. -- Equivalent to calling @explDestroy@ on each member @@ -136,69 +138,7 @@ cast (Slice vec) = Slice vec -- Tuple Instances --- (,) -instance (Component a, Component b) => Component (a,b) where - type Storage (a, b) = (Storage a, Storage b) - -instance (Has w a, Has w b) => Has w (a,b) where - {-# INLINE getStore #-} - getStore = (,) <$> getStore <*> getStore - -instance (Store a, Store b) => Store (a,b) where - type InitArgs (a, b) = (InitArgs a, InitArgs b) - type Stores (a, b) = (Stores a, Stores b) - initStoreWith (aa, ab) = (,) <$> initStoreWith aa <*> initStoreWith ab - - explMembers (sa,sb) = explMembers sa >>= U.filterM (explExists sb) - explReset (sa,sb) = explReset sa >> explReset sb - explDestroy (sa,sb) ety = explDestroy sa ety >> explDestroy sb ety - explExists (sa,sb) ety = (&&) <$> explExists sa ety <*> explExists sb ety - {-# INLINE explMembers #-} - {-# INLINE explReset #-} - {-# INLINE explDestroy #-} - {-# INLINE explExists #-} - - type SafeRW (a, b) = (SafeRW a, SafeRW b) - explGetUnsafe (sa,sb) ety = (,) <$> explGetUnsafe sa ety <*> explGetUnsafe sb ety - explGet (sa,sb) ety = (,) <$> explGet sa ety <*> explGet sb ety - explSet (sa,sb) ety (wa,wb) = explSet sa ety wa >> explSet sb ety wb - explSetMaybe (sa,sb) ety (wa,wb) = explSetMaybe sa ety wa >> explSetMaybe sb ety wb - {-# INLINE explGetUnsafe #-} - {-# INLINE explGet #-} - {-# INLINE explSet #-} - {-# INLINE explSetMaybe #-} +T.makeInstances [2..6] instance (GlobalStore a, GlobalStore b) => GlobalStore (a,b) where - --- (,,) -instance (Component a, Component b, Component c) => Component (a,b,c) where - type Storage (a, b, c) = (Storage a, Storage b, Storage c) -instance (Has w a, Has w b, Has w c) => Has w (a,b,c) where - {-# INLINE getStore #-} - getStore = (,,) <$> getStore <*> getStore <*> getStore - -instance (Store a, Store b, Store c) => Store (a,b,c) where - type InitArgs (a, b, c) = (InitArgs a, InitArgs b, InitArgs c) - type Stores (a, b, c) = (Stores a, Stores b, Stores c) - initStoreWith (aa, ab, ac) = (,,) <$> initStoreWith aa <*> initStoreWith ab <*> initStoreWith ac - - explMembers (sa,sb,sc) = explMembers sa >>= U.filterM (explExists sb) >>= U.filterM (explExists sc) - explReset (sa,sb,sc) = explReset sa >> explReset sb >> explReset sc - explDestroy (sa,sb,sc) ety = explDestroy sa ety >> explDestroy sb ety >> explDestroy sc ety - explExists (sa,sb,sc) ety = and <$> sequence [explExists sa ety, explExists sb ety, explExists sc ety] - {-# INLINE explMembers #-} - {-# INLINE explReset #-} - {-# INLINE explDestroy #-} - {-# INLINE explExists #-} - - type SafeRW (a, b, c) = (SafeRW a, SafeRW b, SafeRW c) - explGetUnsafe (sa,sb,sc) ety = (,,) <$> explGetUnsafe sa ety <*> explGetUnsafe sb ety <*> explGetUnsafe sc ety - explGet (sa,sb,sc) ety = (,,) <$> explGet sa ety <*> explGet sb ety <*> explGet sc ety - explSet (sa,sb,sc) ety (wa,wb,wc) = explSet sa ety wa >> explSet sb ety wb >> explSet sc ety wc - explSetMaybe (sa,sb,sc) ety (wa,wb,wc) = explSetMaybe sa ety wa >> explSetMaybe sb ety wb >> explSetMaybe sc ety wc - {-# INLINE explGetUnsafe #-} - {-# INLINE explGet #-} - {-# INLINE explSet #-} - {-# INLINE explSetMaybe #-} - instance (GlobalStore a, GlobalStore b, GlobalStore c) => GlobalStore (a,b,c) where diff --git a/src/Apecs/Util.hs b/src/Apecs/Util.hs --- a/src/Apecs/Util.hs +++ b/src/Apecs/Util.hs @@ -7,7 +7,7 @@ initStore, runGC, unEntity, -- * EntityCounter - EntityCounter, initCounter, nextEntity, newEntity, + EntityCounter, nextEntity, newEntity, -- * Spatial hashing -- $hash @@ -22,33 +22,27 @@ import Control.Monad.Reader (liftIO) import Control.Applicative (liftA2) import System.CPUTime +import Data.Monoid import Apecs.Types import Apecs.Stores import Apecs.System --- | Initializes a store with (), useful since most stores have () as their initialization argument -initStore :: (Store s, InitArgs s ~ ()) => IO s -initStore = initStoreWith () - unEntity :: Entity a -> Int unEntity (Entity e) = e -- | Secretly just an int in a newtype -newtype EntityCounter = EntityCounter Int deriving (Num, Eq, Show) +newtype EntityCounter = EntityCounter {getCounter :: Sum Int} deriving (Monoid, Num, Eq, Show) + instance Component EntityCounter where type Storage EntityCounter = Global EntityCounter --- | Initialize an EntityCounter -initCounter :: IO (Storage EntityCounter) -initCounter = initStoreWith (EntityCounter 0) - -- | Bumps the EntityCounter and yields its value {-# INLINE nextEntity #-} nextEntity :: Has w EntityCounter => System w (Entity ()) -nextEntity = do EntityCounter n <- readGlobal - writeGlobal (EntityCounter (n+1)) - return (Entity n) +nextEntity = do n <- readGlobal + writeGlobal (n+1) + return (Entity . getSum . getCounter $ n) -- | Writes the given components to a new entity, and yields that entity {-# INLINE newEntity #-} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,6 +5,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -w #-} @@ -17,6 +18,7 @@ import Apecs import Apecs.Types +import Apecs.TH import Apecs.Util import qualified Apecs.Stores as S import qualified Apecs.Logs as S @@ -33,12 +35,10 @@ instance Component CachePos where type Storage CachePos = S.Cache 1 (S.Map CachePos) - newtype Velocity = Velocity Vec deriving (Arbitrary, Eq, Show) instance Component Velocity where type Storage Velocity = S.Map Velocity - data TestFlag = TestFlag instance Arbitrary TestFlag where arbitrary = return TestFlag instance S.Flag TestFlag where flag = TestFlag @@ -56,30 +56,27 @@ instance Arbitrary (RandomEntity a) where arbitrary = RandomEntity . Entity . abs <$> arbitrary -newtype W1 c = W1 {w1c1 :: (Storage c)} -instance Component c => Has (W1 c) c where getStore = System $ asks w1c1 - -data W2 a b = W2 { w2c1 :: Storage a , w2c2 :: Storage b } -instance (Component a, Component b) => Has (W2 a b) a where getStore = System $ asks w2c1 -instance (Component a, Component b) => Has (W2 a b) b where getStore = System $ asks w2c2 +makeWorld "Counter" [''CachePos] counter :: [CachePos] -> CachePos -> Property counter cs c = monadicIO $ run f >>= assert where f = do - w :: W2 CachePos EntityCounter <- W2 <$> initStore <*> initCounter + w <- initCounter runWith w $ do forM_ cs newEntity e <- newEntity c Safe r <- get e return (r == Just c) +makeWorld "GetSetPos" [''Position] + getSetPos :: [(RandomEntity Position, Position)] -> RandomEntity Position -> Position -> Property getSetPos cs (RandomEntity e) p = monadicIO $ run f >>= assert where f = do - w :: Storage Position <- initStore - runWith (W1 w) $ do + w <- initGetSetPos + runWith w $ do forM_ cs $ \(RandomEntity ety, pos) -> set ety pos set e p Safe r <- get e @@ -88,27 +85,28 @@ Members set <- liftIO$ readIORef ref return (r == Just p && sl1 == U.fromList (S.toList set)) +makeWorld "GetSetVCPos" [''Velocity, ''CachePos] + getSetVCPos :: [(RandomEntity (Velocity, CachePos), (Velocity, CachePos))] -> RandomEntity (Velocity, CachePos) -> (Velocity, CachePos) -> Property getSetVCPos cs (RandomEntity e) (v,p) = monadicIO $ run f >>= assert where f = do - wp :: Storage CachePos <- initStore - wv :: Storage Velocity <- initStore - runWith (W2 wp wv) $ do + w <- initGetSetVCPos + runWith w $ do forM_ cs $ \(RandomEntity ety, pos) -> set ety pos set e (v,p) Safe r <- get e return (r == (Just v, Just p)) +makeWorld "CmapVP" [''Velocity, ''CachePos] cmapVP :: [(RandomEntity (Velocity, CachePos), (Velocity, CachePos))] -> RandomEntity (Velocity, CachePos) -> (Velocity, CachePos) -> Property cmapVP cs (RandomEntity e) (v,p) = monadicIO $ run f >>= assert where f = do let swapP (CachePos (x,y)) = CachePos (y,x) swapV (Velocity (x,y)) = Velocity (y,x) - wp :: Storage CachePos <- initStore - wv :: Storage Velocity <- initStore - runWith (W2 wp wv) $ do + w <- initCmapVP + runWith w $ do forM_ cs $ \(RandomEntity ety, pos) -> set ety pos set e (v,p) cmap $ \(v,p) -> (swapV v, swapP p)