apecs 0.2.0.3 → 0.2.1.0

raw patch · 11 files changed

+424/−270 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +1/−1
• apecs.cabal +9/−5
• spec/Spec.hs +0/−108
• src/Apecs.hs +4/−4
• src/Apecs/Logs.hs +207/−0
• src/Apecs/Stores.hs +73/−110
• src/Apecs/System.hs +2/−10
• src/Apecs/Types.hs +5/−14
• src/Apecs/Util.hs +14/−16
• test/Main.hs +107/−0
• tutorials/RTS.md +2/−2

@@ -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) | [tutorial](https://github.com/jonascarpay/apecs/blob/master/tutorials/RTS.md)+##### [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/)  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.

@@ -1,5 +1,5 @@ name:                apecs-version:             0.2.0.3+version:             0.2.1.0 homepage:            https://github.com/jonascarpay/apecs#readme license:             BSD3 license-file:        LICENSE@@ -19,6 +19,7 @@     Apecs,     Apecs.Types,     Apecs.Stores,+    Apecs.Logs,     Apecs.System,     Apecs.Slice,     Apecs.Util@@ -34,19 +35,22 @@     -Odph     -fno-warn-unused-top-binds -test-suite apecs-spec+test-suite apecs-test   type:     exitcode-stdio-1.0   main-is:-    Spec.hs+    Main.hs   hs-source-dirs:-    spec+    test   build-depends:     base >= 4.7 && < 5,     apecs,-    QuickCheck+    QuickCheck,+    containers,+    vector   default-language:     Haskell2010+  ghc-options: -Wall  benchmark apecs-bench   type:

@@ -1,108 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}--import Test.QuickCheck-import Test.QuickCheck.Monadic-import Control.Monad--import Apecs-import Apecs.Types-import Apecs.Util-import qualified Apecs.Stores as S--type Vec = (Double, Double)--newtype Position = Position Vec deriving (Arbitrary, Eq, Show)-instance Component Position where-  type Storage Position = S.Map Position--newtype CachePos = CachePos Vec deriving (Arbitrary, Eq, Show)-instance Component CachePos where-  type Storage CachePos = S.Map CachePos---newtype Velocity = Velocity Vec deriving (Arbitrary, Eq, Show)-instance Component Velocity where-  type Storage Velocity = S.Map Velocity---data Flag = Flag-instance Arbitrary Flag where arbitrary = return Flag-instance S.Flag Flag where flag = Flag-instance Component Flag where-  type Storage Flag = S.Set Flag---newtype RandomEntity a = RandomEntity (Entity a) deriving (Eq, Show)-instance Arbitrary (RandomEntity a) where-  arbitrary = RandomEntity . Entity <$> arbitrary--newtype W1 c = W1 {getIdentity :: (Storage c)}-instance Component c => Has (W1 c) c where getStore = System $ asks getIdentity--data W2 a b = W2 { c1 :: Storage a-                 , c2 :: Storage b-                 }--instance (Component a, Component b) => Has (W2 a b) a where getStore = System $ asks c1-instance (Component a, Component b) => Has (W2 a b) b where getStore = System $ asks c2--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-        forM_ cs $ \(RandomEntity ety, pos) -> set ety pos-        set e p-        Safe r <- get e-        return (r == Just p)--getSetCPos :: [(RandomEntity CachePos, CachePos)] -> RandomEntity CachePos -> CachePos -> Property-getSetCPos cs (RandomEntity e) p = monadicIO $ run f >>= assert-  where-    f = do-      w :: Storage CachePos <- initStore-      runWith (W1 w) $ do-        forM_ cs $ \(RandomEntity ety, pos) -> set ety pos-        set e p-        Safe r <- get e-        return (r == Just p)--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-        forM_ cs $ \(RandomEntity ety, pos) -> set ety pos-        set e (v,p)-        Safe r <- get e-        return (r == (Just v, Just p))--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-        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))---main = do-  quickCheck getSetPos-  quickCheck getSetCPos-  quickCheck getSetVCPos-  quickCheck cmapVP

