apecs 0.5.0.0 → 0.5.1.0

raw patch · 8 files changed

+208/−257 lines, 8 filesdep −stmPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: stm

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−1
• apecs.cabal +1/−2
• bench/Main.hs +2/−2
• src/Apecs/Core.hs +2/−2
• src/Apecs/Stores.hs +82/−114
• src/Apecs/System.hs +23/−0
• src/Apecs/Util.hs +4/−36
• test/Main.hs +76/−100

@@ -1,8 +1,25 @@-## [Unreleased]+## [0.5.1.0]+### Added+- The `Register` store, which allows reverse lookups for bounded enums.+  For example, if `Bool` has storage `Register (Map Bool)`, `regLookup True` will yield a list of all entities with a `True` component.+  Can also be used to emulate a hash table, where `fromEnum` is the hashing function.+  This allows us to make simple spatial hashes.+  I'm open to suggestions for better names than Register.+- `cmapIf`, cmap with a conditional test ### Changed+- `ExplInit` now too takes a monad argument.+- Started rewrite of the test suite+- Caches now internally use -2 to denote absence, to avoid possible conflict with -1 as a global entity+### Removed+- The STM instances have been removed, to be moved to their own package++## [0.5.0.0]+### Changed - `System w a` is now a synonym for `SystemT w IO a`.   A variable monad argument allows apecs to be run in monads like ST or STM.   Most of the library has been rewritten to be as permissive as possible in its monad argument.+### Added+- STM stores. These will be moved to a separate package soon.  ## [0.4.1.2] ### Changed

@@ -1,5 +1,5 @@ name:                apecs-version:             0.5.0.0+version:             0.5.1.0 homepage:            https://github.com/jonascarpay/apecs#readme license:             BSD3 license-file:        LICENSE@@ -40,7 +40,6 @@     containers,     mtl,     template-haskell,-    stm,     vector   ghc-options:     -Wall

@@ -27,8 +27,8 @@  posVelInit :: System PosVel () posVelInit = do-  mapM_ (`set` ECSPos 0) [0..9999]-  mapM_ (`set` ECSVel 1) [0..999]+  replicateM_ 1000 $ newEntity (ECSPos 0, ECSVel 1)+  replicateM_ 9000 $ newEntity (ECSPos 0)  posVelStep :: System PosVel () posVelStep = cmap $ \(ECSVel v, ECSPos p) -> ECSPos (p+v)

@@ -48,9 +48,9 @@  -- | Indicates that the store @s@ can be initialized. --   Generally, \"base\" stores like @Map c@ can be initialized, but composite stores like @MaybeStore s@ cannot.-class ExplInit s where+class ExplInit m s where   -- | Initialize a new empty store.-  explInit :: IO s+  explInit :: m s  -- | Stores that we can read using @explGet@ and @explExists@. --   For some entity @e@, @eplGet s e@ is only guaranteed to be safe if @explExists s e@ returns @True@.

