apecs 0.2.3.0 → 0.2.4.0

raw patch · 10 files changed

+206/−101 lines, 10 filesdep +asyncPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async

API changes (from Hackage documentation)

Files

• README.md +7/−1
• apecs.cabal +9/−1
• bench/Main.hs +13/−5
• src/Apecs/Concurrent.hs +92/−0
• src/Apecs/Logs.hs +0/−1
• src/Apecs/Stores.hs +3/−3
• src/Apecs/System.hs +0/−3
• src/Apecs/THTuples.hs +2/−1
• src/Apecs/Types.hs +3/−5
• test/Main.hs +77/−81

@@ -16,6 +16,8 @@ | build  | 699 us | 285 us |  | update | 34 us  | 46 us  | +There is a performance guide [here](https://github.com/jonascarpay/apecs/blob/master/tutorials/GoingFast.md).+ ### Example ```haskell import Apecs@@ -53,10 +55,14 @@   -- set (over)writes components   set ety (Velocity 2) +  let stepVelocity (Position p, Velocity v) = Position (v+p)+   -- 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)+  rmap stepVelocity+  -- prmap n does the same, but in parallel+  prmap 2 stepVelocity    -- Print all positions   cmapM_ $ \(Position p) -> liftIO (print p)

@@ -1,5 +1,5 @@ name:                apecs-version:             0.2.3.0+version:             0.2.4.0 homepage:            https://github.com/jonascarpay/apecs#readme license:             BSD3 license-file:        LICENSE@@ -12,6 +12,10 @@ synopsis:            A fast ECS for game engine programming description:         A fast ECS for game engine programming +source-repository head+  type:     git+  location: git://github.com/jonascarpay/apecs.git+ library   hs-source-dirs:     src@@ -21,6 +25,7 @@     Apecs.Stores,     Apecs.Logs,     Apecs.System,+    Apecs.Concurrent,     Apecs.Slice,     Apecs.TH,     Apecs.Util@@ -33,6 +38,7 @@     containers,     mtl,     template-haskell,+    async,     vector   ghc-options:     -Wall@@ -74,5 +80,7 @@     -Odph     -fllvm     -optlo-O3+    -threaded+    -with-rtsopts=-N     -funfolding-use-threshold1000     -funfolding-keeness-factor1000

@@ -11,6 +11,7 @@ import Apecs.TH import Apecs.Stores import Apecs.Util+import Apecs.Concurrent import qualified Apecs.Slice as S  -- ecs_bench@@ -22,15 +23,22 @@  makeWorld "ECSB" [''ECSPos, ''ECSVel] -pvInit = do replicateM_ 1000 (newEntity (ECSPos 0, ECSVel 1))-            replicateM_ 9000 (newEntity (ECSPos 0))+ecsbInit = do replicateM_ 1000 (newEntity (ECSPos 0, ECSVel 1))+              replicateM_ 9000 (newEntity (ECSPos 0)) -pvStep = rmap $ \(ECSVel v, ECSPos p) -> ECSPos (p+v)+stepVel (ECSVel v, ECSPos p) = ECSPos (p+v)  main :: IO () main = C.defaultMain   [ bgroup "ecs_bench"-    [ bench "init" $ whnfIO (initECSB >>= runSystem pvInit)-    , bench "step" $ whnfIO (initECSB >>= runSystem (pvInit >> pvStep))+    [ bench "init" $ whnfIO (initECSB >>= runSystem ecsbInit)+    , bench "step" $ whnfIO (initECSB >>= runSystem (ecsbInit >> rmap stepVel))+    , bgroup "concurrent" $+      [ bench "grain 10"  $ whnfIO (initECSB >>= runSystem (ecsbInit >> prmap 10  stepVel))+      , bench "grain 100" $ whnfIO (initECSB >>= runSystem (ecsbInit >> prmap 100 stepVel))+      , bench "grain 125" $ whnfIO (initECSB >>= runSystem (ecsbInit >> prmap 125 stepVel))+      , bench "grain 500" $ whnfIO (initECSB >>= runSystem (ecsbInit >> prmap 500 stepVel))+      , bench "grain 1000" $ whnfIO (initECSB >>= runSystem (ecsbInit >> prmap 1000 stepVel))+      ]     ]   ]

@@ -0,0 +1,92 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}++module Apecs.Concurrent (+  concurrently,+  pcmap, prmap, pwmap, pcmap', prmap', pwmap',+) where+++import qualified Control.Concurrent.Async as A+import Control.Monad.Reader+import qualified Data.Vector.Unboxed as U++import Apecs.Types+import Apecs.System++-- | Executes a list of systems concurrently, and blocks until all have finished.+--   Provides zero protection against race conditions, so use with caution.+concurrently :: [System w ()] -> System w ()+concurrently ss = do w <- System ask+                     liftIO . A.mapConcurrently_ (runWith w) $ ss++{-# INLINE parallelize #-}+parallelize :: U.Unbox a => Int -> (a -> IO b) -> U.Vector a -> IO ()+parallelize grainSize sys vec+  | U.length vec <= grainSize = U.mapM_ sys vec+  | otherwise = A.mapConcurrently_ (U.mapM_ sys) vecSplits+    where+      vecSplits = go vec+      go vec+        | U.null vec = []+        | otherwise = let (h,t) = U.splitAt grainSize vec in h : go t++-- | Executes a map in parallel by requesting a slice of all components,+--   and spawning threads iterating over @grainSize@ components each.+{-# INLINE pcmap #-}+pcmap :: forall world c. Has world c => Int -> (c -> c) -> System world ()+pcmap grainSize f = do+  s :: Storage c <- getStore+  liftIO$ do+    sl <- explMembers s+    parallelize grainSize (\e -> explModify s e f) sl++-- | @rmap@ version of @pcmap@+{-# INLINE prmap #-}+prmap :: forall world r w. (Has world w, Has world r)+      => Int -> (r -> w) -> System world ()+prmap grainSize f =+  do sr :: Storage r <- getStore+     sw :: Storage w <- getStore+     liftIO$ do+       sl <- explMembers sr+       parallelize grainSize (\e -> explGetUnsafe sr e >>= explSet sw e . f) sl++-- | @cmap'@ version of @pcmap@+{-# INLINE pcmap' #-}+pcmap' :: forall world c. Has world c => Int -> (c -> Safe c) -> System world ()+pcmap' grainSize f = do+  s :: Storage c <- getStore+  liftIO$ do sl <- explMembers s+             parallelize grainSize (\e -> explGetUnsafe s e >>= explSetMaybe s e . getSafe . f) sl++-- | @rmap'@ version of @pcmap@+{-# INLINE prmap' #-}+prmap' :: forall world r w. (Has world w, Has world r, Store (Storage r), Store (Storage w))+      => Int -> (r -> Safe w) -> System world ()+prmap' grainSize f = do+  sr :: Storage r <- getStore+  sw :: Storage w <- getStore+  liftIO$ do sl <- explMembers sr+             parallelize grainSize (\e -> explGetUnsafe sr e >>= explSetMaybe sw e . getSafe . f) sl++-- | @wmap@ version of @pcmap@+{-# INLINE pwmap #-}+pwmap :: forall world r w. (Has world w, Has world r, Store (Storage r), Store (Storage w))+     => Int -> (Safe r -> w) -> System world ()+pwmap grainSize f = do+  sr :: Storage r <- getStore+  sw :: Storage w <- getStore+  liftIO$ do sl <- explMembers sr+             parallelize grainSize (\e -> explGet sr e >>= explSet sw e . f . Safe) sl++-- | @wmap'@ version of @pcmap@+{-# INLINE pwmap' #-}+pwmap' :: forall world r w. (Has world w, Has world r, Store (Storage r), Store (Storage w))+       => Int -> (Safe r -> Safe w) -> System world ()+pwmap' grainSize f =+  do sr :: Storage r <- getStore+     sw :: Storage w <- getStore+     liftIO$ do sl <- explMembers sr+                parallelize grainSize (\e -> explGet sr e >>= explSetMaybe sw e . getSafe . f . Safe) sl+

@@ -1,6 +1,5 @@ {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts #-}-{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Strict #-} 

@@ -1,9 +1,9 @@ {-# LANGUAGE Strict #-}-{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}-{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE ConstraintKinds, DataKinds, KindSignatures #-}+{-# LANGUAGE DataKinds, KindSignatures #-} {-# LANGUAGE TypeApplications #-}  module Apecs.Stores

@@ -1,9 +1,6 @@ {-# LANGUAGE Strict #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}  module Apecs.System where 

@@ -5,6 +5,8 @@ import Language.Haskell.TH import qualified Data.Vector.Unboxed as U +-- | Generate tuple instances for the following tuple sizes.+makeInstances :: [Int] -> Q [Dec] makeInstances is = concat <$> traverse tupleInstances is  {--@@ -45,7 +47,6 @@       varTuple = tupleUpT vars       tuplN = tupleDataName n       tuplE = ConE tuplN-      pureTuplE = AppE (VarE (mkName "pure")) tuplE        compN = mkName "Component"       compT var = ConT compN `AppT` var

@@ -1,11 +1,9 @@-{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}-{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE LambdaCase #-}  module Apecs.Types where @@ -28,7 +26,7 @@ --   The storage in turn supplies runtime types for the component. --   For the component to be valid, its Storage must be in instance of Store. class (Stores (Storage c) ~ c, Store (Storage c)) => Component c where-  type Storage c = s | s -> c+  type Storage c  -- | A world `Has` a component if it can produce its Storage class Component c => Has w c where

@@ -11,7 +11,6 @@  import Test.QuickCheck import Test.QuickCheck.Monadic-import Control.Monad import qualified Data.IntSet as S import qualified Data.Vector.Unboxed as U import Data.IORef@@ -19,102 +18,99 @@ import Apecs import Apecs.Types import Apecs.TH-import Apecs.Util-import qualified Apecs.Stores as S-import qualified Apecs.Logs as S+import Apecs.Stores+import Apecs.Logs  type Vec = (Double, Double) ----+-- Preamble+newtype RandomEntity a = RandomEntity {getRandom :: Entity a} deriving (Eq, Show)+instance Arbitrary (RandomEntity a) where+  arbitrary = RandomEntity . Entity . abs <$> arbitrary -newtype Position = Position Vec deriving (Arbitrary, Eq, Show)-instance Component Position where-  type Storage Position = S.Logger (S.FromPure Members) (S.Map Position)+assertSys :: IO w -> System w Bool -> Property+assertSys initW sys = monadicIO $ run (initW >>= runSystem sys) >>= assert -newtype CachePos = CachePos Vec deriving (Arbitrary, Eq, Show)-instance Component CachePos where-  type Storage CachePos = S.Cache 1 (S.Map CachePos)+type Inserts a = [a]+type Deletes a = [RandomEntity a]+type Writes a  = [(RandomEntity a, a)]+type Scramble a = (Inserts a, Writes a, Deletes a) -newtype Velocity = Velocity Vec deriving (Arbitrary, Eq, Show)-instance Component Velocity where-  type Storage Velocity = S.Map Velocity+insertAll :: (Has w EntityCounter, Has w c) => Inserts c -> System w ()+insertAll = mapM_ newEntity+writeAll  :: Has w c => Writes c -> System w ()+writeAll = mapM_ $ \(e, w) -> set (getRandom e) w+deleteAll :: Has w c => Deletes c -> System w ()+deleteAll = mapM_ (destroy . getRandom)+scramble :: (Has w EntityCounter, Has w c) => Scramble c -> System w ()+scramble (is, ws, ds) = insertAll is >> writeAll ws >> deleteAll ds -data TestFlag = TestFlag-instance Arbitrary TestFlag where arbitrary = return TestFlag-instance S.Flag TestFlag where flag = TestFlag-instance Component TestFlag where-  type Storage TestFlag = S.Set TestFlag+-- Tests whether writing and reading gives back the original component+newtype MapInt = MapInt Int deriving (Eq, Show, Arbitrary)+instance Component MapInt where type Storage MapInt = Map MapInt+makeWorld "SetGetMI" [''MapInt] +setGetProp :: Scramble MapInt -> RandomEntity MapInt -> MapInt -> Property+setGetProp scr (RandomEntity re) rw = assertSys initSetGetMI $ do+  scramble scr+  set re rw+  Safe r :: Safe MapInt <- get re+  return (r == Just rw) -newtype Members c = Members S.IntSet-instance S.PureLog Members c where-  pureEmpty = Members mempty-  pureOnSet (Entity e) _ _ (Members s) = Members $ S.insert e s-  pureOnDestroy (Entity e) _ (Members s) = Members $ S.delete e s+-- Tests whether this is also true for caches+newtype CacheInt = CacheInt Int deriving (Eq, Show, Arbitrary)+instance Component CacheInt where type Storage CacheInt = Cache 2 (Map CacheInt)+makeWorld "SetGetCI" [''CacheInt] -newtype RandomEntity a = RandomEntity (Entity a) deriving (Eq, Show)-instance Arbitrary (RandomEntity a) where-  arbitrary = RandomEntity . Entity . abs <$> arbitrary+setGetPropC :: Scramble CacheInt -> RandomEntity CacheInt -> CacheInt -> Property+setGetPropC scr (RandomEntity re) rw = assertSys initSetGetCI $ do+  scramble scr+  set re rw+  Safe r :: Safe CacheInt <- get re+  return (r == Just rw) -makeWorld "Counter" [''CachePos]+-- Tests basic tuple functionality+newtype T1 = T1 Int deriving (Eq, Show, Arbitrary)+newtype T2 = T2 Int deriving (Eq, Show, Arbitrary)+newtype T3 = T3 Int deriving (Eq, Show, Arbitrary)+instance Component T1 where type Storage T1 = Map T1+instance Component T2 where type Storage T2 = Map T2+instance Component T3 where type Storage T3 = Map T3 -counter :: [CachePos] -> CachePos -> Property-counter cs c = monadicIO $ run f >>= assert-  where-    f = do-      w <- initCounter-      runWith w $ do-        forM_ cs newEntity-        e <- newEntity c-        Safe r <- get e-        return (r == Just c)+makeWorld "Tuples" [''T1, ''T2, ''T3] -makeWorld "GetSetPos" [''Position]+setGetTuple :: (T1, T2, T3) -> Inserts (T1, T2, T3) -> Property+setGetTuple w@(T1 n1, T2 n2, T3 n3) ws = assertSys initTuples $ do+  e <- newEntity w+  insertAll ws+  cmap $ \(T1 n) -> T1 (n+1)+  Safe (r1, r2, r3) <- get e+  return $ r1 == Just (T1 $ n1+1) && r2 == Just (T2 n2) && r3 == Just (T3 n3) -getSetPos :: [(RandomEntity Position, Position)] -> RandomEntity Position -> Position -> Property-getSetPos cs (RandomEntity e) p = monadicIO $ run f >>= assert-  where-    f = do-      w <- initGetSetPos-      runWith w $ do-        forM_ cs $ \(RandomEntity ety, pos) -> set ety pos-        set e p-        Safe r <- get e-        Slice sl1 :: Slice Position <- owners-        S.FromPure ref :: S.FromPure Members Position <- S.getLog-        Members set <- liftIO$ readIORef ref-        return (r == Just p && sl1 == U.fromList (S.toList set))+-- This Log should be able to track the members of the underlying store+newtype Members c = Members S.IntSet+instance PureLog Members c where+  pureEmpty = Members mempty+  pureOnSet     (Entity e) _ _ (Members s) = Members $ S.insert e s+  pureOnDestroy (Entity e) _   (Members s) = Members $ S.delete e s -makeWorld "GetSetVCPos" [''Velocity, ''CachePos]+data Logged = Logged deriving (Eq, Show)+instance Arbitrary Logged where arbitrary = return Logged+instance Component Logged where type Storage Logged = Logger (FromPure Members) (Map Logged) -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-      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 "LoggerProp" [''Logged] -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)-      w <- initCmapVP-      runWith w $ do-        forM_ cs $ \(RandomEntity ety, pos) -> set ety pos-        set e (v,p)-        cmap $ \(v,p) -> (swapV v, swapP p)-        Safe r <- get e-        return (r == (Just $ swapV v, Just $ swapP p))+loggerProp :: Scramble Logged -> Property+loggerProp s = assertSys initLoggerProp $ do+  scramble s+  Slice sl :: Slice Logged <- owners+  FromPure ref :: FromPure Members Logged <- getLog+  Members set <- liftIO$ readIORef ref+  return (sl == U.fromList (S.toList set)) + main = do-  quickCheck getSetPos-  quickCheck getSetVCPos-  quickCheck cmapVP-  quickCheck counter+  quickCheck setGetProp+  quickCheck setGetTuple+  quickCheck setGetPropC+  quickCheck loggerProp