apecs 0.7.3 → 0.8.0

raw patch · 13 files changed

+520/−399 lines, 13 filesdep +arraydep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: array

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−0
• README.md +6/−6
• apecs.cabal +9/−6
• src/Apecs/Components.hs +2/−17
• src/Apecs/Experimental/Components.hs +54/−0
• src/Apecs/Experimental/Reactive.hs +180/−0
• src/Apecs/Experimental/Stores.hs +121/−0
• src/Apecs/Experimental/Util.hs +63/−0
• src/Apecs/Reactive.hs +0/−131
• src/Apecs/Stores.hs +44/−5
• src/Apecs/Stores/Extra.hs +0/−159
• src/Apecs/Util.hs +2/−57
• test/Main.hs +17/−18

@@ -1,3 +1,25 @@+## [0.8.0]+There are a number of unsolved problems in apecs' design space.+Most notably, it needs a good way to do streaming and reactivity, or find a way to integrate with existing solutions.+I'm hesitant to accept some of the feature requests I've gotten because they would be obsoleted when we figure this out, and I don't want to pollute the API with unstable features.++However, I don't think we should let perfect get in the way of good.+So, apecs 0.8 have new `Apecs.Experimental.*` modules, that I want to use for features that might or might not get removed or changed.+They should provide some conveniences, but the catch is that their API might undergo significant changes between point releases (and therefore within LTS'es).+Some of the existing modules were already marked experimental, and those have been moved.++### Added+- Experimental `Head` component+- `OrdMap` and `IxMap` reactive maps++### Changed+- Moved `ReadOnly` to `Apecs.Stores` since `EntityCounter` now depends on it+- Moved spatial hashing to `Experimental.Util`+- Moved `Redirect` and `Stores.Extra` to `Experimental.Stores`+- Moved `Reactive` to `Experimental.Reactive`+- `rget` has been replaced by `withReactive`+- Improved error messages for unsafe operations+ ## [0.7.3] ### Changed - Added Data.Semigroup to Stores.Extra to build with GHC 8.2.2 in hackage matrix

@@ -6,18 +6,18 @@ * **Fast** - Performance is competitive with Rust ECS libraries (see benchmark results below). * **Concise** - Game logic is expressed using a small number of powerful combinators. * **Safe** - The `cmap`/`cfold`-DSL completely hides the dangers of the low-level API.-* **Extensible** - At its heart apecs is just a data manipulation DSL that can be implemented with any number of backends. as a monad transformer it easily integrates into larger applications.+* **Extensible** - At its heart apecs is just a data manipulation DSL that can be implemented with any number of backends. As a monad transformer it easily integrates into larger applications. * **Cool**  ![Benchmarks](apecs/bench/chart.png)  #### Links - [documentation on hackage](https://hackage.haskell.org/package/apecs/docs/Apecs.html)-- [tutorial](examples/Shmup.md) and other [examples](examples/)-- [paper (prepublication)](apecs/prepub.pdf) (see [#19](https://github.com/jonascarpay/apecs/issues/19))-- [apecs-physics](apecs-physics/) - 2D physics using the [Chipmunk2D](https://github.com/slembcke/Chipmunk2D) engine-- [apecs-gloss](apecs-gloss/) - Simple frontend for [gloss](http://hackage.haskell.org/package/gloss)-based rendering-- [apecs-stm](apecs-stm/) - STM-based stores for easy concurrency+- [tutorial](../examples/Shmup.md) and other [examples](../examples/)+- [paper (prepublication)](../apecs/prepub.pdf) (see [#19](https://github.com/jonascarpay/apecs/issues/19))+- [apecs-physics](../apecs-physics/) - 2D physics using the [Chipmunk2D](https://github.com/slembcke/Chipmunk2D) engine+- [apecs-gloss](../apecs-gloss/) - Simple frontend for [gloss](http://hackage.haskell.org/package/gloss)-based rendering+- [apecs-stm](../apecs-stm/) - STM-based stores for easy concurrency  ##### By other authors - [An Introduction to Developing Games in Haskell with Apecs](https://blog.aas.sh/posts/2018-09-10-Making-A-Game-With-Haskell-And-Apecs/) by Ashley Smith

