apecs 0.2.2.0 → 0.2.3.0

raw patch · 11 files changed

+313/−218 lines, 11 filesdep +template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: template-haskell

API changes (from Hackage documentation)

Files

• README.md +23/−39
• apecs.cabal +5/−2
• bench/Main.hs +8/−53
• src/Apecs.hs +3/−7
• src/Apecs/Logs.hs +1/−2
• src/Apecs/Stores.hs +14/−19
• src/Apecs/TH.hs +61/−0
• src/Apecs/THTuples.hs +170/−0
• src/Apecs/Types.hs +6/−66
• src/Apecs/Util.hs +7/−13
• test/Main.hs +15/−17

@@ -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 ```

@@ -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:

@@ -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   ]

@@ -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,

@@ -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

@@ -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 #-}

@@ -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])+

@@ -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]

@@ -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

@@ -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 #-}

@@ -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)