@@ -13,14 +13,12 @@   ( Map, Cache, Unique,     Global,     Cachable,-    RawGlobal,+    Register, regLookup   ) where -import           Control.Concurrent.STM      as S-import           Control.Concurrent.STM.TVar as S- import           Control.Monad.Reader import qualified Data.IntMap.Strict          as M+import qualified Data.IntSet                 as S import           Data.IORef import           Data.Maybe                  (fromJust) import           Data.Proxy@@ -32,116 +30,61 @@ import           Apecs.Core  -- | A map based on @Data.IntMap.Strict@. O(log(n)) for most operations.-newtype Map c = Map (TVar (M.IntMap (TVar c)))+newtype Map c = Map (IORef (M.IntMap c))  type instance Elem (Map c) = c-instance ExplInit (Map c) where-  explInit = Map <$> newTVarIO mempty+instance ExplInit IO (Map c) where+  explInit = Map <$> newIORef mempty  instance ExplGet IO (Map c) where-  explExists (Map ref) ety = M.member ety <$> readTVarIO ref+  explExists (Map ref) ety = M.member ety <$> readIORef ref   explGet    (Map ref) ety =-    readTVarIO ref >>= readTVarIO . fromJust . M.lookup ety+    fromJust . M.lookup ety <$> readIORef ref   {-# INLINE explExists #-}   {-# INLINE explGet #-}  instance ExplSet IO (Map c) where   {-# INLINE explSet #-}-  explSet (Map ref) ety x = do-    m <- readTVarIO ref-    case M.lookup ety m of-      Nothing -> do-        rInsert <- newTVarIO x-        atomically . writeTVar ref $ M.insert ety rInsert m-      Just cref -> atomically $ writeTVar cref x+  explSet (Map ref) ety x =+    modifyIORef' ref (M.insert ety x)  instance ExplDestroy IO (Map c) where   {-# INLINE explDestroy #-}   explDestroy (Map ref) ety =-    readTVarIO ref >>= atomically . writeTVar ref . M.delete ety+    readIORef ref >>= writeIORef ref . M.delete ety  instance ExplMembers IO (Map c) where   {-# INLINE explMembers #-}-  explMembers (Map ref) = U.fromList . M.keys <$> readTVarIO ref--instance ExplGet STM (Map c) where-  explExists (Map ref) ety = M.member ety <$> readTVar ref-  explGet    (Map ref) ety =-    readTVar ref >>= readTVar . fromJust . M.lookup ety-  {-# INLINE explExists #-}-  {-# INLINE explGet #-}--instance ExplSet STM (Map c) where-  {-# INLINE explSet #-}-  explSet (Map ref) ety x = do-    m <- readTVar ref-    case M.lookup ety m of-      Nothing -> do-        rInsert <- newTVar x-        writeTVar ref $ M.insert ety rInsert m-      Just cref -> writeTVar cref x--instance ExplDestroy STM (Map c) where-  {-# INLINE explDestroy #-}-  explDestroy (Map ref) ety = do-    m <- readTVar ref-    writeTVar ref $ M.delete ety m--instance ExplMembers STM (Map c) where-  {-# INLINE explMembers #-}-  explMembers (Map ref) = U.fromList . M.keys <$> readTVar ref+  explMembers (Map ref) = U.fromList . M.keys <$> readIORef ref  -- | A Unique contains zero or one component. --   Writing to it overwrites both the previous component and its owner. --   Its main purpose is to be a @Map@ optimized for when only ever one component inhabits it.-newtype Unique c = Unique (TVar (Maybe (Int, c)))+newtype Unique c = Unique (IORef (Maybe (Int, c))) type instance Elem (Unique c) = c-instance ExplInit (Unique c) where-  explInit = Unique <$> newTVarIO Nothing+instance ExplInit IO (Unique c) where+  explInit = Unique <$> newIORef Nothing  instance ExplGet IO (Unique c) where   {-# INLINE explGet #-}-  explGet (Unique ref) _ = flip fmap (readTVarIO ref) $ \case+  explGet (Unique ref) _ = flip fmap (readIORef ref) $ \case     Nothing -> error "Reading empty Unique"     Just (_, c)  -> c   {-# INLINE explExists #-}-  explExists (Unique ref) ety = maybe False ((==ety) . fst) <$> readTVarIO ref+  explExists (Unique ref) ety = maybe False ((==ety) . fst) <$> readIORef ref  instance ExplSet IO (Unique c) where   {-# INLINE explSet #-}-  explSet (Unique ref) ety c = atomically $ writeTVar ref (Just (ety, c))+  explSet (Unique ref) ety c = writeIORef ref (Just (ety, c))  instance ExplDestroy IO (Unique c) where   {-# INLINE explDestroy #-}-  explDestroy (Unique ref) ety = readTVarIO ref >>=-    mapM_ (flip when (atomically $ writeTVar ref Nothing) . (==ety) . fst)+  explDestroy (Unique ref) ety = readIORef ref >>=+    mapM_ (flip when (writeIORef ref Nothing) . (==ety) . fst)  instance ExplMembers IO (Unique c) where   {-# INLINE explMembers #-}-  explMembers (Unique ref) = flip fmap (readTVarIO ref) $ \case-    Nothing -> mempty-    Just (ety, _) -> U.singleton ety--instance ExplGet STM (Unique c) where-  {-# INLINE explGet #-}-  explGet (Unique ref) _ = flip fmap (readTVar ref) $ \case-    Nothing -> error "Reading empty Unique"-    Just (_, c)  -> c-  {-# INLINE explExists #-}-  explExists (Unique ref) ety = maybe False ((==ety) . fst) <$> readTVar ref--instance ExplSet STM (Unique c) where-  {-# INLINE explSet #-}-  explSet (Unique ref) ety c = writeTVar ref (Just (ety, c))--instance ExplDestroy STM (Unique c) where-  {-# INLINE explDestroy #-}-  explDestroy (Unique ref) ety = readTVar ref >>=-    mapM_ (flip when (writeTVar ref Nothing) . (==ety) . fst)--instance ExplMembers STM (Unique c) where-  {-# INLINE explMembers #-}-  explMembers (Unique ref) = flip fmap (readTVar ref) $ \case+  explMembers (Unique ref) = flip fmap (readIORef ref) $ \case     Nothing -> mempty     Just (ety, _) -> U.singleton ety @@ -150,47 +93,21 @@ -- --   When operating on a global, any entity arguments are ignored. --   For example, we can get a global component with @get 0@ or @get 1@ or even @get undefined@.-newtype Global c = Global (TVar c)+newtype Global c = Global (IORef c) type instance Elem (Global c) = c-instance Monoid c => ExplInit (Global c) where+instance Monoid c => ExplInit IO (Global c) where   {-# INLINE explInit #-}-  explInit = Global <$> newTVarIO mempty+  explInit = Global <$> newIORef mempty  instance ExplGet IO (Global c) where   {-# INLINE explGet #-}-  explGet (Global ref) _ = readTVarIO ref+  explGet (Global ref) _ = readIORef ref   {-# INLINE explExists #-}   explExists _ _ = return True  instance ExplSet IO (Global c) where   {-# INLINE explSet #-}-  explSet (Global ref) _ c = atomically $ writeTVar ref c--instance ExplGet STM (Global c) where-  {-# INLINE explGet #-}-  explGet (Global ref) _ = readTVar ref-  {-# INLINE explExists #-}-  explExists _ _ = return True--instance ExplSet STM (Global c) where-  {-# INLINE explSet #-}-  explSet (Global ref) _ c = writeTVar ref c--newtype RawGlobal c = RawGlobal (IORef c)-type instance Elem (RawGlobal c) = c-instance Monoid c => ExplInit (RawGlobal c) where-  {-# INLINE explInit #-}-  explInit = RawGlobal <$> newIORef mempty--instance ExplGet IO (RawGlobal c) where-  {-# INLINE explGet #-}-  explGet (RawGlobal ref) _ = readIORef ref-  {-# INLINE explExists #-}-  explExists _ _ = return True--instance ExplSet IO (RawGlobal c) where-  {-# INLINE explSet #-}-  explSet (RawGlobal ref) _ c = writeIORef ref c+  explSet (Global ref) _ c = writeIORef ref c  -- | An empty type class indicating that the store behaves like a regular map, and can therefore safely be cached. class Cachable s@@ -205,7 +122,7 @@ --   Note that iterating over a cache is linear in cache size, so sparsely populated caches might actually decrease performance. --   In general, the exact size of the cache does not matter as long as it reasonably approximates the number of components present. -----   The cache uses entity (-1) to internally represent missing entities, so be wary when manually manipulating entities.+--   The cache uses entity (-2) to internally represent missing entities, so be wary when manually manipulating entities. data Cache (n :: Nat) s =   Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s @@ -214,11 +131,11 @@  type instance Elem (Cache n s) = Elem s -instance (ExplInit s, KnownNat n, Cachable s) => ExplInit (Cache n s) where+instance (ExplInit IO s, KnownNat n, Cachable s) => ExplInit IO (Cache n s) where   {-# INLINE explInit #-}   explInit = do     let n = fromIntegral$ natVal (Proxy @n)-    tags <- UM.replicate n (-1)+    tags <- UM.replicate n (-2)     cache <- VM.replicate n cacheMiss     child <- explInit     return (Cache n tags cache child)@@ -242,7 +159,7 @@   explSet (Cache n tags cache s) ety x = do     let index = ety `rem` n     tag <- UM.unsafeRead tags index-    when (tag /= (-1) && tag /= ety) $ do+    when (tag /= (-2) && tag /= ety) $ do       cached <- VM.unsafeRead cache index       explSet s tag cached     UM.unsafeWrite tags  index ety@@ -255,13 +172,64 @@     tag <- UM.unsafeRead tags (ety `rem` n)     if tag == ety        then do-         UM.unsafeWrite tags  index (-1)+         UM.unsafeWrite tags  index (-2)          VM.unsafeWrite cache index cacheMiss        else explDestroy s ety  instance ExplMembers IO s => ExplMembers IO (Cache n s) where   {-# INLINE explMembers #-}   explMembers (Cache _ tags _ s) = do-    cached <- U.filter (/= (-1)) <$> U.freeze tags+    cached <- U.filter (/= (-2)) <$> U.freeze tags     stored <- explMembers s     return $! cached U.++ stored++data Register s = Register (VM.IOVector S.IntSet) s+type instance Elem (Register s) = Elem s++instance (Cachable s, ExplInit IO s, Bounded (Elem s), Enum (Elem s)) => ExplInit IO (Register s) where+  explInit = do+    vec <- VM.replicate+             (fromEnum (maxBound :: Elem s) - fromEnum (minBound :: Elem s) + 1)+             mempty+    s <- explInit+    return $ Register vec s++instance ExplGet m s => ExplGet m (Register s) where+  {-# INLINE explGet #-}+  explExists (Register _ s) e = explExists s e+  explGet (Register _ s) e = explGet s e++instance (ExplGet IO s, ExplSet IO s, Bounded (Elem s), Enum (Elem s)) => ExplSet IO (Register s) where+  explSet (Register vec s) ety x = do+    let offset = negate $ fromEnum (minBound :: Elem s)+    ex <- explExists s ety+    when ex $ do+      xOld <- explGet s ety+      VM.modify vec (S.delete ety) (fromEnum xOld - offset)+    VM.modify vec (S.insert ety) (fromEnum x - offset)+    explSet s ety x++instance (ExplGet IO s, ExplDestroy IO s, Bounded (Elem s), Enum (Elem s)) => ExplDestroy IO (Register s) where+  explDestroy (Register vec s) ety = do+    let offset = negate $ fromEnum (minBound :: Elem s)+    ex <- explExists s ety+    when ex $ do+      xOld <- explGet s ety+      VM.modify vec (S.delete ety) (fromEnum xOld - offset)+    explDestroy s ety++instance ExplMembers m s => ExplMembers m (Register s) where+  {-# INLINE explMembers #-}+  explMembers (Register _ s) = explMembers s++regLookup :: forall w s c.+  ( Component c, Bounded c, Enum c+  , Has w IO c+  , Storage c ~ Register s+  , c ~ Elem s+  )+  => c -> System w [Entity]+regLookup c = do+  let offset = negate $ fromEnum (minBound :: Elem s)+  Register vec _ :: Register s <- getStore+  fmap Entity . S.toList <$> lift (VM.read vec (fromEnum c - offset))

@@ -58,6 +58,29 @@       r <- explGet sx e       explSet sy e (f r) +-- | Conditional @cmap@, that first tests whether the argument satisfies some property.+--   The entity needs to have both a cx and cp component.+{-# INLINE cmapIf #-}+cmapIf :: forall w m cp cx cy.+  ( Get w m cx+  , Get w m cp+  , Members w m cx+  , Set w m cy )+  => (cp -> Bool)+  -> (cx -> cy)+  -> SystemT w m ()+cmapIf cond f = do+  sp :: Storage cp <- getStore+  sx :: Storage cx <- getStore+  sy :: Storage cy <- getStore+  lift$ do+    sl <- explMembers (sx,sp)+    U.forM_ sl $ \ e -> do+      p <- explGet sp e+      when (cond p) $ do +        x <- explGet sx e+        explSet sy e (f x)+ -- | Monadically iterates over all entites with a @cx@, and writes their @cy@. {-# INLINE cmapM #-} cmapM :: forall w m cx cy. (Get w m cx, Set w m cy, Members w m cx)

@@ -16,24 +16,13 @@   -- * Spatial hashing   -- $hash   quantize, flatten, inbounds, region, flatten',--  -- * Timing-  timeSystem, timeSystem_,--  -- * Concurrency-  forkSys, atomically, sleep--  ) where--import qualified Control.Concurrent     as C-import qualified Control.Concurrent.STM as C-import           System.CPUTime+) where -import           Control.Applicative    (liftA2)+import           Control.Applicative  (liftA2) import           Control.Monad.Reader import           Data.Monoid import           Data.Semigroup-import           System.Mem             (performMajorGC)+import           System.Mem           (performMajorGC)  import           Apecs.Core import           Apecs.Stores@@ -41,7 +30,7 @@  -- | Convenience entity, for use in places where the entity value does not matter, i.e. a global store. global :: Entity-global = Entity (-2)+global = Entity (-1)  -- | Component used by newEntity to track the number of issued entities. --   Automatically added to any world created with @makeWorld@@@ -120,24 +109,3 @@             => v a -- Field size vector             -> v a -> a flatten' size vec = foldr (\(n,x) acc -> n*acc + x) 0 (liftA2 (,) size vec)---- | Runs a system and gives its execution time in seconds-timeSystem :: System w a -> System w (Double, a)-timeSystem sys = do-  s <- lift getCPUTime-  a <- sys-  t <- lift getCPUTime-  return (fromIntegral (t-s)/1e12, a)---- | Runs a system, discards its output, and gives its execution time in seconds-timeSystem_ :: System w a -> System w Double-timeSystem_ = fmap fst . timeSystem--forkSys :: System w () -> System w C.ThreadId-forkSys sys = ask >>= liftIO . C.forkIO . runSystem sys--atomically :: SystemT w C.STM () -> SystemT w IO ()-atomically sys = ask >>= liftIO . C.atomically . runSystem sys--sleep :: Int -> System w ()-sleep = liftIO . C.threadDelay

@@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -15,71 +16,86 @@ import qualified Data.Vector.Unboxed as U import Data.IORef import Data.List (sort)+import Control.Monad  import Apecs import Apecs.Core import Apecs.Stores import Apecs.Util -{----Need to be rewritten for apecs 0.3!- 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+instance Arbitrary Entity where+  arbitrary = Entity . getNonNegative <$> arbitrary  assertSys :: IO w -> System w Bool -> Property assertSys initW sys = monadicIO $ run (initW >>= runSystem sys) >>= assert -type Inserts a = [a]-type Deletes a = [RandomEntity a]-type Writes a  = [(RandomEntity a, a)]-type Scramble a = (Inserts a, Writes a, Deletes a)+genericSetGet :: forall w c.+  ( ExplGet IO (Storage c)+  , ExplSet IO (Storage c)+  , ExplDestroy IO (Storage c)+  , Has w IO c+  , Eq c+  , Arbitrary c )+  => IO w+  -> c+  -> [(Entity, c)]+  -> [Entity]+  -> [(Entity, c)]+  -> Entity -> c+  -> Property+genericSetGet initSys _ sets1 dels sets2 ety c = do+  assertSys initSys $ do+    -- insert and delete random data+    forM_ sets1 $ uncurry set+    forM_ dels $ flip destroy (Proxy @c)+    forM_ sets2 $ uncurry set+    set ety c+    c' <- get ety+    return (c == c') -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+genericSetSet :: forall w c.+  ( ExplGet IO (Storage c)+  , ExplSet IO (Storage c)+  , ExplDestroy IO (Storage c)+  , Has w IO c+  , Eq c+  , Arbitrary c )+  => IO w+  -> c+  -> [(Entity, c)]+  -> [Entity]+  -> [(Entity, c)]+  -> Entity -> c -> c+  -> Property+genericSetSet initSys _ sets1 dels sets2 ety c1 c2 = do+  assertSys initSys $ do+    -- insert and delete random data+    forM_ sets1 $ uncurry set+    forM_ dels $ flip destroy (Proxy @c)+    forM_ sets2 $ uncurry set+    set ety c1+    set ety c2+    c' <- get ety+    return (c2 == c')  -- 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]+makeWorld "Simple" [''MapInt] -prop_setGet :: Scramble MapInt -> RandomEntity MapInt -> MapInt -> Property-prop_setGet scr (RandomEntity re) rw = assertSys initSetGetMI $ do-  scramble scr-  set re rw-  Safe r :: Safe MapInt <- get re-  return (r == Just rw)+prop_setGetMap = genericSetGet initSimple (undefined :: MapInt)+prop_setSetMap = genericSetSet initSimple (undefined :: MapInt)  -- 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]--prop_setGetCached :: Scramble CacheInt -> RandomEntity CacheInt -> CacheInt -> Property-prop_setGetCached scr (RandomEntity re) rw = assertSys initSetGetCI $ do-  scramble scr-  set re rw-  Safe r :: Safe CacheInt <- get re-  return (r == Just rw)--prop_sliceIsMembersLog :: Scramble CacheInt -> Property-prop_sliceIsMembersLog scr = assertSys initSetGetCI $ do-  scramble scr-  es :: [Entity CacheInt] <- listAllE-  sl :: Slice CacheInt <- owners-  return (S.fromList (unEntity <$> es) == S.fromList (unEntity <$> Sl.toList sl))+makeWorld "Cached" [''CacheInt] +prop_setGetCache = genericSetGet initCached (undefined :: CacheInt)+prop_setSetCache = genericSetSet initCached (undefined :: CacheInt)  -- Tests basic tuple functionality newtype T1 = T1 Int deriving (Eq, Show, Arbitrary)@@ -91,71 +107,31 @@  makeWorld "Tuples" [''T1, ''T2, ''T3] -prop_setGetTuple :: (T1, T2, T3) -> Inserts (T1, T2, T3) -> Property-prop_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)--prop_flipTuple :: Scramble T1 -> Scramble T2 -> Scramble T3 -> Scramble (T1,T2,T3) -> Property-prop_flipTuple s1 s2 s3 s = assertSys initTuples $ do-  scramble s1; scramble s2; scramble s3; scramble s-  s1 :: Slice (T1,T2) <- owners-  s2 :: Slice (T2,T1) <- owners-  let sorted = sort . fmap unEntity . Sl.toList-  return$ sorted s1 == sorted s2--prop_membership :: Int -> Scramble T1 -> Scramble T2 -> Scramble T3 -> Scramble (T1,T2,T3) -> Property-prop_membership ety s1 s2 s3 s = assertSys initTuples $ do-  scramble s1; scramble s2; scramble s3; scramble s-  let e1   = (Entity ety :: Entity T1)-      e123 = (Entity ety :: Entity (T1, T2, T3))-  sl1 <- owners-  ex1 <- exists e1-  sl123 <- owners-  ex123 <- exists e123-  return$ Sl.elem e1 sl1 == ex1 && Sl.elem e123 sl123 == ex123---- 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--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)--makeWorld "LoggerProp" [''Logged]+prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3))+prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3)) -prop_logger :: Scramble Logged -> Property-prop_logger 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))+newtype TestBool = TestBool Bool deriving (Eq, Show, Bounded, Enum, Arbitrary)+instance Component TestBool where type Storage TestBool = Register (Map TestBool) +makeWorld "Registered" [''TestBool] -newtype G = G Bool deriving (Eq, Show)-instance Monoid G where-  mempty = G False-  mappend (G x) (G y) = G (x || y)-instance Component G where-  type Storage G = Global G+prop_setGetRegister = genericSetGet initRegistered (undefined :: TestBool)+prop_setSetRegister = genericSetSet initRegistered (undefined :: TestBool)+prop_lookupValid :: [(Entity, TestBool)] -> [Entity] -> Property+prop_lookupValid writes deletes = assertSys initRegistered $ do+  forM_ writes  $ uncurry set+  forM_ deletes $ flip destroy (Proxy @TestBool) -makeWorld "GProp" [''G]+  et <- fmap snd . filter ((== TestBool True ) . fst) <$> getAll+  ef <- fmap snd . filter ((== TestBool False) . fst) <$> getAll -prop_global = assertSys initGProp $ do-  modifyGlobal $ \(G x) -> G (not x)-  G x <- getGlobal-  return $ x == True+  rt <- regLookup (TestBool True)+  rf <- regLookup (TestBool False) +  return (  sort rt == sort et+         && sort rf == sort ef+         && all (`notElem` ef) et+         )  return [] main = $quickCheckAll---}-main = return ()