@@ -1,5 +1,5 @@ name:                apecs-version:             0.7.3+version:             0.8.0 homepage:            https://github.com/jonascarpay/apecs#readme license:             BSD3 license-file:        LICENSE@@ -10,8 +10,7 @@ cabal-version:       >=1.10 synopsis:            Fast Entity-Component-System library for game programming description:-  The Entity-Component-System architecture provides an imperative game programming paradigm that tackles many of the shortcomings of more OO-oriented approaches.-  apecs is a type-driven ECS library, that leverages strong typing for an expressive DSL that compiles into fast game code.+  apecs is a fast, type-driven Entity-Component-System library for game programming.  extra-source-files:   README.md,@@ -29,17 +28,21 @@     Apecs.Core,     Apecs.Components,     Apecs.Stores,-    Apecs.Stores.Extra,-    Apecs.Reactive,     Apecs.System,     Apecs.TH,-    Apecs.Util+    Apecs.Util,++    Apecs.Experimental.Components,+    Apecs.Experimental.Reactive,+    Apecs.Experimental.Stores,+    Apecs.Experimental.Util   other-modules:     Apecs.THTuples   default-language:     Haskell2010   build-depends:     base             >= 4.9  && < 5,+    array            >= 0.4  && < 0.6,     containers       >= 0.5  && < 0.8,     mtl              >= 2.2  && < 2.3,     template-haskell >= 2.12 && < 3,

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}@@ -9,8 +11,6 @@ {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeFamilies               #-} -{-# OPTIONS_GHC -Wno-orphans #-}- module Apecs.Components where  import Data.Functor.Identity@@ -201,18 +201,3 @@   explGet _ ety = return $ Entity ety   {-# INLINE explExists #-}   explExists _ _ = return True---- | Pseudocomponent that when written to, actually writes 'c' to its entity argument.---   Used to dereference during a @cmap@.-data Redirect c = Redirect Entity c deriving (Eq, Show)-instance Component c => Component (Redirect c) where-  type Storage (Redirect c) = RedirectStore (Storage c)--newtype RedirectStore s = RedirectStore s-type instance Elem (RedirectStore s) = Redirect (Elem s)--instance Has w m c => Has w m (Redirect c) where-  getStore = RedirectStore <$> getStore--instance (ExplSet m s) => ExplSet m (RedirectStore s) where-  explSet (RedirectStore s) _ (Redirect (Entity ety) c) = explSet s ety c

@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}++{-|+Stability : experimental++This module is experimental, and its API might change between point releases. Use at your own risk.+--}+module Apecs.Experimental.Components+  ( Redirect (..)+  , Head (..)+  ) where++import qualified Data.Vector.Unboxed as U++import Apecs.Core++-- | Pseudocomponent that when written to, actually writes @c@ to its entity argument.+--   Can be used to write to other entities in a 'cmap'.+data Redirect c = Redirect Entity c deriving (Eq, Show)+instance Component c => Component (Redirect c) where+  type Storage (Redirect c) = RedirectStore (Storage c)++newtype RedirectStore s = RedirectStore s+type instance Elem (RedirectStore s) = Redirect (Elem s)++instance Has w m c => Has w m (Redirect c) where+  getStore = RedirectStore <$> getStore++instance (ExplSet m s) => ExplSet m (RedirectStore s) where+  explSet (RedirectStore s) _ (Redirect (Entity ety) c) = explSet s ety c+++-- | Pseudocomponent that can be read like any other component, but will only+--   yield a single member when iterated over. Intended to be used as+--   @cmap $ Head (...) -> ...@+newtype Head c = Head c deriving (Eq, Show)+instance Component c => Component (Head c) where+  type Storage (Head c) = HeadStore (Storage c)++newtype HeadStore s = HeadStore s+type instance Elem (HeadStore s) = Head (Elem s)++instance Has w m c => Has w m (Head c) where+  getStore = HeadStore <$> getStore++instance (ExplGet m s) => ExplGet m (HeadStore s) where+  explExists (HeadStore s) ety = explExists s ety+  explGet (HeadStore s) ety = Head <$> explGet s ety++instance (ExplMembers m s) => ExplMembers m (HeadStore s) where+  explMembers (HeadStore s) = U.take 1 <$> explMembers s