@@ -4,7 +4,9 @@   -- * Types     System(..),     Component(..), Entity(..), Slice, Has(..), Safe(..), cast,+    Map, Set, Unique, Global, +   -- * Initializable     initStoreWith, @@ -12,7 +14,7 @@     destroy, exists, owners, resetStore,    -- * Store wrapper functions-    get, set, setOrDelete, modify,+    get, set, set', modify,     cmap, cmapM, cmapM_, cimapM, cimapM_,     rmap', rmap, wmap, wmap', cmap', @@ -20,9 +22,6 @@   -- * GlobalRW wrapper functions     readGlobal, writeGlobal, modifyGlobal, -  -- * Query-    slice, All(..),-   -- * Other     runSystem, runWith, @@ -38,4 +37,5 @@ import Apecs.Types import Apecs.System import Apecs.Slice as SL+import Apecs.Stores 

@@ -0,0 +1,207 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, ConstraintKinds #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Strict #-}++module Apecs.Logs+  ( -- * Types and classes+    Log(..), PureLog(..), FromPure(..), Logger, getLog,+    LVec1, LVec2, LVec3,++    -- * EnumTable+    EnumTable, byIndex, byEnum,+  ) where++import Data.IORef+import qualified Data.Vector.Mutable as VM+import qualified Data.IntSet as S+import Control.Monad.Reader++import Apecs.Types+import Apecs.Stores+import Apecs.Slice++-- | A PureLog is a piece of state @l c@ that is updated when components @c@ are written or destroyed.+--   Note that @l :: * -> *@+class PureLog l c where+  pureEmpty :: l c+  pureOnSet :: Entity a -> Maybe c -> c -> l c -> l c+  pureOnDestroy :: Entity a -> c -> l c -> l c++-- | A Log is a PureLog with mutable state.+class Log l c where+  logEmpty     :: IO (l c)+  logOnSet     :: l c -> Entity a -> Maybe c -> c -> IO ()+  logOnDestroy :: l c -> Entity a -> c -> IO ()+  logReset     :: l c -> IO ()++class HasLog s l where+  explGetLog :: s -> l (Stores s)++instance HasLog (Logger l s) l where+  {-# INLINE explGetLog #-}+  explGetLog (Logger l _) = l++-- | Produces the log indicated by the return type.+{-# INLINE getLog #-}+getLog :: forall w c l. (IsRuntime c, Has w c, HasLog (Storage c) l, Log l c) => System w (l c)+getLog = do s :: Storage c <- getStore+            return (explGetLog s)+++-- | FromPure turns a PureLog into a Log+newtype FromPure l c = FromPure (IORef (l c))+instance PureLog l c => Log (FromPure l) c where+  {-# INLINE logEmpty #-}+  logEmpty = FromPure <$> newIORef pureEmpty+  {-# INLINE logOnSet #-}+  logOnSet (FromPure lref) e old new = modifyIORef' lref (pureOnSet e old new)+  {-# INLINE logOnDestroy #-}+  logOnDestroy (FromPure lref) e c = modifyIORef' lref (pureOnDestroy e c)+  {-# INLINE logReset #-}+  logReset (FromPure lref) = writeIORef lref pureEmpty++-- | A @Logger l@ of some store updates its @Log l@ with the writes and deletes to @Store s@+data Logger l s = Logger (l (Stores s)) s++instance (Log l (Stores s), Cachable s) => Initializable (Logger l s) where+  type InitArgs (Logger l s) = InitArgs s+  initStoreWith args = Logger <$> logEmpty <*> initStoreWith args++instance (Log l (Stores s), Cachable s) => HasMembers (Logger l s) where+  {-# INLINE explDestroy #-}+  explDestroy (Logger l s) ety = do+    mc <- explGet s ety+    case mc of+      Just c -> logOnDestroy l (Entity ety) c >> explDestroy s ety+      _ -> return ()++  {-# INLINE explExists #-}+  explExists (Logger _ s) ety = explExists s ety+  {-# INLINE explMembers #-}+  explMembers (Logger _ s) = explMembers s+  {-# INLINE explReset #-}+  explReset (Logger l s) = logReset l >> explReset s+  {-# INLINE explImapM_ #-}+  explImapM_ (Logger _ s) = explImapM_ s+  {-# INLINE explImapM #-}+  explImapM (Logger _ s) = explImapM s++instance (Log l (Stores s), Cachable s) => Store (Logger l s) where+  type SafeRW (Logger l s) = SafeRW s+  type Stores (Logger l s) = Stores s++  {-# INLINE explGetUnsafe #-}+  explGetUnsafe (Logger _ s) ety = explGetUnsafe s ety+  {-# INLINE explGet #-}+  explGet (Logger _ s) ety = explGet s ety+  {-# INLINE explSet #-}+  explSet (Logger l s) ety x = do+    mc <- explGet s ety+    logOnSet l (Entity ety) mc x+    explSet s ety x++  {-# INLINE explSetMaybe #-}+  explSetMaybe s ety (Nothing) = explDestroy s ety+  explSetMaybe s ety (Just x) = explSet s ety x++  {-# INLINE explModify #-}+  explModify (Logger l s) ety f = do+    mc <- explGet s ety+    case mc of+      Just c -> explSet (Logger l s) ety (f c)+      Nothing -> return ()++  {-# INLINE explCmapM_ #-}+  explCmapM_  (Logger _ s) = explCmapM_  s+  {-# INLINE explCmapM #-}+  explCmapM   (Logger _ s) = explCmapM   s+  {-# INLINE explCimapM_ #-}+  explCimapM_ (Logger _ s) = explCimapM_ s+  {-# INLINE explCimapM #-}+  explCimapM  (Logger _ s) = explCimapM  s++-- | Composite Log consisting of 1 Log+newtype LVec1 l c = LVec1 (l c)+instance Log l c => Log (LVec1 l) c where+  {-# INLINE logEmpty #-}+  logEmpty = LVec1 <$> logEmpty+  {-# INLINE logOnSet #-}+  logOnSet     (LVec1 l) e old new = logOnSet l e old new+  {-# INLINE logOnDestroy #-}+  logOnDestroy (LVec1 l) e c       = logOnDestroy l e c+  {-# INLINE logReset #-}+  logReset     (LVec1 l)           = logReset l++-- | Composite Log consisting of 2 Logs+data LVec2 l1 l2 c = LVec2 (l1 c) (l2 c)+instance (Log l1 c, Log l2 c) => Log (LVec2 l1 l2) c where+  {-# INLINE logEmpty #-}+  logEmpty = LVec2 <$> logEmpty <*> logEmpty+  {-# INLINE logOnSet #-}+  logOnSet     (LVec2 l1 l2) e old new = logOnSet l1 e old new >> logOnSet l2 e old new+  {-# INLINE logOnDestroy #-}+  logOnDestroy (LVec2 l1 l2) e c       = logOnDestroy l1 e c >> logOnDestroy l2 e c+  {-# INLINE logReset #-}+  logReset     (LVec2 l1 l2)           = logReset l1 >> logReset l2++-- | Composite Log consisting of 3 Logs+data LVec3 l1 l2 l3 c = LVec3 (l1 c) (l2 c) (l3 c)+instance (Log l1 c, Log l2 c, Log l3 c) => Log (LVec3 l1 l2 l3) c where+  {-# INLINE logEmpty #-}+  logEmpty = LVec3 <$> logEmpty <*> logEmpty <*> logEmpty+  {-# INLINE logOnSet #-}+  logOnSet (LVec3 l1 l2 l3) e old new = do+    logOnSet l1 e old new+    logOnSet l2 e old new+    logOnSet l3 e old new+  {-# INLINE logOnDestroy #-}+  logOnDestroy (LVec3 l1 l2 l3) e c = do+    logOnDestroy l1 e c+    logOnDestroy l2 e c+    logOnDestroy l3 e c+  {-# INLINE logReset #-}+  logReset (LVec3 l1 l2 l3) = do+    logReset l1+    logReset l2+    logReset l3++-- | Hashtable that maintains buckets of entities whose @fromEnum c@ produces the same value+newtype EnumTable c = EnumTable (VM.IOVector S.IntSet)+instance (Bounded c, Enum c) => Log EnumTable c where+  {-# INLINE logEmpty #-}+  logEmpty = do+    let lo = fromEnum (minBound :: c)+        hi = fromEnum (maxBound :: c)++    if lo == 0+       then EnumTable <$> VM.replicate (hi+1) mempty+       else error "Attempted to initialize EnumTable for a component with a non-zero minBound"++  {-# INLINE logOnSet #-}+  logOnSet (EnumTable vec) (Entity e) old new = do+    case old of+      Nothing -> return ()+      Just c -> VM.modify vec (S.delete e) (fromEnum c)+    VM.modify vec (S.insert e) (fromEnum new)++  {-# INLINE logOnDestroy #-}+  logOnDestroy (EnumTable vec) (Entity e) c = VM.modify vec (S.delete e) (fromEnum c)++  {-# INLINE logReset #-}+  logReset (EnumTable vec) = forM_ [0..VM.length vec - 1] (\e -> VM.write vec e mempty)++-- | Query the @EnumTable@ by an index (the result of @fromEnum@).+--   Will return an empty slice if @index < 0@ of @index >= fromEnum (maxBound)@.+{-# INLINE byIndex #-}+byIndex :: EnumTable c -> Int -> System w (Slice c)+byIndex (EnumTable vec) c+  | c < 0                  = return mempty+  | c >= VM.length vec - 1 = return mempty+  | otherwise = liftIO$ sliceFromList . S.toList <$> VM.read vec c++-- | Query the @EnumTable@ by an example enum.+--   Will not perform bound checks, so crashes if @fromEnum c < 0 && fromEnum c > fromEnum maxBound @.+byEnum :: Enum c => EnumTable c -> c -> System w (Slice c)+byEnum (EnumTable vec) c = liftIO$ sliceFromList . S.toList <$> VM.read vec (fromEnum c)

