apecs (empty) → 0.1.0.0
raw patch · 13 files changed
+1917/−0 lines, 13 filesdep +apecsdep +basedep +containerssetup-changed
Dependencies added: apecs, base, containers, criterion, mtl, random, sdl2, vector
Files
- LICENSE +30/−0
- README.md +78/−0
- Setup.hs +2/−0
- apecs.cabal +82/−0
- bench/Main.hs +75/−0
- example/RTS.hs +158/−0
- example/Simple.hs +60/−0
- src/Apecs.hs +30/−0
- src/Apecs/Core.hs +377/−0
- src/Apecs/Stores.hs +360/−0
- src/Apecs/Util.hs +219/−0
- src/Apecs/Vector.hs +154/−0
- tutorials/RTS.md +292/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Jonas Carpay (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jonas Carpay nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,78 @@+# apecs++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.++There is an example below, and a tutorial can be found [here](https://github.com/jonascarpay/apecs/blob/master/tutorials/RTS.md).+For a general introduction to ECS, see [this talk](https://www.youtube.com/watch?v=lNTaC-JWmdI&feature=youtu.be&t=218) or [here](https://en.wikipedia.org/wiki/Entity–component–system).++### Performance+Performance is good.+Running the [ecs-bench](https://github.com/lschmierer/ecs_bench) pos_vel benchmark shows that we can keep up with specs, which was written in Rust:++| | specs | apecs |+| --- | ----- | --- |+| build | 699 us | 285 us | +| update | 34 us | 46 us |++### Example+```haskell+import Apecs+import Apecs.Stores+import Apecs.Util+import Apecs.Vector -- Optional module for basic 2D and 3D vectos++-- Component data definitions+newtype Velocity = Velocity (V2 Double) deriving (Eq, Show)+newtype Position = Position (V2 Double) deriving (Eq, Show)+data Enemy = Enemy -- A single constructor for tagging entites as enemies++-- Define Velocity as a component by giving it a storage type+instance Component Velocity where+ -- Store velocities in a cached map+ type Storage Velocity = Cache 100 (Map Velocity)++instance Component Position where+ type Storage Position = Cache 100 (Map Position)++instance Flag Enemy where flag = Enemy+instance Component Enemy where+ -- Because enemy is just a flag, we can use a set+ type Storage Enemy = Set Enemy++-- Define your world as containing the storages of your components+data World = World+ { positions :: Storage Position+ , velocities :: Storage Velocity+ , enemies :: Storage Enemy+ , entityCounter :: Storage EntityCounter }++-- Define Has instances for components to allow type-driven access to their storages+instance World `Has` Position where getStore = System $ asks positions+instance World `Has` Velocity where getStore = System $ asks velocities+instance World `Has` Enemy where getStore = System $ asks enemies+instance World `Has` EntityCounter where getStore = System $ asks entityCounter++type System' a = System World a++game :: System' ()+game = do+ -- Create new entities+ newEntity (Position 0)+ -- Components can be composed using tuples+ newEntity (Position 0, Velocity 1)+ -- Tagging one as an enemy is a matter of adding the constructor+ newEntity (Position 1, Velocity 1, Enemy)++ -- Side effects+ liftIO$ putStrLn "Stepping velocities"+ -- rmap maps a pure function over all entities in its domain+ rmap $ \(Position p, Velocity v) -> Position (v+p)++ -- Print the positions of all enemies+ cmapM_ $ \(Enemy, Position p) -> liftIO (print p)++main :: IO ()+main = do w <- World <$> initStore <*> initStore <*> initStore <*> initCounter+ runSystem game w+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ apecs.cabal view
@@ -0,0 +1,82 @@+name: apecs+version: 0.1.0.0+homepage: https://github.com/jonascarpay/apecs#readme+license: BSD3+license-file: LICENSE+author: Jonas Carpay+maintainer: jonascarpay@gmail.com+category: Game, Control, Data+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md, tutorials/RTS.md+synopsis: A fast ECS for game engine programming+description: A fast ECS for game engine programming++library+ hs-source-dirs:+ src+ exposed-modules:+ Apecs,+ Apecs.Vector,+ Apecs.Stores,+ Apecs.Util+ other-modules:+ Apecs.Core+ default-language:+ Haskell2010+ build-depends:+ base >= 4.7 && < 5,+ containers,+ mtl,+ vector+ ghc-options:+ -Wall+ -Odph+ -fno-warn-unused-top-binds++executable simple+ hs-source-dirs:+ example+ main-is:+ Simple.hs+ build-depends:+ base, apecs+ default-language:+ Haskell2010+ ghc-options:+ -Wall+ -fno-warn-unused-top-binds++executable rts+ hs-source-dirs:+ example+ main-is:+ RTS.hs+ build-depends:+ base, apecs, sdl2, random+ default-language:+ Haskell2010+ ghc-options:+ -Wall+ -Odph+ -fno-warn-unused-top-binds++benchmark apecs-bench+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ bench+ main-is:+ Main.hs+ build-depends:+ base, apecs, criterion+ default-language:+ Haskell2010+ ghc-options:+ -Wall+ -Odph+ -fllvm+ -optlo-O3+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ -threaded
+ bench/Main.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE Strict, ScopedTypeVariables, DataKinds, TypeFamilies, MultiParamTypeClasses, TypeOperators #-}++import Criterion+import qualified Criterion.Main as C+import Control.Monad++import Apecs as A+import Apecs.Stores+import Apecs.Util+import Apecs.Vector++newtype Position = Position (V2 Float) deriving (Eq, Show)+instance Component Position where+ type Storage Position = Cache 10000 (Map Position)++newtype Velocity = Velocity (V2 Float) deriving (Eq, Show)+instance Component Velocity where+ type Storage Velocity = Cache 1000 (Map Velocity)++data World = World+ { positions :: Storage Position+ , velocities :: Storage Velocity+ , entityCounter :: Storage EntityCounter+ }++instance World `Has` Position where+ getStore = System $ asks positions++instance World `Has` Velocity where+ getStore = System $ asks velocities++instance World `Has` EntityCounter where+ getStore = System $ asks entityCounter++emptyWorld :: IO World+emptyWorld = liftM3 World initStore initStore initCounter++cStep (Velocity v, Position p) = (Velocity v, Position (p+v))+rStep (Velocity v, Position p) = Position (p+v)++rStep' :: (Velocity, Position) -> Safe Position+rStep' (Velocity v, Position p) = Safe (Just (Position (p+v)))++wStep' :: Safe (Velocity, Position) -> Safe Position+wStep' (Safe (Just (Velocity v), Just (Position p))) = Safe (Just (Position (p+v)))++wStep :: Safe (Velocity, Position) -> Position+wStep (Safe (Just (Velocity v), Just (Position p))) = Position (p+v)++{-# INLINE vstep #-}+vstep :: System World ()+vstep = cimapM_ $ \(e,(Velocity v,Position p)) -> set (cast e) (Position (p+v))++explicit = do sl :: Slice (Velocity, Position) <- owners+ sliceForMC_ sl $ \(e,Safe (Just (Velocity v), Just (Position p))) -> set (cast e) (Position $ p + v)++cStep1 (Velocity p) = (Velocity (p+1))++initialize :: System World ()+initialize = do replicateM_ 1000 $ newEntity (Position 0, Velocity 1)+ replicateM_ 9000 $ newEntity (Position 0)++main :: IO ()+main = C.defaultMain [ bench "init" $ whnfIO (emptyWorld >>= runSystem initialize)+ , bgroup "init and step"+ [ bench "cmap" $ whnfIO (emptyWorld >>= runSystem (initialize >> cmap cStep))+ , bench "cmap1" $ whnfIO (emptyWorld >>= runSystem (initialize >> cmap cStep1))+ , bench "rmap" $ whnfIO (emptyWorld >>= runSystem (initialize >> rmap rStep))+ , bench "rmap'" $ whnfIO (emptyWorld >>= runSystem (initialize >> rmap' rStep'))+ , bench "wmap" $ whnfIO (emptyWorld >>= runSystem (initialize >> wmap wStep))+ , bench "wmap'" $ whnfIO (emptyWorld >>= runSystem (initialize >> wmap' wStep'))+ , bench "vstep" $ whnfIO (emptyWorld >>= runSystem (initialize >> vstep))+ , bench "forMC_" $ whnfIO (emptyWorld >>= runSystem (initialize >> explicit))+ ]+ ]
+ example/RTS.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE MultiParamTypeClasses, TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}++module Main where++import Control.Monad as M+import SDL.Vect+import qualified SDL+import SDL (($=))+import System.Random+import Data.Proxy++import Apecs as A+import Apecs.Stores+import Apecs.Util+import qualified Apecs.Vector as V++hres, vres :: Num a => a+hres = 1024+vres = 768++newtype Position = Position {getPos :: V2 Double} deriving (Show, Num)+instance Component Position where+ type Storage Position = Map Position++newtype Target = Target (V2 Double)+instance Component Target where+ type Storage Target = Map Target++data Selected = Selected+instance Flag Selected where flag = Selected+instance Component Selected where+ type Storage Selected = Set Selected++data MouseState = Dragging !(V2 Double) !(V2 Double) | Rest+instance Component MouseState where+ type Storage MouseState = Global MouseState++data World = World+ { positions :: Storage Position+ , targets :: Storage Target+ , selected :: Storage Selected+ , mouseState :: Storage MouseState+ , entityCounter :: Storage EntityCounter+ }+instance World `Has` Position where getStore = System $ asks positions+instance World `Has` Target where getStore = System $ asks targets+instance World `Has` Selected where getStore = System $ asks selected+instance World `Has` MouseState where getStore = System $ asks mouseState+instance World `Has` EntityCounter where getStore = System $ asks entityCounter++type System' a = System World a++game :: System' ()+game = do+ (window, renderer) <- initRenderer++ -- Add units+ replicateM_ 5000 $ do+ x <- liftIO$ randomRIO (100,hres/2)+ y <- liftIO$ randomRIO (100,vres-100)+ newEntity (Position (V2 x y))++ let loop = do+ shouldQuit <- handleEvents+ step+ render renderer+ unless shouldQuit loop++ loop++ cleanup (window, renderer)++render :: SDL.Renderer -> System' ()+render renderer = do+ liftIO$ SDL.rendererDrawColor renderer $= V4 0 0 0 255+ liftIO$ SDL.clear renderer++ cimapM_ $ \(e, Position p) -> do+ e <- exists (cast e :: Entity Selected)+ liftIO$ SDL.rendererDrawColor renderer $= if e then V4 255 255 255 255 else V4 255 0 0 255+ SDL.drawPoint renderer (P (round <$> p))++ r <- readGlobal+ case r of+ Dragging a b -> SDL.drawRect renderer (Just $ SDL.Rectangle (P (round <$> a)) (round <$> b-a))+ _ -> return ()++ SDL.present renderer++step = do+ let speed = 5+ stepPosition :: (Target, Position) -> Safe (Target, Position)+ stepPosition (Target t, Position p)+ | V.vlength (p-t) < speed = Safe (Nothing, Just (Position t))+ | otherwise = Safe (Just (Target t), Just (Position (p + V.setLength speed (t-p))))++ cmap' stepPosition++ m <- readGlobal+ case m of+ Rest -> return ()+ Dragging (V2 ax ay) (V2 bx by) -> do+ resetStore (Proxy :: Proxy Selected)+ let f :: Position -> Safe Selected+ f (Position (V2 x y)) = Safe (x >= min ax bx && x <= max ax bx && y >= min ay by && y <= max ay by)+ rmap' f++handleEvents = do+ events <- fmap SDL.eventPayload <$> SDL.pollEvents+ mapM_ handleEvent events+ return (SDL.QuitEvent `elem` events)+ where+ handleEvent :: SDL.EventPayload -> System' ()+ handleEvent (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft _ (P p))) =+ let p' = fromIntegral <$> p in writeGlobal (Dragging p' p')++ handleEvent (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ SDL.ButtonLeft _ _)) =+ writeGlobal Rest++ handleEvent (SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ _ (P p) _)) = do+ md <- readGlobal+ case md of+ Rest -> return ()+ Dragging a _ -> writeGlobal (Dragging a (fromIntegral <$> p))++ handleEvent (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonRight _ (P (V2 px py)))) = do+ sl :: Slice Selected <- slice All+ let r = (*3) . subtract 1 . sqrt . fromIntegral$ sliceSize sl++ sliceForM_ sl $ \e -> do+ dx <- liftIO$ randomRIO (-r,r)+ dy <- liftIO$ randomRIO (-r,r)+ set e (Target (V2 (fromIntegral px+dx) (fromIntegral py+dy)))++ handleEvent _ = return ()++initRenderer = liftIO$ do+ SDL.initialize [SDL.InitVideo]+ SDL.HintRenderScaleQuality $= SDL.ScaleLinear+ window <- SDL.createWindow "Apecs tutorial" SDL.defaultWindow {SDL.windowInitialSize = V2 hres vres}+ SDL.showWindow window+ renderer <- SDL.createRenderer window (-1) (SDL.RendererConfig SDL.AcceleratedRenderer False)+ return (window, renderer)++cleanup (window, renderer) = liftIO$ do+ SDL.destroyRenderer renderer+ SDL.destroyWindow window+ SDL.quit++main :: IO ()+main = do+ w <- World <$> initStore <*> initStore <*> initStore <*> initStoreWith Rest <*> initCounter+ runSystem game w
+ example/Simple.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeFamilies, MultiParamTypeClasses, TypeOperators #-}++import Apecs+import Apecs.Stores+import Apecs.Util+import Apecs.Vector -- Optional module for basic 2D and 3D vectos++-- Component data definitions+newtype Velocity = Velocity (V2 Double) deriving (Eq, Show)+newtype Position = Position (V2 Double) deriving (Eq, Show)+data Enemy = Enemy -- A single constructor for tagging entites as enemies++-- Define Velocity as a component by giving it a storage type+instance Component Velocity where+ -- Store velocities in a cached map+ type Storage Velocity = Cache 100 (Map Velocity)++instance Component Position where+ type Storage Position = Cache 100 (Map Position)++instance Flag Enemy where flag = Enemy+instance Component Enemy where+ -- Because enemy is just a flag, we can use a set+ type Storage Enemy = Set Enemy++-- Define your world as containing the storages of your components+data World = World+ { positions :: Storage Position+ , velocities :: Storage Velocity+ , enemies :: Storage Enemy+ , entityCounter :: Storage EntityCounter }++-- Define Has instances for components to allow type-driven access to their storages+instance World `Has` Position where getStore = System $ asks positions+instance World `Has` Velocity where getStore = System $ asks velocities+instance World `Has` Enemy where getStore = System $ asks enemies+instance World `Has` EntityCounter where getStore = System $ asks entityCounter++type System' a = System World a++game :: System' ()+game = do+ -- Create new entities+ newEntity (Position 0)+ -- Components can be composed using tuples+ newEntity (Position 0, Velocity 1)+ -- Tagging one as an enemy is a matter of adding the constructor+ newEntity (Position 1, Velocity 1, Enemy)++ -- Side effects+ liftIO$ putStrLn "Stepping velocities"+ -- rmap maps a pure function over all entities in its domain+ rmap $ \(Position p, Velocity v) -> Position (v+p)++ -- Print the positions of all enemies+ cmapM_ $ \(Enemy, Position p) -> liftIO (print p)++main :: IO ()+main = do w <- World <$> initStore <*> initStore <*> initStore <*> initCounter+ runSystem game w
+ src/Apecs.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleContexts #-}++module Apecs (+ -- Core+ System(..), runSystem, runWith,+ Component(..), Entity, Slice, Has(..), Safe(..), cast,++ -- Initializable+ initStoreWith,++ -- HasMembers+ destroy, exists, owners, resetStore,++ -- Store+ get, set, setMaybe, modify,+ cmap, cmapM, cmapM_, cimapM, cimapM_,+ sliceSize,++ -- GlobalRW+ readGlobal, writeGlobal, modifyGlobal,++ -- Query+ slice, All(..),++ -- Reader+ asks, ask, liftIO, lift,+) where++import Apecs.Core as A+import Control.Monad.Reader (asks, ask, liftIO, lift)
+ src/Apecs/Core.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE Strict #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds, KindSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Apecs.Core where++import Control.Monad.Reader+import Data.Traversable (for)+import qualified Data.Vector.Unboxed as U++-- | A component is defined by the type of its storage+-- The storage in turn supplies runtime types for the component.+class Initializable (Storage c) => Component c where+ type Storage c = s | s -> c++type ID = Int+type IDVec = U.Vector ID+newtype System w a = System {unSystem :: ReaderT w IO a} deriving (Functor, Monad, Applicative, MonadIO)+newtype Slice c = Slice {unSlice :: U.Vector ID} deriving (Show, Monoid)+newtype Entity c = Entity {unEntity :: ID} deriving (Eq, Num)++{-# INLINE runSystem #-}+runSystem :: System w a -> w -> IO a+runSystem sys = runReaderT (unSystem sys)++{-# INLINE runWith #-}+runWith :: w -> System w a -> IO a+runWith = flip runSystem++-- Storage type class hierarchy+-- | Common for every storage. Represents a container that can be initialized+class Initializable s where+ type InitArgs s+ initStoreWith :: InitArgs s -> IO s++-- | A store that is indexed by entities+class HasMembers s where+ explDestroy :: s -> Int -> IO ()+ explExists :: s -> Int -> IO Bool+ explMembers :: s -> IO (U.Vector Int)++ {-# INLINE explReset #-}+ explReset :: s -> IO ()+ explReset s = do+ sl <- explMembers s+ U.mapM_ (explDestroy s) sl++ explImapM_ :: MonadIO m => s -> (Int -> m a) -> m ()+ {-# INLINE explImapM_ #-}+ explImapM_ s ma = liftIO (explMembers s) >>= Prelude.mapM_ ma . U.toList++ explImapM :: MonadIO m => s -> (Int -> m a) -> m [a]+ {-# INLINE explImapM #-}+ explImapM s ma = liftIO (explMembers s) >>= Prelude.mapM ma . U.toList++{-# INLINE imapM_ #-}+-- | Monadically iterate a system over all entities that have that component.+-- Note that writing to the store while iterating over it is undefined behaviour.+imapM_ :: forall w c. (Has w c, HasMembers (Storage c))+ => (Entity c -> System w ()) -> System w ()+imapM_ sys = do s :: Storage c <- getStore+ explImapM_ s (sys . Entity)++{-# INLINE imapM #-}+-- | Monadically iterate a system over all entities that have that component.+-- Note that writing to the store while iterating over it is undefined behaviour.+imapM :: forall w c a. (Has w c, HasMembers (Storage c))+ => (Entity c -> System w a) -> System w [a]+imapM sys = do s :: Storage c <- getStore+ explImapM s (sys . Entity)++-- | Destroys the component @c@ for the given entity+{-# INLINE destroy #-}+destroy :: forall w c. (Has w c, HasMembers (Storage c)) => Entity c -> System w ()+destroy (Entity n) = do s :: Storage c <- getStore+ liftIO$ explDestroy s n++-- | Returns whether the given entity has component @c@+-- For composite components, this indicates whether the component+-- has all its constituents+{-# INLINE exists #-}+exists :: forall w c. (Has w c, HasMembers (Storage c)) => Entity c -> System w Bool+exists (Entity n) = do s :: Storage c <- getStore+ liftIO$ explExists s n++-- | A slice containing all entities with component @c@+{-# INLINE owners #-}+owners :: forall w c. (Has w c, HasMembers (Storage c)) => System w (Slice c)+owners = do s :: Storage c <- getStore+ liftIO$ Slice <$> explMembers s++resetStore :: forall w c p. (Has w c, HasMembers (Storage c)) => p c -> System w ()+resetStore _ = do s :: Storage c <- getStore+ liftIO$ explReset s++-- | Class of storages that associates components with entities.+class HasMembers s => Store s where+ type SafeRW s -- ^ Return type for safe reads/writes to the store+ type Stores s -- ^ The type of components stored by this Store+ -- | Unsafe index to the store. Undefined if the component does not exist+ explGetUnsafe :: s -> Int -> IO (Stores s)+ -- | Retrieves a component from the store+ explGet :: s -> Int -> IO (SafeRW s)+ -- | Writes a component+ explSet :: s -> Int -> Stores s -> IO ()+ -- | Either writes or deletes a component+ explSetMaybe :: s -> Int -> SafeRW s -> IO ()++ -- | Modifies an element in the store.+ {-# 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+ explCmap :: s -> (Stores s -> Stores s) -> IO ()+ {-# INLINE explCmap #-}+ explCmap s f = do+ sl <- explMembers s+ U.forM_ sl $ \ety -> do+ x :: Stores s <- explGetUnsafe s ety+ explSet s ety (f x)++ explCmapM_ :: MonadIO m => s -> (Stores s -> m a) -> m ()+ {-# INLINE explCmapM_ #-}+ explCmapM_ s sys = do+ sl <- liftIO$ explMembers s+ U.forM_ sl $ \ety -> do x :: Stores s <- liftIO$ explGetUnsafe s ety+ sys x++ explCimapM_ :: MonadIO m => s -> ((Int, Stores s) -> m a) -> m ()+ {-# INLINE explCimapM_ #-}+ explCimapM_ s sys = do+ sl <- liftIO$ explMembers s+ U.forM_ sl $ \ety -> do x :: Stores s <- liftIO$ explGetUnsafe s ety+ sys (ety,x)++ explCmapM :: MonadIO m => s -> (Stores s -> m a) -> m [a]+ {-# INLINE explCmapM #-}+ explCmapM s sys = do+ sl <- liftIO$ explMembers s+ for (U.toList sl) $ \ety -> do+ x :: Stores s <- liftIO$ explGetUnsafe s ety+ sys x++ explCimapM :: MonadIO m => s -> ((Int, Stores s) -> m a) -> m [a]+ {-# INLINE explCimapM #-}+ explCimapM s sys = do+ sl <- liftIO$ explMembers s+ for (U.toList sl) $ \ety -> do+ x :: Stores s <- liftIO$ explGetUnsafe s ety+ sys (ety,x)++-- | A constraint that indicates that the runtime representation of @c@ is @c@+type Runtime c = Stores (Storage c)+type IsRuntime c = (Store (Storage c), Runtime c ~ c)+newtype Safe c = Safe {getSafe :: (SafeRW (Storage c))}++-- Setting/Getting+{-# INLINE get #-}+get :: forall w c. (Store (Storage c), Has w c) => Entity c -> System w (Safe c)+get (Entity ety) = do s :: Storage c <- getStore+ liftIO$ Safe <$> explGet s ety++{-# INLINE set #-}+set :: forall w c e. (Store (Storage c), Stores (Storage c) ~ c, Has w c) => Entity e -> c -> System w ()+set (Entity ety) x = do+ s :: Storage c <- getStore+ liftIO$ explSet s ety x++{-# INLINE modify #-}+modify :: forall w c. (IsRuntime c, Has w c) => Entity c -> (c -> c) -> System w ()+modify (Entity ety) f = do+ s :: Storage c <- getStore+ liftIO$ explModify s ety f++setMaybe :: forall w c. (IsRuntime c, Has w c) => Entity c -> Safe c -> System w ()+setMaybe (Entity ety) (Safe c) = do+ s :: Storage c <- getStore+ liftIO$ explSetMaybe s ety c++{-# INLINE cmap #-}+cmap :: forall world c. (IsRuntime c, Has world c) => (c -> c) -> System world ()+cmap f = do s :: Storage c <- getStore+ liftIO$ explCmap s f++{-# INLINE cmapM_ #-}+cmapM_ :: forall w c. (Has w c, IsRuntime c)+ => (c -> System w ()) -> System w ()+cmapM_ sys = do s :: Storage c <- getStore+ explCmapM_ s sys++{-# INLINE cimapM_ #-}+cimapM_ :: forall w c. (Has w c, IsRuntime c)+ => ((Entity c, c) -> System w ()) -> System w ()+cimapM_ sys = do s :: Storage c <- getStore+ explCimapM_ s (\(e,c) -> sys (Entity e,c))++{-# INLINE cmapM #-}+cmapM :: forall w c a. (Has w c, IsRuntime c)+ => (c -> System w a) -> System w [a]+cmapM sys = do s :: Storage c <- getStore+ explCmapM s sys++{-# INLINE cimapM #-}+cimapM :: forall w c a. (Has w c, IsRuntime c)+ => ((Entity c, c) -> System w a) -> System w [a]+cimapM sys = do s :: Storage c <- getStore+ explCimapM s (\(e,c) -> sys (Entity e,c))++-- | Class of storages for global values+class GlobalRW s c where+ {-# MINIMAL explGlobalRead, explGlobalWrite #-}+ explGlobalRead :: s -> IO c+ explGlobalWrite :: s -> c -> IO ()++ {-# INLINE explGlobalModify #-}+ explGlobalModify :: s -> (c -> c) -> IO ()+ explGlobalModify s f = do r <- explGlobalRead s+ explGlobalWrite s (f r)++{-# INLINE readGlobal #-}+readGlobal :: forall w c. (Has w c, GlobalRW (Storage c) c) => System w c+readGlobal = do s :: Storage c <- getStore+ liftIO$ explGlobalRead s++{-# INLINE writeGlobal #-}+writeGlobal :: forall w c. (Has w c, GlobalRW (Storage c) c) => c -> System w ()+writeGlobal c = do s :: Storage c <- getStore+ liftIO$ explGlobalWrite s c++{-# INLINE modifyGlobal #-}+modifyGlobal :: forall w c. (Has w c, GlobalRW (Storage c) c) => (c -> c) -> System w ()+modifyGlobal f = do s :: Storage c <- getStore+ liftIO$ explGlobalModify s f++-- Query+class Query q s where+ explSlice :: s -> q -> IO (U.Vector Int)++{-# 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++data All = All+instance HasMembers s => Query All s where+ {-# INLINE explSlice #-}+ explSlice s _ = explMembers s++class Cast a b where cast :: a -> b+instance Cast (Entity a) (Entity b) where+ {-# INLINE cast #-}+ cast (Entity ety) = Entity ety+instance Cast (Slice a) (Slice b) where+ {-# INLINE cast #-}+ cast (Slice vec) = Slice vec++class Component c => Has w c where+ getStore :: System w (Storage c)++instance Show (Entity c) where+ show (Entity e) = "Entity " ++ show e++{-# INLINE sliceFoldM_ #-}+sliceFoldM_ :: (a -> Entity c -> System w a) -> a -> Slice b -> System w ()+sliceFoldM_ f seed (Slice sl) = U.foldM'_ ((.Entity) . f) seed sl++-- | Gets the size of a slice (O(n))+{-# INLINE sliceSize #-}+sliceSize :: Slice a -> Int+sliceSize (Slice vec) = U.length vec++-- | Tests whether a slice is empty (O(1))+{-# INLINE sliceNull #-}+sliceNull :: Slice a -> Bool+sliceNull (Slice vec) = U.null vec++-- | Construct a slice from a list of IDs+{-# INLINE sliceFromList #-}+sliceFromList :: [ID] -> Slice a+sliceFromList = Slice . U.fromList++-- | Monadically filter a slice+{-# INLINE sliceFilterM #-}+sliceFilterM :: (Entity c -> System w Bool) -> Slice c -> System w (Slice c)+sliceFilterM fm (Slice vec) = Slice <$> U.filterM (fm . Entity) vec++{-# INLINE sliceConcat #-}+sliceConcat :: Slice a -> Slice b -> Slice c+sliceConcat (Slice a) (Slice b) = Slice (a U.++ b)+++-- Tuple instances+-- (,)+instance (Component a, Component b) => Component (a,b) where+ type Storage (a, b) = (Storage a, Storage b)+instance (Has w a, Has w b) => Has w (a,b) where+ {-# INLINE getStore #-}+ getStore = (,) <$> getStore <*> getStore++instance (Initializable a, Initializable b) => Initializable (a,b) where+ type InitArgs (a, b) = (InitArgs a, InitArgs b)+ initStoreWith (aa, ab) = (,) <$> initStoreWith aa <*> initStoreWith ab++instance (HasMembers a, HasMembers b) => HasMembers (a,b) where+ explMembers (sa,sb) = explMembers sa >>= U.filterM (explExists sb)+ explReset (sa,sb) = explReset sa >> explReset sb+ explDestroy (sa,sb) ety = explDestroy sa ety >> explDestroy sb ety+ explExists (sa,sb) ety = (&&) <$> explExists sa ety <*> explExists sb ety+ {-# INLINE explMembers #-}+ {-# INLINE explReset #-}+ {-# INLINE explDestroy #-}+ {-# INLINE explExists #-}++instance (Store a, Store b) => Store (a, b) where+ type SafeRW (a, b) = (SafeRW a, SafeRW b)+ type Stores (a, b) = (Stores a, Stores b)+ explGetUnsafe (sa,sb) ety = (,) <$> explGetUnsafe sa ety <*> explGetUnsafe sb ety+ explGet (sa,sb) ety = (,) <$> explGet sa ety <*> explGet sb ety+ explSet (sa,sb) ety (wa,wb) = explSet sa ety wa >> explSet sb ety wb+ explSetMaybe (sa,sb) ety (wa,wb) = explSetMaybe sa ety wa >> explSetMaybe sb ety wb+ {-# INLINE explGetUnsafe #-}+ {-# INLINE explGet #-}+ {-# INLINE explSet #-}+ {-# INLINE explSetMaybe #-}++instance (GlobalRW a ca, GlobalRW b cb) => GlobalRW (a,b) (ca,cb) where+ explGlobalRead (sa,sb) = (,) <$> explGlobalRead sa <*> explGlobalRead sb+ explGlobalWrite (sa,sb) (wa,wb) = explGlobalWrite sa wa >> explGlobalWrite sb wb+ {-# INLINE explGlobalRead #-}+ {-# INLINE explGlobalWrite #-}++-- (,,)+instance (Component a, Component b, Component c) => Component (a,b,c) where+ type Storage (a, b, c) = (Storage a, Storage b, Storage c)+instance (Has w a, Has w b, Has w c) => Has w (a,b,c) where+ {-# INLINE getStore #-}+ getStore = (,,) <$> getStore <*> getStore <*> getStore++instance (Initializable a, Initializable b, Initializable c) => Initializable (a,b,c) where+ type InitArgs (a, b, c) = (InitArgs a, InitArgs b, InitArgs c)+ initStoreWith (aa, ab, ac) = (,,) <$> initStoreWith aa <*> initStoreWith ab <*> initStoreWith ac++instance (HasMembers a, HasMembers b, HasMembers c) => HasMembers (a,b,c) where+ explMembers (sa,sb,sc) = explMembers sa >>= U.filterM (explExists sb) >>= U.filterM (explExists sc)+ explReset (sa,sb,sc) = explReset sa >> explReset sb >> explReset sc+ explDestroy (sa,sb,sc) ety = explDestroy sa ety >> explDestroy sb ety >> explDestroy sc ety+ explExists (sa,sb,sc) ety = and <$> sequence [explExists sa ety, explExists sb ety, explExists sc ety]+ {-# INLINE explMembers #-}+ {-# INLINE explReset #-}+ {-# INLINE explDestroy #-}+ {-# INLINE explExists #-}++instance (Store a, Store b, Store c) => Store (a, b, c) where+ type SafeRW (a, b, c) = (SafeRW a, SafeRW b, SafeRW c)+ type Stores (a, b, c) = (Stores a, Stores b, Stores c)+ explGetUnsafe (sa,sb,sc) ety = (,,) <$> explGetUnsafe sa ety <*> explGetUnsafe sb ety <*> explGetUnsafe sc ety+ explGet (sa,sb,sc) ety = (,,) <$> explGet sa ety <*> explGet sb ety <*> explGet sc ety+ explSet (sa,sb,sc) ety (wa,wb,wc) = explSet sa ety wa >> explSet sb ety wb >> explSet sc ety wc+ explSetMaybe (sa,sb,sc) ety (wa,wb,wc) = explSetMaybe sa ety wa >> explSetMaybe sb ety wb >> explSetMaybe sc ety wc+ {-# INLINE explGetUnsafe #-}+ {-# INLINE explGet #-}+ {-# INLINE explSet #-}+ {-# INLINE explSetMaybe #-}++instance (GlobalRW a ca, GlobalRW b cb, GlobalRW c cc) => GlobalRW (a,b,c) (ca,cb,cc) where+ explGlobalRead (sa,sb,sc) = (,,) <$> explGlobalRead sa <*> explGlobalRead sb <*> explGlobalRead sc+ explGlobalWrite (sa,sb,sc) (wa,wb,wc) = explGlobalWrite sa wa >> explGlobalWrite sb wb >> explGlobalWrite sc wc+ {-# INLINE explGlobalRead #-}+ {-# INLINE explGlobalWrite #-}
+ src/Apecs/Stores.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE Strict #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds, DataKinds, KindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Apecs.Stores+ ( Map, Set, Flag(..), Cache,+ Global, readGlobal, writeGlobal,+ IndexTable, ToIndex(..), ByIndex(..), ByComponent(..),+ ) where++import qualified Data.IntMap.Strict as M+import qualified Data.IntSet as S+import Data.IORef+import Data.Maybe (fromJust)+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as UM+import qualified Data.Vector.Mutable as VM+import Control.Monad+import Control.Monad.IO.Class+import GHC.TypeLits+import Data.Proxy++import Apecs.Core++newtype Map c = Map (IORef (M.IntMap c))+instance Initializable (Map c) where+ type InitArgs (Map c) = ()+ initStoreWith _ = Map <$> newIORef mempty+instance HasMembers (Map c) where+ explDestroy (Map ref) ety = modifyIORef' ref (M.delete ety)+ explMembers (Map ref) = U.fromList . M.keys <$> readIORef ref+ explExists (Map ref) ety = M.member ety <$> readIORef ref+ explReset (Map ref) = writeIORef ref mempty+ {-# INLINE explDestroy #-}+ {-# INLINE explMembers #-}+ {-# INLINE explExists #-}+ {-# INLINE explReset #-}+instance Store (Map c) where+ type SafeRW (Map c) = Maybe c+ type Stores (Map c) = c+ explGetUnsafe (Map ref) ety = fromJust . M.lookup ety <$> readIORef ref+ explGet (Map ref) ety = M.lookup ety <$> readIORef ref+ explSet (Map ref) ety x = modifyIORef' ref $ M.insert ety x+ explSetMaybe s ety Nothing = explDestroy s ety+ explSetMaybe s ety (Just x) = explSet s ety x+ explModify (Map ref) ety f = modifyIORef' ref $ M.adjust f ety+ explCmap (Map ref) f = modifyIORef' ref $ M.map f+ explCmapM_ (Map ref) ma = liftIO (readIORef ref) >>= mapM_ ma+ explCmapM (Map ref) ma = liftIO (readIORef ref) >>= mapM ma . M.elems+ explCimapM_ (Map ref) ma = liftIO (readIORef ref) >>= mapM_ ma . M.assocs+ explCimapM (Map ref) ma = liftIO (readIORef ref) >>= mapM ma . M.assocs+ {-# INLINE explGetUnsafe #-}+ {-# INLINE explGet #-}+ {-# INLINE explSet #-}+ {-# INLINE explSetMaybe #-}+ {-# INLINE explCmap #-}+ {-# INLINE explModify #-}+ {-# INLINE explCmapM_ #-}+ {-# INLINE explCmapM #-}+ {-# INLINE explCimapM_ #-}+ {-# INLINE explCimapM #-}++class Flag c where+ flag :: c+newtype Set c = Set (IORef S.IntSet)+instance Initializable (Set c) where+ type InitArgs (Set c) = ()+ initStoreWith _ = Set <$> newIORef mempty+instance HasMembers (Set c) where+ explDestroy (Set ref) ety = modifyIORef' ref (S.delete ety)+ explMembers (Set ref) = U.fromList . S.toList <$> readIORef ref+ explReset (Set ref) = writeIORef ref mempty+ explExists (Set ref) ety = S.member ety <$> readIORef ref+ explImapM_ (Set ref) ma = liftIO (readIORef ref) >>= mapM_ ma . S.toList+ explImapM (Set ref) ma = liftIO (readIORef ref) >>= mapM ma . S.toList+ {-# INLINE explDestroy #-}+ {-# INLINE explMembers #-}+ {-# INLINE explExists #-}+ {-# INLINE explReset #-}+ {-# INLINE explImapM_ #-}+ {-# INLINE explImapM #-}+instance (Flag c) => Store (Set c) where+ type SafeRW (Set c) = Bool+ type Stores (Set c) = c+ explGetUnsafe _ _ = return flag+ explGet (Set ref) ety = S.member ety <$> readIORef ref+ explSet (Set ref) ety _ = modifyIORef' ref $ S.insert ety+ explSetMaybe s ety False = explDestroy s ety+ explSetMaybe s ety True = explSet s ety flag+ explCmap _ _ = return ()+ explModify _ _ _ = return ()+ explCmapM = error "Iterating over set"+ explCmapM_ = error "Iterating over set"+ explCimapM = error "Iterating over set"+ explCimapM_ = error "Iterating over set"+ {-# INLINE explGetUnsafe #-}+ {-# INLINE explGet #-}+ {-# INLINE explSet #-}+ {-# INLINE explSetMaybe #-}+ {-# INLINE explCmap #-}+ {-# INLINE explModify #-}++newtype Const c = Const c+instance Initializable (Const c) where+ type InitArgs (Const c) = c+ initStoreWith c = return$ Const c++instance GlobalRW (Const c) c where+ explGlobalRead (Const c) = return c+ explGlobalWrite _ _ = return ()+ explGlobalModify _ _ = return ()+instance HasMembers (Const c) where+ explDestroy _ _ = return ()+ explExists _ _ = return False+ explMembers _ = return mempty+ explReset _ = return ()+instance Store (Const c) where+ type SafeRW (Const c) = c+ type Stores (Const c) = c+ explGetUnsafe (Const c) _ = return c+ explGet (Const c) _ = return c+ explSet _ _ _ = return ()+ explSetMaybe _ _ _ = return ()+ explModify _ _ _ = return ()+ explCmap _ _ = return ()++newtype Global c = Global (IORef c)+instance Initializable (Global c) where+ type InitArgs (Global c) = c+ initStoreWith c = Global <$> newIORef c++instance GlobalRW (Global c) c where+ explGlobalRead (Global ref) = readIORef ref+ explGlobalWrite (Global ref) = writeIORef ref+ explGlobalModify (Global ref) = modifyIORef' ref+ {-# INLINE explGlobalRead #-}+ {-# INLINE explGlobalWrite #-}+ {-# INLINE explGlobalModify #-}++data Cache (n :: Nat) s =+ Cache Int -- | Size+ (UM.IOVector Int) -- | Tags+ (VM.IOVector (Stores s)) -- | Members+ s -- | Writeback++instance (KnownNat n, Initializable s) => Initializable (Cache n s) where+ type InitArgs (Cache n s) = (InitArgs s)+ initStoreWith args = do+ let n = fromIntegral$ natVal (Proxy @n)+ tags <- UM.replicate n (-1)+ cache <- VM.new n+ child <- initStoreWith args+ return (Cache n tags cache child)++instance HasMembers s => HasMembers (Cache n s) where+ {-# INLINE explDestroy #-}+ explDestroy (Cache n tags _ s) ety = do+ tag <- UM.unsafeRead tags (ety `mod` n)+ if tag == ety+ then UM.unsafeWrite tags (ety `mod` n) (-1)+ else explDestroy s ety++ {-# INLINE explExists #-}+ explExists (Cache n tags _ s) ety = do+ tag <- UM.unsafeRead tags (ety `mod` n)+ if tag == ety then return True else explExists s ety++ {-# INLINE explMembers #-}+ explMembers (Cache _ tags _ s) = do+ cached <- U.filter (/= (-1)) <$> U.freeze tags+ stored <- explMembers s+ return $! cached U.++ stored++ {-# INLINE explReset #-}+ explReset (Cache n tags _ s) = do+ forM_ [0..n-1] $ \e -> UM.write tags e (-1)+ explReset s++ {-# INLINE explImapM_ #-}+ explImapM_ (Cache _ tags _ s) ma = do+ liftIO (U.freeze tags) >>= U.mapM_ ma . U.filter (/= (-1))+ explImapM_ s ma++ {-# INLINE explImapM #-}+ explImapM (Cache _ tags _ s) ma = do+ as1 <- liftIO (U.freeze tags) >>= mapM ma . U.toList . U.filter (/= (-1))+ as2 <- explImapM s ma+ return (as1 ++ as2)++instance (SafeRW s ~ Maybe (Stores s), Store s) => Store (Cache n s) where+ type SafeRW (Cache n s) = SafeRW s+ type Stores (Cache n s) = Stores s++ {-# INLINE explGetUnsafe #-}+ explGetUnsafe (Cache n tags cache s) ety = do+ let index = ety `mod` n+ tag <- UM.unsafeRead tags index+ if tag == ety+ then VM.unsafeRead cache index+ else explGetUnsafe s ety++ {-# INLINE explGet #-}+ explGet (Cache n tags cache s) ety = do+ let index = ety `mod` n+ tag <- UM.unsafeRead tags index+ if tag == ety+ then Just <$> VM.unsafeRead cache index+ else explGet s ety++ {-# INLINE explSet #-}+ explSet (Cache n tags cache s) ety x = do+ let index = ety `mod` n+ tag <- UM.unsafeRead tags index+ when (tag /= (-1) && tag /= ety) $ do+ cached <- VM.unsafeRead cache index+ explSet s tag cached+ UM.unsafeWrite tags index ety+ VM.unsafeWrite cache index x++ {-# INLINE explSetMaybe #-}+ explSetMaybe c ety Nothing = explDestroy c ety+ explSetMaybe c ety (Just x) = explSet c ety x++ {-# INLINE explCmap #-}+ explCmap (Cache n tags cache s) f = do+ forM_ [0..n-1] $ \e -> do+ tag <- UM.read tags e+ unless (tag == (-1)) (VM.modify cache f e)+ explCmap s f++ {-# INLINE explModify #-}+ explModify (Cache n tags cache s) ety f = do+ let index = ety `mod` n+ tag <- UM.read tags index+ if tag == ety+ then VM.modify cache f ety+ else explModify s ety f++ {-# INLINE explCmapM_ #-}+ explCmapM_ (Cache n tags cache s) ma = do+ forM_ [0..n-1] $ \e -> do+ tag <- liftIO$ UM.read tags e+ unless (tag == (-1)) $ do+ r <- liftIO$ VM.read cache e+ void$ ma r+ explCmapM_ s ma++ {-# INLINE explCimapM_ #-}+ explCimapM_ (Cache n tags cache s) ma = do+ forM_ [0..n-1] $ \e -> do+ tag <- liftIO$ UM.read tags e+ unless (tag == (-1)) $ do+ 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+newtype ByIndex a = ByIndex Int+newtype ByComponent c = ByComponent c+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 -> do 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+
+ src/Apecs/Util.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE Strict, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}++module Apecs.Util (+ -- * Utility+ initStore, ConcatQueries(..), runGC,++ -- * EntityCounter+ EntityCounter, initCounter, nextEntity, newEntity,++ -- * Spatial hashing+ quantize, flatten, region, inbounds,++ -- * Optimized maps+ rmap', rmap, wmap, wmap', cmap',++ -- * Slice interation+ sliceForM, sliceForM_, sliceForMC, sliceForMC_,+ sliceMapM, sliceMapM_, sliceMapMC, sliceMapMC_,++ -- * Timing+ timeSystem, timeSystem_,++ ) where++import System.Mem (performMajorGC)+import Control.Monad.Reader (liftIO)+import Control.Applicative (liftA2)+import qualified Data.Vector.Unboxed as U+import Data.Traversable (for)+import System.CPUTime++import Apecs.Core+import Apecs.Stores++-- | Initializes a store with (), useful since most stores have () as their initialization argument+initStore :: (Initializable s, InitArgs s ~ ()) => IO s+initStore = initStoreWith ()++newtype EntityCounter = EntityCounter Int+instance Component EntityCounter where+ type Storage EntityCounter = Global EntityCounter++initCounter :: IO (Storage EntityCounter)+initCounter = initStoreWith (EntityCounter 0)++{-# INLINE nextEntity #-}+nextEntity :: Has w EntityCounter => System w (Entity ())+nextEntity = do EntityCounter n <- readGlobal+ writeGlobal (EntityCounter (n+1))+ return (Entity n)++{-# INLINE newEntity #-}+newEntity :: (IsRuntime c, Has w c, Has w EntityCounter)+ => c -> System w (Entity c)+newEntity c = do ety <- nextEntity+ set (cast ety) c+ return (cast ety)++runGC :: System w ()+runGC = liftIO performMajorGC++newtype ConcatQueries q = ConcatQueries [q]+instance Query q s => Query (ConcatQueries q) s where+ explSlice s (ConcatQueries qs) = mconcat <$> traverse (explSlice s) qs++cmap' :: forall world c. (Has world c, IsRuntime c)+ => (c -> Safe c) -> System world ()+cmap' f = do s :: Storage c <- getStore+ liftIO$ do sl <- explMembers s+ U.forM_ sl $ \e -> do+ r <- explGetUnsafe s e+ explSetMaybe s e (getSafe . f $ r)++-- | Maps a function over all entities with a @r@, and writes their @w@+{-# INLINE rmap #-}+rmap :: forall world r w. (Has world w, Has world r, IsRuntime w, IsRuntime r)+ => (r -> w) -> System world ()+rmap f = do sr :: Storage r <- getStore+ sc :: Storage w <- getStore+ liftIO$ do sl <- explMembers sr+ U.forM_ sl $ \ e -> do+ r <- explGetUnsafe sr e+ explSet sc e (f r)++-- | Maps a function over all entities with a @r@, and writes or deletes their @w@+{-# INLINE rmap' #-}+rmap' :: forall world r w. (Has world w, Has world r, Store (Storage w), IsRuntime r)+ => (r -> Safe w) -> System world ()+rmap' f = do sr :: Storage r <- getStore+ sw :: Storage w <- getStore+ liftIO$ do sl <- explMembers sr+ U.forM_ sl $ \ e -> do+ r <- explGetUnsafe sr e+ explSetMaybe sw e (getSafe $ f r)++-- | For all entities with a @w@, this map reads their @r@ and writes their @w@+{-# INLINE wmap #-}+wmap :: forall world r w. (Has world w, Has world r, IsRuntime w, IsRuntime r)+ => (Safe r -> w) -> System world ()+wmap f = do sr :: Storage r <- getStore+ sw :: Storage w <- getStore+ liftIO$ do sl <- explMembers sr+ U.forM_ sl $ \ e -> do+ r <- explGet sr e+ explSet sw e (f . Safe $ r)++-- | For all entities with a @w@, this map reads their @r@ and writes or deletes their @w@+{-# INLINE wmap' #-}+wmap' :: forall world r w. (Has world w, Has world r, Store (Storage w), IsRuntime r)+ => (Safe r -> Safe w) -> System world ()+wmap' f = do sr :: Storage r <- getStore+ sw :: Storage w <- getStore+ liftIO$ do sl <- explMembers sr+ U.forM_ sl $ \ e -> do+ r <- explGet sr e+ explSetMaybe sw e (getSafe . f . Safe $ r)+++-- Slice traversal+{-# INLINE sliceForM_ #-}+sliceForM_ :: Monad m => Slice c -> (Entity c -> m b) -> m ()+sliceForM_ (Slice vec) ma = U.forM_ vec (ma . Entity)++{-# INLINE sliceForM #-}+sliceForM :: Monad m => Slice c -> (Entity c -> m a) -> m [a]+sliceForM (Slice vec) ma = traverse (ma . Entity) (U.toList vec)++{-# INLINE sliceForMC #-}+sliceForMC :: forall w c a. (Store (Storage c), Has w c) => Slice c -> ((Entity c,Safe c) -> System w a) -> System w [a]+sliceForMC (Slice vec) sys = do+ s :: Storage c <- getStore+ for (U.toList vec) $ \e -> do+ r <- liftIO$ explGet s e+ sys (Entity e, Safe r)++{-# INLINE sliceForMC_ #-}+sliceForMC_ :: forall w c a. (Store (Storage c), Has w c) => Slice c -> ((Entity c,Safe c) -> System w a) -> System w ()+sliceForMC_ (Slice vec) sys = do+ s :: Storage c <- getStore+ U.forM_ vec $ \e -> do+ r <- liftIO$ explGet s e+ sys (Entity e, Safe r)++{-# INLINE sliceMapM_ #-}+sliceMapM_ :: Monad m => (Entity c -> m a) -> Slice c -> m ()+sliceMapM_ ma (Slice vec) = U.mapM_ (ma . Entity) vec++{-# INLINE sliceMapM #-}+sliceMapM :: Monad m => (Entity c -> m a) -> Slice c -> m [a]+sliceMapM ma (Slice vec) = traverse (ma . Entity) (U.toList vec)++{-# INLINE sliceMapMC #-}+sliceMapMC :: forall w c a. (Store (Storage c), Has w c) => ((Entity c,Safe c) -> System w a) -> Slice c -> System w [a]+sliceMapMC sys (Slice vec) = do+ s :: Storage c <- getStore+ for (U.toList vec) $ \e -> do+ r <- liftIO$ explGet s e+ sys (Entity e, Safe r)++{-# INLINE sliceMapMC_ #-}+sliceMapMC_ :: forall w c a. (Store (Storage c), Has w c) => ((Entity c, Safe c) -> System w a) -> Slice c -> System w ()+sliceMapMC_ sys vec = sliceForMC_ vec sys++-- | 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+{-# 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++-- | 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++-- | Turns a table-space vector into a linear index, given some table size vector.+{-# 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)++-- | Tests whether a vector is in the region given by 0 and the size vector+{-# INLINE inbounds #-}+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+{-# INLINE timeSystem #-}+timeSystem :: System w a -> System w (Double, a)+timeSystem sys = do+ s <- liftIO getCPUTime+ a <- sys+ t <- liftIO getCPUTime+ return (fromIntegral (t-s)/1e12, a)++{-# INLINE timeSystem_ #-}+-- | Runs a system, discards its output, and gives its execution time in seconds+timeSystem_ :: System w a -> System w Double+timeSystem_ = fmap fst . timeSystem
+ src/Apecs/Vector.hs view
@@ -0,0 +1,154 @@+-- | A lightweight version of Edward Kmett's linear, included for convenience' sake++{-# LANGUAGE TypeFamilyDependencies, ScopedTypeVariables, FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++module Apecs.Vector where++import Control.Applicative++{-# INLINE dot #-}+dot :: (Num (v a), Num a, Foldable v) => v a -> v a -> a+dot a b = sum $ a * b++{-# INLINE vlength #-}+vlength :: (Foldable v, Num (v a), Floating a) => v a -> a+vlength a = sqrt (dot a a)++{-# INLINE setLength #-}+setLength :: (Num (f b), Functor f, Floating b, Foldable f) => b -> f b -> f b+setLength r v = let l = vlength v in fmap ((*r).(/l)) v++{-# INLINE normalize #-}+normalize :: (Num (v b), Floating b, Foldable v, Functor f) => v b -> f b -> f b+normalize v = fmap (/vlength v)+++-- V2+data V2 a = V2 !a !a deriving (Eq, Show)++instance Functor V2 where+ {-# INLINE fmap #-}+ fmap f (V2 a b) = V2 (f a) (f b)++instance Applicative V2 where+ {-# INLINE (<*>) #-}+ V2 fx fy <*> V2 x y = V2 (fx x) (fy y)+ {-# INLINE pure #-}+ pure x = V2 x x++instance Num a => Num (V2 a) where+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ (-) = liftA2 (-)+ {-# INLINE (-) #-}+ (*) = liftA2 (*)+ {-# INLINE (*) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ abs = fmap abs+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++instance Fractional a => Fractional (V2 a) where+ (/) = liftA2 (/)+ {-# INLINE (/) #-}+ fromRational = pure . fromRational+ {-# INLINE fromRational #-}++instance Foldable V2 where+ foldMap f (V2 x y) = f x `mappend` f y+ foldr f seed (V2 x y) = f x (f y seed)+ foldr1 f (V2 x y) = f x y+ foldl f seed (V2 x y) = f (f seed x) y+ foldl1 f (V2 x y) = f x y+ null _ = False+ length _ = 2+ elem a (V2 x y) = x == a || y == a+ minimum (V2 x y) = min x y+ maximum (V2 x y) = max x y+ sum (V2 x y) = x + y+ product (V2 x y) = x * y+ {-# INLINE foldMap #-}+ {-# INLINE foldr #-}+ {-# INLINE foldr1 #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl1 #-}+ {-# INLINE null #-}+ {-# INLINE length #-}+ {-# INLINE elem #-}+ {-# INLINE minimum #-}+ {-# INLINE maximum #-}+ {-# INLINE product #-}+ {-# INLINE sum #-}++-- V3+data V3 a = V3 !a !a !a deriving (Eq, Show)++instance Functor V3 where+ {-# INLINE fmap #-}+ fmap f (V3 a b c) = V3 (f a) (f b) (f c)++instance Applicative V3 where+ {-# INLINE (<*>) #-}+ V3 fx fy fz <*> V3 x y z = V3 (fx x) (fy y) (fz z)+ {-# INLINE pure #-}+ pure x = V3 x x x++instance Num a => Num (V3 a) where+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ (-) = liftA2 (-)+ {-# INLINE (-) #-}+ (*) = liftA2 (*)+ {-# INLINE (*) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ abs = fmap abs+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++instance Fractional a => Fractional (V3 a) where+ (/) = liftA2 (/)+ {-# INLINE (/) #-}+ fromRational = pure . fromRational+ {-# INLINE fromRational #-}++instance Foldable V3 where+ foldMap f (V3 x y z) = f x `mappend` f y `mappend` f z+ foldr f seed (V3 x y z) = f x (f y (f z seed))+ foldr1 f (V3 x y z) = f x (f y z)+ foldl f seed (V3 x y z) = f (f (f seed x) y) z+ foldl1 f (V3 x y z) = f (f x y) z+ null _ = False+ length _ = 3+ elem a (V3 x y z) = x == a || y == a || z == a+ minimum (V3 x y z) = min (min x y) z+ maximum (V3 x y z) = max (max x y) z+ sum (V3 x y z) = x + y + z+ product (V3 x y z) = x * y * z+ {-# INLINE foldMap #-}+ {-# INLINE foldr #-}+ {-# INLINE foldr1 #-}+ {-# INLINE foldl #-}+ {-# INLINE foldl1 #-}+ {-# INLINE null #-}+ {-# INLINE length #-}+ {-# INLINE elem #-}+ {-# INLINE minimum #-}+ {-# INLINE maximum #-}+ {-# INLINE product #-}+ {-# INLINE sum #-}++{-# INLINE outer #-}+outer :: Num a => V3 a -> V3 a -> V3 a+V3 a b c `outer` V3 d e f = V3 (b*f - e*c) (c*d - a*f) (a*e - b*d)+
+ tutorials/RTS.md view
@@ -0,0 +1,292 @@+## apecs tutorial+### An RTS-like game++In this tutorial we'll take a look at how to write a simple RTS-like game using apecs.+We'll be using [SDL2](https://github.com/haskell-game/sdl2) for graphics.+Don't worry if you don't know SDL2, neither do I.+We'll only be drawing single pixels to the screen, so it should be pretty easy to follow what's going on.+The final result can be found [here](https://github.com/jonascarpay/apecs/blob/master/example/RTS.hs).+You can run it with `stack build && stack exec rts`.+I will be skipping some details, so make sure to keep it handy if you want to follow along.++#### Entity Component Systems+Entity Component Systems are frameworks for game engines.+The concept is as follows:++Your game world consists of entities.+An entity is an ID and a collection of components.+Examples of components include position, velocity, health, and 3D model.+All of the entity's state is captured by the components it holds.+The game logic is then defined in systems that operate on the game world.+This is taking the [component pattern](http://gameprogrammingpatterns.com/component.html) to the extreme, where we can arbitrarily add and remove components from entities.+An example of a system is one that looks at all entities with both a position and a velocity, and adds their velocity to their position.++What makes most ECS fast is that we can store components of the same type together.+In fact, by storing each component together with the ID of the entity it belongs to, an entity becomes implicit altogether;+an entity can be said to exist as long as there is at least one component associating itself with that entity's ID.++Once you understand this, the API is relatively straightforward.++#### Components+In our game, we want to be able to select units and order them around.+We start by defining our components.++First up is position.+A `Position` is just a two-dimensional vector of `Double`s.+When defining a data type as a component, you have to specify how the component is stored in memory.+At the root of a storage you'll generally find one of three kinds of storage; a `Map`, `Set`, or `Global`.+In this case, we can simply store the position in a `Map`.+```haskell+newtype Position = Position {getPos :: V2 Double} deriving (Show, Num)++instance Component Position where+ type Storage Position = Map Position+```++A `Target` is whatever position the entity is moving towards.+Again, the storage is a simple `Map`+```haskell+newtype Target = Target (V2 Double)++instance Component Target where+ type Storage Target = Map Target+```++We use `Selected` to tag an entity as being currently selected by the mouse.+We can designate `Selected` as being a flag by defining a Flag instance, which in turn gives us access to the `Set` storage.+```haskell+data Selected = Selected++instance Flag Selected where flag = Selected+instance Component Selected where+ type Storage Selected = Set Selected+```++Finally, we need to store some global information about the mouse.+`Dragging` indicates that we're currently performing a box-selection.+```haskell+data MouseState = Rest | Dragging (V2 Double) (V2 Double)+instance Component MouseState where+ type Storage MouseState = Global MouseState+```++We'll probably look into the `Storage` type in more detail in a future tutorial.+Using the right storage type is important when optimizing performance, but for now these will do just fine.+In fact, in this example SDL will become a bottleneck before game logic will.++#### The game world+Defining your game world is straightforward.+The only extra thing to look out for is the `EntityCounter`.+Adding an `EntityCounter` means we can use `newEntity` to add entities to our game world, which is nice.+```haskell+data World = World+ { positions :: Storage Position+ , targets :: Storage Target+ , selected :: Storage Selected+ , mouseState :: Storage MouseState+ , entityCounter :: Storage EntityCounter+ }+```+`World` simply holds the storages of each component.+Or, to be more precise, it holds immutable references to mutable storage containers for each of your components.+When actually executing the game, we produce a world in the IO monad:+```haskell+initWorld = do+ positions <- initStore+ targets <- initStore+ selected <- initStore+ mouseState <- initStoreWith Rest+ counter <- initCounter+ return $ World positions targets selected counter+```+One last thing is to make sure we can access each of these at the type level by defining instances for `Has`:+```haskell+instance World `Has` Position where getStore = System $ asks positions+instance World `Has` Target where getStore = System $ asks targets+instance World `Has` Selected where getStore = System $ asks selected+instance World `Has` MouseState where getStore = System $ asks mouseState+instance World `Has` EntityCounter where getStore = System $ asks entityCounter+```+The boilerplate ends here, you will never need to touch your `World` or the `Has` class again.+In the future, this might be automated using Template Haskell, but it's still good to at least know what's being generated.++#### Systems+Most of your code takes place in the `System` monad.+If you want to know, a `System w` is a `ReaderT w IO`, but it doesn't really matter.+All that matters is the System allows for access to the World's underlying component stores.+Just add this alias for convenience' sake:+```haskell+type System' a = System World a+```+and remember that IO looks like:+```haskell+helloWorld :: System' ()+helloWorld = liftIO $ putStrLn "Hello World!"+```++Here's a system to get you started:+```haskell+newGuy :: System' ()+newGuy = newEntity (Position (V2 0 0))+```+It makes a new guy with a position of (0,0).+Here's another:+```haskell+newGuy2 :: System' ()+newGuy2 = newEntity (Player, Position (V2 0 0), Velocity (V2 0 0))+```+That's right; components can be tupled up and used as if they were a single component.++And now for something more practical:+```haskell+addUnits :: System' ()+addUnits = replicateM_ 100 $ do+ x <- liftIO$ randomRIO (0,hres)+ y <- liftIO$ randomRIO (0,vres)+ newEntity (Position (V2 x y))+```+It adds a hundred units scattered over the field.++Say you wanted to add 1 to all positions.+That would look like this:+```haskell+cmap $ \(Position p) -> Position (p+1)+```+`cmap` takes a pure function and maps it over all components in the domain of the function.++`cmap'` is analogous, but takes a function of `c -> Safe c`.+A `Safe` value comes up when performing a read that might fail, or a write that might delete.+At runtime, it looks like e.g. `Safe (Just (Position p), Nothing) :: Safe (Position, Target)` when reading an entity that has a position but no target.+In the case of `cmap'`, it means that the function might delete the component it's mapped over.++There's also `rmap`, of type `(r -> w) -> System world ()`.+It still iterates over the components in the domain, but instead of mapping to those same components, it writes the result to a different component (creating one if none exists).+This can be used to write something like `rmap $ \(Position p, Velocity v) -> Position (p+v)` to step positions, or `rmap $ \ Player -> Selected` to add the `Selected` tag to the player.++Finally, there's these mapping functions, whose effect you can see from the type signature:+```haskell+rmap' :: (r -> Safe w) -> System world ()+wmap :: (Safe r -> w) -> System world ()+wmap' :: (Safe r -> Safe w) -> System world ()+```+Note that `wmap` has a `Safe` argument in its function.+`wmap` iterates over the entities/components in the codomain of its function.+Those entities are not guaranteed to have an `r` component, so we need `Safe` here.++Let's write the first part of our game loop.+We will use `cmap'` to delete a target once we are sufficiently close:+```haskell+step = do+ let speed = 5+ stepPosition :: (Target, Position) -> Safe (Target, Position)+ stepPosition (Target t, Position p)+ | V.vlength (p-t) < speed = Safe (Nothing, Just (Position t))+ | otherwise = Safe (Just (Target t), Just (Position (p + V.setLength speed (t-p))))++ cmap' stepPosition+```+There's a lot there.+First try to understand what `stepPosition`'s type signature means, then what the body means, and then what it means to `cmap'` that function.+Once an entity loses its `Target` component, it will no longer be affected by the function above, because it's no longer in the domain of `stepPosition`.++This is the second part of the game loop:+```haskell+ m :: MouseState <- readGlobal+ case m of+ Rest -> return ()+ Dragging (V2 ax ay) (V2 bx by) -> do+ resetStore (Proxy :: Proxy Selected)+ let f :: Position -> Safe Selected+ f (Position (V2 x y)) = Safe (x >= min ax bx && x <= max ax bx && y >= min ay by && y <= max ay by)+ rmap' f+```+We start by reading the `MouseState` global.+The result of `readGlobal` is determined by the type it is instantiated with.+`resetStore` is semantically equivalent to `cmap' $ \(_ :: Selected) -> Safe False`, i.e. it just deletes every component of some type, but more general and usually faster.+Because `Selected` is a `Set`, its `Safe` representation is a `Bool` rather than `Maybe c`.+For components in a `Map`, the equivalent of `resetStore` is `cmap' $ \(_ :: c) -> Nothing`.+After resetting the store, we determine what units are selected.+We can do this using `rmap'`.+`f` looks at every `Position`, and returns `Safe True` if the position was inside the selection box.++### Events+Handling events is unpacking SDL Event types and matching them to a piece of game logic:++Here we start tracking the mouse when the left button is pressed, and stop when it is released.+```haskell+handleEvent :: SDL.EventPayload -> System' ()+handleEvent (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft _ (P p))) =+ let p' = fromIntegral <$> p in writeGlobal (Dragging p' p')++handleEvent (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ SDL.ButtonLeft _ _)) =+ writeGlobal Rest+```++This is how we update the selection box when the mouse moves:+```haskell+handleEvent (SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ _ (P p) _)) = do+ md <- readGlobal+ case md of+ Rest -> return ()+ Dragging a _ -> writeGlobal (Dragging a (fromIntegral <$> p))+```++And finally, what to do when the right mouse button is pressed.+As per genre convention, the selected units are to start moving to wherever we clicked with the right mouse button.+Now, this is an interesting piece of game logic.+How do you direct a group of units?+You can't just send them all to the same location, or they'd end up overlapping.+For simplicity's sake, I chose to arrange them randomly in a square, with area proportional to the number of selected units.+```+handleEvent (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonRight _ (P (V2 px py)))) = do+ sl :: Slice Selected <- slice All+ let r = (*3) . subtract 1 . sqrt . fromIntegral$ sliceSize sl++ sliceForM_ sl $ \e -> do+ dx <- liftIO$ randomRIO (-r,r)+ dy <- liftIO$ randomRIO (-r,r)+ set e (Target (V2 (fromIntegral px+dx) (fromIntegral py+dy)))++handleEvent _ = return ()+```+`slice` performs a query, and returns a `Slice`, which is just a list of entities.+The only query we can currently perform is `All`, which returns all owners of the specified component.+Other queries can be performed by using a more elaborate `Storage` type, but that's for a later tutorial.+The reason we need a slice instead of a map is that we need to know the amount of selected units.++There's a few more interesting functions here.+`sliceForM_` monadically iteraters over a `Slice`.+`set entity component` then explicitly writes a component for an entity, overwriting whatever might have been there.++#### Rendering+Rendering turns out to be really easy.+It looks like this:+```haskell+cimapM_ $ \(e, Position p) -> do+ e <- exists (cast e :: Entity Selected)+ liftIO$ SDL.rendererDrawColor renderer $= if e then V4 255 255 255 255 else V4 255 0 0 255+ SDL.drawPoint renderer (P (round <$> p))+```+`cmapM_` is to `cmap` as `mapM_` is to `map`.+Here we see `cimapM_`, note the extra `i`, which gives both the read component, and the current entity.+We then check whether or not it has a `Selected` component.+`exists :: Entity c -> System w ()` checks to see if the entity has a certain component.+We could emulate this with `get`, but this is, like `resetStore`, more general and usually faster.+Because the entities we iterate over are only guaranteed to have a `Position`, their type is `Entity Position`.+To check whether or not they are `Selected`, we need to explicitly cast them.+If you were to call `exists` with an `Entity (Position, Velocity)`, it'd tell you whether or not that entity has both a `Position` and `Velocity`.++#### Conclusion+These are the tools you need to build a game in apecs.+I did not discuss every line in the final program, as they were mostly SDL-related.+Again, the final version in its full glory can be found [here](https://github.com/jonascarpay/apecs/blob/master/example/RTS.hs).++The reason for writing this tutorial at this point is that apecs is now sufficiently developed where it has most of the functionality of other ECS, and is now a viable way of developing games in Haskell.+The library is still under development, but for now, that is mostly on parts outside the scope of this tutorial.+I hope to have a version on hackage soon!++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