@@ -0,0 +1,180 @@+{-|+Stability : experimental++This module is experimental, and its API might change between point releases. Use at your own risk.++Adds the @Reactive r s@ store, which when wrapped around store @s@, will call the @react@ on its @r@.++@Show c => Reactive (Printer c) (Map c)@ will print a message every time a @c@ value is set.++@Enum c => Reactive (EnumMap c) (Map c)@ allows you to look up entities by component value.+Use e.g. @rget >>= mapLookup True@ to retrieve a list of entities that have a @True@ component.++-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}++module Apecs.Experimental.Reactive+  ( Reacts (..), Reactive, withReactive+  , EnumMap, enumLookup+  , OrdMap, ordLookup+  , IxMap, ixLookup+  ) where++import           Control.Monad.Reader+import qualified Data.Array.IO        as A+import qualified Data.IntMap.Strict   as IM+import qualified Data.IntSet          as S+import           Data.IORef+import           Data.Ix+import qualified Data.Map.Strict      as M++import           Apecs.Components+import           Apecs.Core++-- | Class required by @Reactive@.+--   Given some @r@ and update information about some component, will run a side-effect in monad @m@.+--   Note that there are also instances for @(,)@.+class Monad m => Reacts m r where+  rempty :: m r+  react  :: Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()++-- | Wrapper for reactivity around some store s.+data Reactive r s = Reactive r s++type instance Elem (Reactive r s) = Elem s++-- | Performs an action with a reactive state token.+withReactive :: forall w m r s a.+             ( Component (Elem r)+             , Has w m (Elem r)+             , Storage (Elem r) ~ Reactive r s+             ) => (r -> m a) -> SystemT w m a+withReactive f = do+  Reactive r (_ :: s) <- getStore+  lift$ f r++instance (Reacts m r, ExplInit m s) => ExplInit m (Reactive r s) where+  explInit = liftM2 Reactive rempty explInit++instance (Reacts m r, ExplSet m s, ExplGet m s, Elem s ~ Elem r)+  => ExplSet m (Reactive r s) where+  {-# INLINE explSet #-}+  explSet (Reactive r s) ety c = do+    old <- explGet (MaybeStore s) ety+    react (Entity ety) old (Just c) r+    explSet s ety c++instance (Reacts m r, ExplDestroy m s, ExplGet m s, Elem s ~ Elem r)+  => ExplDestroy m (Reactive r s) where+  {-# INLINE explDestroy #-}+  explDestroy (Reactive r s) ety = do+    old <- explGet (MaybeStore s) ety+    react (Entity ety) old Nothing r+    explDestroy s ety++instance ExplGet m s => ExplGet m (Reactive r s) where+  {-# INLINE explExists #-}+  explExists (Reactive _ s) = explExists s+  {-# INLINE explGet    #-}+  explGet    (Reactive _ s) = explGet    s++instance ExplMembers m s => ExplMembers m (Reactive r s) where+  {-# INLINE explMembers #-}+  explMembers (Reactive _ s) = explMembers s++-- | Prints a message to stdout every time a component is updated.+data Printer c = Printer+type instance Elem (Printer c) = c++instance (MonadIO m, Show c) => Reacts m (Printer c) where+  {-# INLINE rempty #-}+  rempty = return Printer+  {-# INLINE react #-}+  react (Entity ety) (Just c) Nothing _ = liftIO$+    putStrLn $ "Entity " ++ show ety ++ ": destroyed component " ++ show c+  react (Entity ety) Nothing (Just c) _ = liftIO$+    putStrLn $ "Entity " ++ show ety ++ ": created component " ++ show c+  react (Entity ety) (Just old) (Just new) _ = liftIO$+    putStrLn $ "Entity " ++ show ety ++ ": update component " ++ show old ++ " to " ++ show new+  react _ _ _ _ = return ()++-- | Allows you to look up entities by component value.+--   Use e.g. @withReactive $ mapLookup True@ to retrieve a list of entities that have a @True@ component.+--   Based on an @IntMap IntSet@ internally.+newtype EnumMap c = EnumMap (IORef (IM.IntMap S.IntSet))++type instance Elem (EnumMap c) = c+instance (MonadIO m, Enum c) => Reacts m (EnumMap c) where+  {-# INLINE rempty #-}+  rempty = liftIO$ EnumMap <$> newIORef mempty+  {-# INLINE react #-}+  react _ Nothing Nothing _ = return ()+  react (Entity ety) (Just c) Nothing (EnumMap ref) = liftIO$+    modifyIORef' ref (IM.adjust (S.delete ety) (fromEnum c))+  react (Entity ety) Nothing (Just c) (EnumMap ref) = liftIO$+    modifyIORef' ref (IM.insertWith mappend (fromEnum c) (S.singleton ety))+  react (Entity ety) (Just old) (Just new) (EnumMap ref) = liftIO$ do+    modifyIORef' ref (IM.adjust (S.delete ety) (fromEnum old))+    modifyIORef' ref (IM.insertWith mappend (fromEnum new) (S.singleton ety))++{-# INLINE enumLookup #-}+enumLookup :: (MonadIO m, Enum c) => c -> EnumMap c -> m [Entity]+enumLookup c = \(EnumMap ref) -> do+  emap <- liftIO $ readIORef ref+  return $ maybe [] (fmap Entity . S.toList) (IM.lookup (fromEnum c) emap)++-- | Allows you to look up entities by component value.+--   Based on a @Map c IntSet@ internally+newtype OrdMap c = OrdMap (IORef (M.Map c S.IntSet))++type instance Elem (OrdMap c) = c+instance (MonadIO m, Ord c) => Reacts m (OrdMap c) where+  {-# INLINE rempty #-}+  rempty = liftIO$ OrdMap <$> newIORef mempty+  {-# INLINE react #-}+  react _ Nothing Nothing _ = return ()+  react (Entity ety) (Just c) Nothing (OrdMap ref) = liftIO$+    modifyIORef' ref (M.adjust (S.delete ety) c)+  react (Entity ety) Nothing (Just c) (OrdMap ref) = liftIO$+    modifyIORef' ref (M.insertWith mappend c (S.singleton ety))+  react (Entity ety) (Just old) (Just new) (OrdMap ref) = liftIO$ do+    modifyIORef' ref (M.adjust (S.delete ety) old)+    modifyIORef' ref (M.insertWith mappend new (S.singleton ety))++{-# INLINE ordLookup #-}+ordLookup :: (MonadIO m, Ord c) => c -> OrdMap c -> m [Entity]+ordLookup c = \(OrdMap ref) -> do+  emap <- liftIO $ readIORef ref+  return $ maybe [] (fmap Entity . S.toList) (M.lookup c emap)++-- | Allows you to look up entities by component value.+--   Based on an @IOArray c IntSet@ internally+newtype IxMap c = IxMap (A.IOArray c S.IntSet)++{-# INLINE modifyArray #-}+modifyArray :: Ix i => A.IOArray i a -> i -> (a -> a) -> IO ()+modifyArray ref ix f = A.readArray ref ix >>= A.writeArray ref ix . f++type instance Elem (IxMap c) = c+instance (MonadIO m, Ix c, Bounded c) => Reacts m (IxMap c) where+  {-# INLINE rempty #-}+  rempty = liftIO$ IxMap <$> A.newArray (minBound, maxBound) mempty+  {-# INLINE react #-}+  react _ Nothing Nothing _ = return ()+  react (Entity ety) (Just c) Nothing (IxMap ref) = liftIO$+    modifyArray ref c (S.delete ety)+  react (Entity ety) Nothing (Just c) (IxMap ref) = liftIO$+    modifyArray ref c (S.insert ety)+  react (Entity ety) (Just old) (Just new) (IxMap ref) = liftIO$ do+    modifyArray ref old (S.delete ety)+    modifyArray ref new (S.insert ety)++{-# INLINE ixLookup #-}+ixLookup :: (MonadIO m, Ix c) => c -> IxMap c -> m [Entity]+ixLookup c = \(IxMap ref) -> do+  liftIO $ fmap Entity . S.toList <$> A.readArray ref c

@@ -0,0 +1,121 @@+{-|+Stability: experimtal++This module is experimental, and its API might change between point releases. Use at your own risk.+-}++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++module Apecs.Experimental.Stores+  ( Pushdown(..), Stack(..)+  ) where++import Control.Monad.Reader+import Data.Proxy+import Data.Semigroup++import Apecs.Components (MaybeStore (..))+import Apecs.Core++-- | Overrides a store to have history/pushdown semantics.+--   Setting this store adds a new value on top of the stack.+--   Destroying pops the stack.+--   You can view the entire stack using the 'Stack' wrapper.+newtype Pushdown s c = Pushdown (s (Stack c))+newtype Stack c = Stack {getStack :: [c]} deriving (Eq, Show, Functor, Applicative, Monad, Foldable, Monoid, Semigroup)++type instance Elem (Pushdown s c) = c++instance (Functor m, ExplInit m (s (Stack c))) => ExplInit m (Pushdown s c) where+  explInit = Pushdown <$> explInit++pattern StackList :: c -> [c] -> Maybe (Stack c)+pattern StackList x xs = Just (Stack (x:xs))++instance+  ( Monad m+  , ExplGet m (s (Stack c))+  , Elem (s (Stack c)) ~ Stack c+  ) => ExplGet m (Pushdown s c) where+    explExists (Pushdown s) ety = f <$> explGet (MaybeStore s) ety+      where+        f (StackList _ _) = True+        f _               = False+    explGet (Pushdown s) ety = head . getStack <$> explGet s ety++instance+  ( Monad m+  , ExplGet m (s (Stack c))+  , ExplSet m (s (Stack c))+  , Elem (s (Stack c)) ~ Stack c+  ) => ExplSet m (Pushdown s c) where+    explSet (Pushdown s) ety c = do+      ms <- explGet (MaybeStore s) ety+      let tail (StackList _ cs) = cs+          tail _                = []+      explSet s ety (Stack (c:tail ms))++instance+  ( Monad m+  , ExplGet m (s (Stack c))+  , ExplSet m (s (Stack c))+  , ExplDestroy m (s (Stack c))+  , Elem (s (Stack c)) ~ Stack c+  ) => ExplDestroy m (Pushdown s c) where+    explDestroy (Pushdown s) ety = do+      mscs <- explGet (MaybeStore s) ety+      case mscs of+        StackList _ cs' -> explSet s ety (Stack cs')+        _               -> explDestroy s ety++instance+  ( Monad m+  , ExplMembers m (s (Stack c))+  , Elem (s (Stack c)) ~ Stack c+  ) => ExplMembers m (Pushdown s c) where+    explMembers (Pushdown s) = explMembers s++instance (Storage c ~ Pushdown s c, Component c) => Component (Stack c) where+  type Storage (Stack c) = StackStore (Storage c)++newtype StackStore s = StackStore s+type instance Elem (StackStore s) = Stack (Elem s)++instance (Storage c ~ Pushdown s c, Has w m c) => Has w m (Stack c) where+  getStore = StackStore <$> getStore++instance+  ( Elem (s (Stack c)) ~ Stack c+  , ExplGet m (s (Stack c))+  ) => ExplGet m (StackStore (Pushdown s c)) where+  explExists (StackStore s) = explExists s+  explGet (StackStore (Pushdown s)) = explGet s++instance+  ( Elem (s (Stack c)) ~ Stack c+  , ExplSet     m (s (Stack c))+  , ExplDestroy m (s (Stack c))+  ) => ExplSet m (StackStore (Pushdown s c)) where+  explSet (StackStore (Pushdown s)) ety (Stack []) = explDestroy s ety+  explSet (StackStore (Pushdown s)) ety st         = explSet s ety st++instance+  ( Elem (s (Stack c)) ~ Stack c+  , ExplDestroy m (s (Stack c))+  ) => ExplDestroy m (StackStore (Pushdown s c)) where+  explDestroy (StackStore (Pushdown s)) = explDestroy s++instance+  ( Elem (s (Stack c)) ~ Stack c+  , ExplMembers m (s (Stack c))+  ) => ExplMembers m (StackStore (Pushdown s c)) where+  explMembers (StackStore (Pushdown s)) = explMembers s