@@ -5,12 +5,11 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE ConstraintKinds, DataKinds, KindSignatures #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}  module Apecs.Stores-  ( Map, Set, Flag(..), Cache,+  ( Map, Set, Flag(..), Cache, Unique,     Global,-    IndexTable, ToIndex(..), ByIndex(..), ByComponent(..),+    Cachable,   ) where  import qualified Data.IntMap.Strict as M@@ -110,6 +109,70 @@   {-# INLINE explCmap #-}   {-# INLINE explModify #-} +-- | A Unique contains exactly one component belonging to some entity.+--   Writing to it overwrites both the previous component and its owner.+data Unique c = Unique (IORef Int) (IORef c)+instance Initializable (Unique c) where+  type InitArgs (Unique c) = ()+  initStoreWith _ = Unique <$> newIORef (-1) <*> newIORef undefined+instance HasMembers (Unique c) where+  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)+  explExists  (Unique eref _) ety = (==ety) <$> readIORef eref+  explImapM_  (Unique eref _) ma = do e <- liftIO (readIORef eref); when (e /= -1) (void$ ma e)+  explImapM   (Unique eref _) ma = do+    e <- liftIO (readIORef eref)+    if e /= -1 then return [] else pure <$> ma e+  {-# INLINE explDestroy #-}+  {-# INLINE explMembers #-}+  {-# INLINE explExists #-}+  {-# INLINE explReset #-}+  {-# INLINE explImapM_ #-}+  {-# INLINE explImapM #-}++instance Store (Unique c) where+  type SafeRW (Unique c) = Maybe c+  type Stores (Unique c) = c+  explGetUnsafe (Unique _ cref) _ = readIORef cref+  explGet       (Unique eref cref) ety = do+    e <- readIORef eref+    if e == ety then Just <$> readIORef cref else return Nothing++  explSet       (Unique eref cref) ety x = writeIORef eref ety >> writeIORef cref x+  explSetMaybe  s ety Nothing = explDestroy s ety+  explSetMaybe  s ety (Just x) = explSet s ety x+  explCmap      (Unique _    cref) f = modifyIORef' cref f+  explModify    (Unique eref cref) ety f = do+    e <- readIORef eref+    when (e==ety) (modifyIORef' cref f)++  explCmapM (Unique eref cref) ma = do+    e <- liftIO$ readIORef eref+    if e /= -1 then liftIO (readIORef cref) >>= fmap pure . ma+               else return []++  explCmapM_ (Unique eref cref) ma = do+    e <- liftIO$ readIORef eref+    when (e /= -1) . void $ liftIO (readIORef cref) >>= ma++  explCimapM (Unique eref cref) ma = do+    e <- liftIO$ readIORef eref+    if e /= -1 then liftIO (readIORef cref) >>= fmap pure . ma . (,) e+               else return []++  explCimapM_ (Unique eref cref) ma = do+    e <- liftIO$ readIORef eref+    when (e /= -1) . void $ liftIO (readIORef cref) >>= ma . (,) e++  {-# INLINE explGetUnsafe #-}+  {-# INLINE explGet #-}+  {-# INLINE explSet #-}+  {-# INLINE explSetMaybe #-}+  {-# INLINE explCmap #-}+  {-# INLINE explModify #-}++ -- | Constant value. Not very practical, but fun to write. newtype Const c = Const c instance Initializable (Const c) where@@ -155,7 +218,11 @@ data Cache (n :: Nat) s =   Cache Int (UM.IOVector Int) (VM.IOVector (Stores s)) s -instance (KnownNat n, Initializable s) => Initializable (Cache n s) where+class (Initializable s, HasMembers s, Store s, SafeRW s ~ Maybe (Stores s)) => Cachable s+instance Cachable (Map s)+instance (KnownNat n, Cachable s) => Cachable (Cache n s)++instance (KnownNat n, Cachable s) => Initializable (Cache n s) where   type InitArgs (Cache n s) = (InitArgs s)   initStoreWith args = do     let n = fromIntegral$ natVal (Proxy @n)@@ -164,7 +231,7 @@     child <- initStoreWith args     return (Cache n tags cache child) -instance HasMembers s => HasMembers (Cache n s) where+instance Cachable s => HasMembers (Cache n s) where   {-# INLINE explDestroy #-}   explDestroy (Cache n tags _ s) ety = do     tag <- UM.unsafeRead tags (ety `mod` n)@@ -199,7 +266,7 @@     as2 <- explImapM s ma     return (as1 ++ as2) -instance (SafeRW s ~ Maybe (Stores s), Store s) => Store (Cache n s) where+instance Cachable s => Store (Cache n s) where   type SafeRW (Cache n s) = SafeRW s   type Stores (Cache n s) = Stores s @@ -265,107 +332,3 @@         r <- liftIO$ VM.read cache e         void$ ma (e, r)     explCimapM_ s ma---- | A component that can be hashed to a table index.---   minBound must hash to the lowest possible value, maxBound must hash to the highest.---   For Enums, toIndex = fromEnum-class Bounded a => ToIndex a where-  toIndex :: a -> Int--- | A query to an IndexTable by an explicit index-newtype ByIndex a     = ByIndex Int--- | A query to an IndexTable by a reference component-newtype ByComponent c = ByComponent c--- | A table that keeps a hashtable of indices along with its writes.--- TODO: Benchmark? hashing function as argument?-data IndexTable s = IndexTable-  { table :: VM.IOVector S.IntSet-  , wrapped :: s-  }--instance (ToIndex (Stores s), Initializable s) => Initializable (IndexTable s) where-  type InitArgs (IndexTable s) = InitArgs s-  initStoreWith args = do-    let lo = toIndex (minBound :: Stores s)-        hi = toIndex (maxBound :: Stores s)-        size = hi - lo + 1-    s <- initStoreWith args-    tab <- VM.replicate size mempty-    return (IndexTable tab s)--instance (SafeRW s ~ Maybe (Stores s), ToIndex (Stores s), Store s) => HasMembers (IndexTable s) where-  {-# INLINE explDestroy #-}-  explDestroy (IndexTable tab s) ety = do-    mc <- explGet s ety-    case mc of-      Just c -> do-        VM.modify tab (S.delete ety) (toIndex c)-        explDestroy s ety-      _ -> return ()--  {-# INLINE explExists #-}-  explExists  (IndexTable _ s) ety = explExists  s ety-  {-# INLINE explMembers #-}-  explMembers (IndexTable _ s) = explMembers s--  {-# INLINE explReset #-}-  explReset (IndexTable tab s) = do-    forM_ [0 .. VM.length tab-1] $ \e -> VM.write tab e mempty-    explReset s--  {-# INLINE explImapM_ #-}-  explImapM_ (IndexTable _ s) = explImapM_ s--  {-# INLINE explImapM #-}-  explImapM (IndexTable _ s) = explImapM s--instance (SafeRW s ~ Maybe (Stores s), ToIndex (Stores s), Store s) => Store (IndexTable s) where-  type SafeRW (IndexTable s) = SafeRW s-  type Stores (IndexTable s) = Stores s-  {-# INLINE explGetUnsafe #-}-  explGetUnsafe (IndexTable _ s) ety = explGetUnsafe s ety-  {-# INLINE explGet #-}-  explGet (IndexTable _ s) ety = explGet s ety-  {-# INLINE explSet #-}-  explSet (IndexTable tab s) ety x = do-    let indexNew = toIndex x-    mc <- explGet s ety-    case mc of-      Nothing -> VM.modify tab (S.insert ety) indexNew-      Just c  -> do let indexOld = toIndex c-                    unless (indexOld == indexNew) $ do-                      VM.modify tab (S.delete ety) indexOld-                      VM.modify tab (S.insert ety) indexNew-    explSet s ety x-  {-# INLINE explSetMaybe #-}-  explSetMaybe s ety Nothing = explDestroy s ety-  explSetMaybe s ety (Just x) = explSet s ety x-  {-# INLINE explModify #-}-  explModify (IndexTable tab s) ety f = do-    mc <- explGet s ety-    case mc of-      Nothing -> return ()-      Just c  -> do let indexOld = toIndex c-                        x = f c-                        indexNew = toIndex c-                    unless (indexOld == indexNew) $ do-                      VM.modify tab (S.delete ety) indexOld-                      VM.modify tab (S.insert ety) indexNew-                    explSet s ety x--  explCmapM_  (IndexTable _ s) = explCmapM_  s-  explCmapM   (IndexTable _ s) = explCmapM   s-  explCimapM_ (IndexTable _ s) = explCimapM_ s-  explCimapM  (IndexTable _ s) = explCimapM  s-  {-# INLINE explCmapM_ #-}-  {-# INLINE explCmapM #-}-  {-# INLINE explCimapM_ #-}-  {-# INLINE explCimapM #-}--instance (Stores s ~ c, ToIndex (Stores s)) => Query (ByComponent c) (IndexTable s) where-  {-# INLINE explSlice #-}-  explSlice (IndexTable tab _) (ByComponent c) = U.fromList . S.elems <$> VM.read tab (toIndex c)--instance (Stores s ~ c, ToIndex (Stores s)) => Query (ByIndex c) (IndexTable s) where-  {-# INLINE explSlice #-}-  explSlice (IndexTable tab _) (ByIndex ix) = U.fromList . S.elems <$> VM.read tab ix-

