diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/apecs.cabal b/apecs.cabal new file mode 100644 --- /dev/null +++ b/apecs.cabal @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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)) + ] + ] diff --git a/example/RTS.hs b/example/RTS.hs new file mode 100644 --- /dev/null +++ b/example/RTS.hs @@ -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 diff --git a/example/Simple.hs b/example/Simple.hs new file mode 100644 --- /dev/null +++ b/example/Simple.hs @@ -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 diff --git a/src/Apecs.hs b/src/Apecs.hs new file mode 100644 --- /dev/null +++ b/src/Apecs.hs @@ -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) diff --git a/src/Apecs/Core.hs b/src/Apecs/Core.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/Core.hs @@ -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 #-} diff --git a/src/Apecs/Stores.hs b/src/Apecs/Stores.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/Stores.hs @@ -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 + diff --git a/src/Apecs/Util.hs b/src/Apecs/Util.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/Util.hs @@ -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 diff --git a/src/Apecs/Vector.hs b/src/Apecs/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Apecs/Vector.hs @@ -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) + diff --git a/tutorials/RTS.md b/tutorials/RTS.md new file mode 100644 --- /dev/null +++ b/tutorials/RTS.md @@ -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