@@ -0,0 +1,63 @@+{-|+Stability : experimental++This module is experimental, and its API might change between point releases. Use at your own risk.+--}+module Apecs.Experimental.Util+  ( -- * Spatial hashing+    -- $hash+  quantize, flatten, inbounds, region, flatten',+  ) where++import Control.Applicative  (liftA2)++-- $hash+-- The following are helper functions for spatial hashing.+-- 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 in world space units.+--     It is used by @quantize@ to translate a world space coordinate into a table space index vector+--   - The table size vector contains integral components and dictates how+--     many cells your field consists of in each direction.+--     It is used by @flatten@ to translate a table-space index vector into a flat integer++-- | Quantize turns a world-space coordinate into a table-space coordinate by dividing+--   by the given cell size and rounding towards negative infinity.+{-# INLINE quantize #-}+quantize :: (Fractional (v a), Integral b, RealFrac a, Functor v)+         => v a -- ^ Quantization cell size+         -> v a -- ^ Vector to be quantized+         -> v b+quantize cell vec = floor <$> vec/cell++-- | Turns a table-space vector into an integral index, given some table size vector.+--   Yields Nothing for out-of-bounds queries+{-# INLINE flatten #-}+flatten :: (Applicative v, Integral a, Foldable v)+        => v a -- Field size vector+        -> v a -> Maybe a+flatten size vec = if inbounds size vec then Just (flatten' size vec) else Nothing++-- | Tests whether a vector is in the region given by 0 and the size vector (inclusive)+{-# INLINE inbounds #-}+inbounds :: (Num a, Ord a, Applicative v, Foldable v)+         => v a -- Field size vector+         -> v a -> Bool+inbounds size vec = and (liftA2 (\v s -> v >= 0 && v <= s) vec size)++-- | For two table-space vectors indicating a region's bounds, gives a list of the vectors contained between them.+--   This is useful for querying a spatial hash.+{-# INLINE region #-}+region :: (Enum a, Applicative v, Traversable v)+       => v a -- ^ Lower bound for the region+       -> v a -- ^ Higher bound for the region+       -> [v a]+region a b = sequence $ liftA2 enumFromTo a b++-- | flatten, but yields garbage for out-of-bounds vectors.+{-# INLINE flatten' #-}+flatten' :: (Applicative v, Integral a, Foldable v)+            => v a -- Field size vector+            -> v a -> a+flatten' size vec = foldr (\(n,x) acc -> n*acc + x) 0 (liftA2 (,) size vec)

@@ -1,131 +0,0 @@-{-|-Stability : experimental--Reactive stores module, still experimental.-Adds the @Reactive r s@ store, which when wrapped around store @s@, will call the @react@ on its @r@.--@Show c => Reactive (Printer c) (Map c)@ will print a message every time a @c@ value is set.--@Enum c => Reactive (EnumMap c) (Map c)@ allows you to look up entities by component value.-Use e.g. @rget >>= mapLookup True@ to retrieve a list of entities that have a @True@ component.---}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}--module Apecs.Reactive where--import           Control.Monad.Reader-import qualified Data.IntMap.Strict   as M-import qualified Data.IntSet          as S-import           Data.IORef--import           Apecs.Core-import           Apecs.Components---- | Analogous to @Elem@, but for @Reacts@ instances.---   For a @Reactive r s@ to be valid, @ReactElem r = Elem s@-type family ReactElem r---- | Class required by @Reactive@.---   Given some @r@ and update information about some component, will run a side-effect in monad @m@.---   Note that there are also instances for @(,)@.-class Monad m => Reacts m r where-  rempty :: m r-  react  :: Entity -> Maybe (ReactElem r) -> Maybe (ReactElem r) -> r -> m ()--type instance ReactElem (a,b) = ReactElem a-instance (ReactElem a ~ ReactElem b, Reacts m a, Reacts m b) => Reacts m (a, b) where-  {-# INLINE rempty #-}-  rempty = liftM2 (,) rempty rempty-  {-# INLINE react #-}-  react ety old new (a,b) = react ety old new a >> react ety old new b---- | Wrapper for reactivity around some store s.-data Reactive r s = Reactive r s--type instance Elem (Reactive r s) = Elem s---- | Reads @r@ from the game world.-rget :: forall w m r s.-  ( Component (ReactElem r)-  , Has w m (ReactElem r)-  , Storage (ReactElem r) ~ Reactive r s-  ) => SystemT w m r-rget = do-  Reactive r (_ :: s) <- getStore-  return r--instance (Reacts m r, ExplInit m s) => ExplInit m (Reactive r s) where-  explInit = liftM2 Reactive rempty explInit--instance (Reacts m r, ExplSet m s, ExplGet m s, Elem s ~ ReactElem r)-  => ExplSet m (Reactive r s) where-  {-# INLINE explSet #-}-  explSet (Reactive r s) ety c = do-    old <- explGet (MaybeStore s) ety-    react (Entity ety) old (Just c) r-    explSet s ety c--instance (Reacts m r, ExplDestroy m s, ExplGet m s, Elem s ~ ReactElem r)-  => ExplDestroy m (Reactive r s) where-  {-# INLINE explDestroy #-}-  explDestroy (Reactive r s) ety = do-    old <- explGet (MaybeStore s) ety-    react (Entity ety) old Nothing r-    explDestroy s ety--instance ExplGet m s => ExplGet m (Reactive r s) where-  {-# INLINE explExists #-}-  explExists (Reactive _ s) = explExists s-  {-# INLINE explGet    #-}-  explGet    (Reactive _ s) = explGet    s--instance ExplMembers m s => ExplMembers m (Reactive r s) where-  {-# INLINE explMembers #-}-  explMembers (Reactive _ s) = explMembers s---- | Prints a message to stdout every time a component is updated.-data Printer c = Printer-type instance ReactElem (Printer c) = c--instance (MonadIO m, Show c) => Reacts m (Printer c) where-  {-# INLINE rempty #-}-  rempty = return Printer-  {-# INLINE react #-}-  react (Entity ety) (Just c) Nothing _ = liftIO$-    putStrLn $ "Entity " ++ show ety ++ ": destroyed component " ++ show c-  react (Entity ety) Nothing (Just c) _ = liftIO$-    putStrLn $ "Entity " ++ show ety ++ ": created component " ++ show c-  react (Entity ety) (Just old) (Just new) _ = liftIO$-    putStrLn $ "Entity " ++ show ety ++ ": update component " ++ show old ++ " to " ++ show new-  react _ _ _ _ = return ()---- | Allows you to look up entities by component value.---   Use e.g. @rget >>= mapLookup True@ to retrieve a list of entities that have a @True@ component.-newtype EnumMap c = EnumMap (IORef (M.IntMap S.IntSet))--type instance ReactElem (EnumMap c) = c-instance (MonadIO m, Enum c) => Reacts m (EnumMap c) where-  {-# INLINE rempty #-}-  rempty = liftIO$ EnumMap <$> newIORef mempty-  {-# INLINE react #-}-  react _ Nothing Nothing _ = return ()-  react (Entity ety) (Just c) Nothing (EnumMap ref) = liftIO$-    modifyIORef' ref (M.adjust (S.delete ety) (fromEnum c))-  react (Entity ety) Nothing (Just c) (EnumMap ref) = liftIO$-    modifyIORef' ref (M.insertWith mappend (fromEnum c) (S.singleton ety))-  react (Entity ety) (Just old) (Just new) (EnumMap ref) = liftIO$ do-    modifyIORef' ref (M.adjust (S.delete ety) (fromEnum old))-    modifyIORef' ref (M.insertWith mappend (fromEnum new) (S.singleton ety))---{-# INLINE mapLookup #-}-mapLookup :: Enum c => EnumMap c -> c -> System w [Entity]-mapLookup (EnumMap ref) c = do-  emap <- liftIO $ readIORef ref-  return $ maybe [] (fmap Entity . S.toList) (M.lookup (fromEnum c) emap)

@@ -13,13 +13,13 @@   ( Map, Cache, Unique,     Global,     Cachable,+    ReadOnly, setReadOnly, destroyReadOnly     -- Register, regLookup   ) where  import           Control.Monad.Reader import qualified Data.IntMap.Strict          as M import           Data.IORef-import           Data.Maybe                  (fromJust) import           Data.Proxy import qualified Data.Vector.Mutable         as VM import qualified Data.Vector.Unboxed         as U@@ -37,8 +37,9 @@  instance MonadIO m => ExplGet m (Map c) where   explExists (Map ref) ety = liftIO$ M.member ety <$> readIORef ref-  explGet    (Map ref) ety = liftIO$-    fromJust . M.lookup ety <$> readIORef ref+  explGet    (Map ref) ety = liftIO$ flip fmap (M.lookup ety <$> readIORef ref) $ \case+    Just c -> c+    Nothing -> error $ "Reading non-existant Map component for entity " <> show ety   {-# INLINE explExists #-}   {-# INLINE explGet #-} @@ -67,8 +68,8 @@ instance MonadIO m => ExplGet m (Unique c) where   {-# INLINE explGet #-}   explGet (Unique ref) _ = liftIO$ flip fmap (readIORef ref) $ \case-    Nothing -> error "Reading empty Unique"     Just (_, c)  -> c+    Nothing -> error $ "Reading non-existant Unique component"   {-# INLINE explExists #-}   explExists (Unique ref) ety = liftIO$ maybe False ((==ety) . fst) <$> readIORef ref @@ -129,7 +130,7 @@   Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s  cacheMiss :: t-cacheMiss = error "Cache miss!"+cacheMiss = error "Cache miss! If you are seeing this during normal operation, please open a bug report at https://github.com/jonascarpay/apecs"  type instance Elem (Cache n s) = Elem s @@ -184,3 +185,41 @@     cached <- liftIO$ U.filter (/= (-2)) <$> U.freeze tags     stored <- explMembers s     return $! cached U.++ stored++-- | Wrapper that makes a store read-only by hiding its 'ExplSet' and 'ExplDestroy'. Use 'setReadOnly' and 'destroyReadOnly' to override.+-- This is used to protect the 'EntityCounter'.+newtype ReadOnly s = ReadOnly s+type instance Elem (ReadOnly s) = Elem s++instance (Functor m, ExplInit m s) => ExplInit m (ReadOnly s) where+  explInit = ReadOnly <$> explInit++instance ExplGet m s => ExplGet m (ReadOnly s) where+  explExists (ReadOnly s) = explExists s+  explGet    (ReadOnly s) = explGet s+  {-# INLINE explExists #-}+  {-# INLINE explGet #-}++instance ExplMembers m s => ExplMembers m (ReadOnly s) where+  {-# INLINE explMembers #-}+  explMembers (ReadOnly s) = explMembers s++setReadOnly :: forall w m s c.+  ( Has w m c+  , Storage c ~ ReadOnly s+  , Elem s ~ c+  , ExplSet m s+  ) => Entity -> c -> SystemT w m ()+setReadOnly (Entity ety) c = do+  ReadOnly s <- getStore+  lift $ explSet s ety c++destroyReadOnly :: forall w m s c.+  ( Has w m c+  , Storage c ~ ReadOnly s+  , Elem s ~ c+  , ExplDestroy m s+  ) => Entity -> Proxy c -> SystemT w m ()+destroyReadOnly (Entity ety) _ = do+  ReadOnly s :: Storage c <- getStore+  lift $ explDestroy s ety

@@ -1,159 +0,0 @@-{-|-Stability: experimtal--Containment module for stores that are experimental/too weird for @Apecs.Stores@.--}--{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE PatternSynonyms            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}--module Apecs.Stores.Extra-  ( Pushdown(..), Stack(..)-  , ReadOnly(..), setReadOnly, destroyReadOnly-  ) where--import Control.Monad.Reader-import Data.Proxy-import Data.Semigroup--import Apecs.Components (MaybeStore (..))-import Apecs.Core---- | Overrides a store to have history/pushdown semantics.---   Setting this store adds a new value on top of the stack.---   Destroying pops the stack.---   You can view the entire stack using the 'Stack' wrapper.-newtype Pushdown s c = Pushdown (s (Stack c))-newtype Stack c = Stack {getStack :: [c]} deriving (Eq, Show, Functor, Applicative, Monad, Foldable, Monoid, Semigroup)--type instance Elem (Pushdown s c) = c--instance (Functor m, ExplInit m (s (Stack c))) => ExplInit m (Pushdown s c) where-  explInit = Pushdown <$> explInit--pattern StackList :: c -> [c] -> Maybe (Stack c)-pattern StackList x xs = Just (Stack (x:xs))--instance-  ( Monad m-  , ExplGet m (s (Stack c))-  , Elem (s (Stack c)) ~ Stack c-  ) => ExplGet m (Pushdown s c) where-    explExists (Pushdown s) ety = f <$> explGet (MaybeStore s) ety-      where-        f (StackList _ _) = True-        f _               = False-    explGet (Pushdown s) ety = head . getStack <$> explGet s ety--instance-  ( Monad m-  , ExplGet m (s (Stack c))-  , ExplSet m (s (Stack c))-  , Elem (s (Stack c)) ~ Stack c-  ) => ExplSet m (Pushdown s c) where-    explSet (Pushdown s) ety c = do-      ms <- explGet (MaybeStore s) ety-      let tail (StackList _ cs) = cs-          tail _                = []-      explSet s ety (Stack (c:tail ms))--instance-  ( Monad m-  , ExplGet m (s (Stack c))-  , ExplSet m (s (Stack c))-  , ExplDestroy m (s (Stack c))-  , Elem (s (Stack c)) ~ Stack c-  ) => ExplDestroy m (Pushdown s c) where-    explDestroy (Pushdown s) ety = do-      mscs <- explGet (MaybeStore s) ety-      case mscs of-        StackList _ cs' -> explSet s ety (Stack cs')-        _               -> explDestroy s ety--instance-  ( Monad m-  , ExplMembers m (s (Stack c))-  , Elem (s (Stack c)) ~ Stack c-  ) => ExplMembers m (Pushdown s c) where-    explMembers (Pushdown s) = explMembers s--instance (Storage c ~ Pushdown s c, Component c) => Component (Stack c) where-  type Storage (Stack c) = StackStore (Storage c)--newtype StackStore s = StackStore s-type instance Elem (StackStore s) = Stack (Elem s)--instance (Storage c ~ Pushdown s c, Has w m c) => Has w m (Stack c) where-  getStore = StackStore <$> getStore--instance-  ( Elem (s (Stack c)) ~ Stack c-  , ExplGet m (s (Stack c))-  ) => ExplGet m (StackStore (Pushdown s c)) where-  explExists (StackStore s) = explExists s-  explGet (StackStore (Pushdown s)) = explGet s--instance-  ( Elem (s (Stack c)) ~ Stack c-  , ExplSet     m (s (Stack c))-  , ExplDestroy m (s (Stack c))-  ) => ExplSet m (StackStore (Pushdown s c)) where-  explSet (StackStore (Pushdown s)) ety (Stack []) = explDestroy s ety-  explSet (StackStore (Pushdown s)) ety st         = explSet s ety st--instance-  ( Elem (s (Stack c)) ~ Stack c-  , ExplDestroy m (s (Stack c))-  ) => ExplDestroy m (StackStore (Pushdown s c)) where-  explDestroy (StackStore (Pushdown s)) = explDestroy s--instance-  ( Elem (s (Stack c)) ~ Stack c-  , ExplMembers m (s (Stack c))-  ) => ExplMembers m (StackStore (Pushdown s c)) where-  explMembers (StackStore (Pushdown s)) = explMembers s---- | Wrapper that makes a store read-only. Use @setReadOnly@ and @destroyReadOnly@ to override.-newtype ReadOnly s = ReadOnly s-type instance Elem (ReadOnly s) = Elem s--instance (Functor m, ExplInit m s) => ExplInit m (ReadOnly s) where-  explInit = ReadOnly <$> explInit--instance ExplGet m s => ExplGet m (ReadOnly s) where-  explExists (ReadOnly s) = explExists s-  explGet    (ReadOnly s) = explGet s-  {-# INLINE explExists #-}-  {-# INLINE explGet #-}--instance ExplMembers m s => ExplMembers m (ReadOnly s) where-  {-# INLINE explMembers #-}-  explMembers (ReadOnly s) = explMembers s--setReadOnly :: forall w m s c.-  ( Has w m c-  , Storage c ~ ReadOnly s-  , Elem s ~ c-  , ExplSet m s-  ) => Entity -> c -> SystemT w m ()-setReadOnly (Entity ety) c = do-  ReadOnly s <- getStore-  lift $ explSet s ety c--destroyReadOnly :: forall w m s c.-  ( Has w m c-  , Storage c ~ ReadOnly s-  , Elem s ~ c-  , ExplDestroy m s-  ) => Entity -> Proxy c -> SystemT w m ()-destroyReadOnly (Entity ety) _ = do-  ReadOnly s :: Storage c <- getStore-  lift $ explDestroy s ety

@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- For Data.Semigroup compatibility+ {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -13,10 +14,6 @@    -- * EntityCounter   EntityCounter(..), nextEntity, newEntity,--  -- * Spatial hashing-  -- $hash-  quantize, flatten, inbounds, region, flatten', ) where  import Control.Applicative  (liftA2)@@ -27,7 +24,6 @@  import Apecs.Core import Apecs.Stores-import Apecs.Stores.Extra import Apecs.System  -- | Convenience entity, for use in places where the entity value does not matter, i.e. a global store.@@ -60,54 +56,3 @@ -- | Explicitly invoke the garbage collector runGC :: System w () runGC = lift performMajorGC---- $hash--- The following are helper functions for spatial hashing.--- 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 in world space units.---     It is used by @quantize@ to translate a world space coordinate into a table space index vector---   - The table size vector contains integral components and dictates how---     many cells your field consists of in each direction.---     It is used by @flatten@ to translate a table-space index vector into a flat integer---- | Quantize turns a world-space coordinate into a table-space coordinate by dividing---   by the given cell size and rounding towards negative infinity.-{-# INLINE quantize #-}-quantize :: (Fractional (v a), Integral b, RealFrac a, Functor v)-         => v a -- ^ Quantization cell size-         -> v a -- ^ Vector to be quantized-         -> v b-quantize cell vec = floor <$> vec/cell---- | Turns a table-space vector into an integral index, given some table size vector.---   Yields Nothing for out-of-bounds queries-{-# INLINE flatten #-}-flatten :: (Applicative v, Integral a, Foldable v)-        => v a -- Field size vector-        -> v a -> Maybe a-flatten size vec = if inbounds size vec then Just (flatten' size vec) else Nothing---- | Tests whether a vector is in the region given by 0 and the size vector (inclusive)-{-# INLINE inbounds #-}-inbounds :: (Num a, Ord a, Applicative v, Foldable v)-         => v a -- Field size vector-         -> v a -> Bool-inbounds size vec = and (liftA2 (\v s -> v >= 0 && v <= s) vec size)---- | For two table-space vectors indicating a region's bounds, gives a list of the vectors contained between them.---   This is useful for querying a spatial hash.-{-# INLINE region #-}-region :: (Enum a, Applicative v, Traversable v)-       => v a -- ^ Lower bound for the region-       -> v a -- ^ Higher bound for the region-       -> [v a]-region a b = sequence $ liftA2 enumFromTo a b---- | flatten, but yields garbage for out-of-bounds vectors.-{-# INLINE flatten' #-}-flatten' :: (Applicative v, Integral a, Foldable v)-            => v a -- Field size vector-            -> v a -> a-flatten' size vec = foldr (\(n,x) acc -> n*acc + x) 0 (liftA2 (,) size vec)

@@ -12,18 +12,18 @@ {-# OPTIONS_GHC -w #-}  import           Control.Monad-import qualified Data.IntSet             as S+import qualified Data.IntSet                 as S import           Data.IORef-import           Data.List               (sort)-import qualified Data.Vector.Unboxed     as U+import           Data.List                   (sort)+import qualified Data.Vector.Unboxed         as U import           Test.QuickCheck import           Test.QuickCheck.Monadic  import           Apecs import           Apecs.Core-import           Apecs.Reactive+import           Apecs.Experimental.Reactive+import           Apecs.Experimental.Stores import           Apecs.Stores-import           Apecs.Stores.Extra import           Apecs.Util  type Vec = (Double, Double)@@ -114,25 +114,24 @@ prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3))  -- Tests Reactive store properties-newtype TestBool = TestBool Bool deriving (Eq, Show, Bounded, Enum, Arbitrary)-instance Component TestBool where type Storage TestBool = Reactive (EnumMap TestBool) (Map TestBool)+newtype TestEnum = TestEnum Bool deriving (Eq, Show, Bounded, Enum, Arbitrary)+instance Component TestEnum where type Storage TestEnum = Reactive (EnumMap TestEnum) (Map TestEnum) -makeWorld "ReactiveWld" [''TestBool]+makeWorld "ReactiveWld" [''TestEnum] -prop_setGetReactive = genericSetGet initReactiveWld (undefined :: TestBool)-prop_setSetReactive = genericSetSet initReactiveWld (undefined :: TestBool)-prop_lookupValid :: [(Entity, TestBool)] -> [Entity] -> Property+prop_setGetReactive = genericSetGet initReactiveWld (undefined :: TestEnum)+prop_setSetReactive = genericSetSet initReactiveWld (undefined :: TestEnum)+prop_lookupValid :: [(Entity, TestEnum)] -> [Entity] -> Property prop_lookupValid writes deletes = assertSys initReactiveWld $ do   forM_ writes  $ uncurry set-  forM_ deletes $ flip destroy (Proxy @TestBool)+  forM_ deletes $ flip destroy (Proxy @TestEnum) -  let getAll = cfold (flip (:)) [] :: SystemT ReactiveWld IO [(TestBool, Entity)]-  et <- fmap snd . filter ((== TestBool True ) . fst) <$> getAll-  ef <- fmap snd . filter ((== TestBool False) . fst) <$> getAll+  let getAll = cfold (flip (:)) [] :: SystemT ReactiveWld IO [(TestEnum, Entity)]+  et <- fmap snd . filter ((== TestEnum True ) . fst) <$> getAll+  ef <- fmap snd . filter ((== TestEnum False) . fst) <$> getAll -  let lookup enum = rget >>= flip mapLookup enum-  rt <- lookup (TestBool True)-  rf <- lookup (TestBool False)+  rt <- withReactive $ enumLookup (TestEnum True)+  rf <- withReactive $ enumLookup (TestEnum False)    return (  sort rt == sort et          && sort rf == sort ef