@@ -63,8 +63,8 @@   liftIO$ explSet s ety x  -- | Same as @set@, but uses Safe to possibly delete a component-setOrDelete :: forall w c. (IsRuntime c, Has w c) => Entity c -> Safe c -> System w ()-setOrDelete (Entity ety) (Safe c) = do+set' :: forall w c. (IsRuntime c, Has w c) => Entity c -> Safe c -> System w ()+set' (Entity ety) (Safe c) = do   s :: Storage c <- getStore   liftIO$ explSetMaybe s ety c @@ -177,14 +177,6 @@                         U.forM_ sl $ \ e -> do                           r <- explGet sr e                           explSetMaybe sw e (getSafe . f . Safe $ r)----- | Performs a query-{-# INLINE slice #-}-slice :: forall w c q. (Query q (Storage c), Has w c) => q -> System w (Slice c)-slice q = do-  s :: Storage c <- getStore-  liftIO$ Slice <$> explSlice s q  -- | Reads a global value {-# INLINE readGlobal #-}

@@ -12,7 +12,7 @@ import qualified Data.Vector.Unboxed as U  -- | 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 {unEntity :: Int} deriving (Eq, Ord, Show)+newtype Entity c = Entity Int deriving (Eq, Ord, Show)  -- | A slice is a list of entities, represented by a Data.Unbox.Vector of Ints. newtype Slice c = Slice {unSlice :: U.Vector Int} deriving (Show, Monoid)@@ -47,7 +47,8 @@   -- | Returns an unboxed vector of member indices   explMembers :: s -> IO (U.Vector Int) -  -- | Removes all components. Default implementation iterates over members and calls explDestroy.+  -- | Removes all components.+  --   Equivalent to calling @explDestroy@ on each member   {-# INLINE explReset #-}   explReset :: s -> IO ()   explReset s = do@@ -83,13 +84,14 @@   explSetMaybe  :: s -> Int -> SafeRW s -> IO ()    -- | Modifies an element in the store.+  --   Equivalent to reading a value, and then writing the result of the function application.   {-# INLINE explModify #-}   explModify :: s -> Int -> (Stores s -> Stores s) -> IO ()   explModify s ety f = do etyExists <- explExists s ety                           when etyExists $ explGetUnsafe s ety >>= explSet s ety . f    -- | Maps over all elements of this store.-  --   The default implementation can be replaced by an optimized one+  --   Equivalent to getting a list of all entities with this component, and then explModifying each of them.   explCmap :: s -> (Stores s -> Stores s) -> IO ()   {-# INLINE explCmap #-}   explCmap s f = explMembers s >>= U.mapM_ (\ety -> explModify s ety f)@@ -138,17 +140,6 @@   explGlobalModify :: s -> (c -> c) -> IO ()   explGlobalModify s f = do r <- explGlobalRead s                             explGlobalWrite s (f r)---- | Classes of queries @q@ that can be performed on a store @s@.-class Query q s where-  -- | Returns a slice of the results of the query-  explSlice :: s -> q -> IO (U.Vector Int)---- | Query that returns all members, equivalent to @members@-data All = All-instance HasMembers s => Query All s where-  {-# INLINE explSlice #-}-  explSlice s _ = explMembers s  -- | Casts for entities and slices class Cast a b where

@@ -4,12 +4,13 @@  module Apecs.Util (   -- * Utility-  initStore, ConcatQueries(..), runGC,+  initStore, runGC, unEntity,    -- * EntityCounter   EntityCounter, initCounter, nextEntity, newEntity,    -- * Spatial hashing+  -- $hash   quantize, flatten, region, inbounds,    -- * Timing@@ -30,6 +31,9 @@ initStore :: (Initializable 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) instance Component EntityCounter where@@ -58,20 +62,15 @@ runGC :: System w () runGC = liftIO performMajorGC --- | Sequentially performs a series of queries and concatenates their result.---   Especially useful when iterating over an IndexTable-newtype ConcatQueries q = ConcatQueries [q]-instance Query q s => Query (ConcatQueries q) s where-  explSlice s (ConcatQueries qs) = mconcat <$> traverse (explSlice s) qs---- | The following functions are for spatial hashing.---   The idea is that your spatial hash is defined by two vectors;---     - The cell size vector contains real components and dictates---       how large each cell in your table is spatially.---       It is used to translate from world-space to table space---     - The field size vector contains integral components and dictates how---       many cells your field consists of in each direction.---       It is used to translate from table-space to a flat integer+-- $hash+-- The following functions are for spatial hashing.+-- The idea is that your spatial hash is defined by two vectors;+--   - The cell size vector contains real components and dictates+--     how large each cell in your table is spatially.+--     It is used to translate from world-space to table space+--   - The field size vector contains integral components and dictates how+--     many cells your field consists of in each direction.+--     It is used to translate from table-space to a flat integer  -- | Quantize turns a world-space coordinate into a table-space coordinate by dividing --   by the given cell size and round components towards negative infinity@@ -103,7 +102,6 @@ inbounds :: (Num (v a), Ord a, Applicative v, Foldable v)          => v a -> v a -> Bool inbounds size vec = and (liftA2 (>=) vec 0) && and (liftA2 (<=) vec size)-   -- | Runs a system and gives its execution time in seconds

@@ -0,0 +1,107 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -w #-}++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++import Apecs+import Apecs.Types+import Apecs.Util+import qualified Apecs.Stores as S+import qualified Apecs.Logs as S++type Vec = (Double, Double)++newtype Position = Position Vec deriving (Arbitrary, Eq, Show)+instance Component Position where+  type Storage Position = S.Logger (S.FromPure Members) (S.Map Position)++newtype CachePos = CachePos Vec deriving (Arbitrary, Eq, Show)+instance Component CachePos where+  type Storage CachePos = S.Map CachePos+++newtype Velocity = Velocity Vec deriving (Arbitrary, Eq, Show)+instance Component Velocity where+  type Storage Velocity = S.Map Velocity+++data Flag = Flag+instance Arbitrary Flag where arbitrary = return Flag+instance S.Flag Flag where flag = Flag+instance Component Flag where+  type Storage Flag = S.Set Flag+++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++newtype RandomEntity a = RandomEntity (Entity a) deriving (Eq, Show)+instance Arbitrary (RandomEntity a) where+  arbitrary = RandomEntity . Entity <$> 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++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+        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))++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+        forM_ cs $ \(RandomEntity ety, pos) -> set ety pos+        set e (v,p)+        Safe r <- get e+        return (r == (Just v, Just p))++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+        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))++main = do+  quickCheck getSetPos+  quickCheck getSetVCPos+  quickCheck cmapVP

@@ -288,5 +288,5 @@ There will be at least one more tutorial, on how to make things fast. We'll be taking a look at   - How to cache your components for O(1) reads and writes-  - How to use an IndexTable to add queries to your component storages-  - How to use those IndexTables to get a free spatial hash of our positions+  - How to use add Logs to your component storages+  - How to use those Logs to get a free spatial hash of our positions