diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,10 @@ # apecs [![Build Status](https://travis-ci.org/jonascarpay/apecs.svg?branch=master)](https://travis-ci.org/jonascarpay/apecs) [![Hackage](https://img.shields.io/hackage/v/apecs.svg)](https://hackage.haskell.org/package/apecs) -[![apecs on Stackage LTS 10](http://stackage.org/package/apecs/badge/lts-10)](http://stackage.org/lts-10/package/apecs) +[![apecs on Stackage LTS 11](http://stackage.org/package/apecs/badge/lts-11)](http://stackage.org/lts-10/package/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 provides a collection of mutable component stores, and an expressive DSL for operating on those stores, both easily extended. +apecs is an _Entity Component System_ framework inspired by [specs](https://github.com/slide-rs/specs) and [Entitas](https://github.com/sschmid/Entitas-CSharp). +The front-end DSL allows you to concisely express your game logic, with an efficient back-end storage framework that can be extended to meet any performance needs. #### Links - [documentation](https://hackage.haskell.org/package/apecs/docs/Apecs.html) diff --git a/apecs.cabal b/apecs.cabal --- a/apecs.cabal +++ b/apecs.cabal @@ -1,5 +1,5 @@ name: apecs -version: 0.3.0.2 +version: 0.4.0.0 homepage: https://github.com/jonascarpay/apecs#readme license: BSD3 license-file: LICENSE @@ -53,6 +53,8 @@ base >= 4.7 && < 5, apecs, QuickCheck, + criterion, + linear, containers, vector default-language: diff --git a/src/Apecs.hs b/src/Apecs.hs --- a/src/Apecs.hs +++ b/src/Apecs.hs @@ -3,12 +3,13 @@ It selectively re-exports the user-facing functions from the submodules. -} module Apecs ( + module Data.Proxy, -- * Core types System(..), Component(..), Entity(..), Has(..), Not(..), -- * Stores Map, Unique, Global, Cache, - initStore, + explInit, -- * Systems get, set, getAll, @@ -17,14 +18,15 @@ -- * Other runSystem, runWith, - runGC, EntityCounter, newEntity, global, proxy, - makeWorld, + runGC, EntityCounter, newEntity, global, + makeWorld, makeWorldAndComponents, -- * Re-exports asks, ask, liftIO, lift, ) where import Control.Monad.Reader (ask, asks, lift, liftIO) +import Data.Proxy import Apecs.Stores import Apecs.System diff --git a/src/Apecs/Concurrent.hs b/src/Apecs/Concurrent.hs --- a/src/Apecs/Concurrent.hs +++ b/src/Apecs/Concurrent.hs @@ -23,12 +23,12 @@ -- | Parallel version of @cmap@. {-# INLINE pmap #-} -pmap :: forall w x y. (Has w y, Has w x) +pmap :: forall w cx cy. (Get w cx, Members w cx, Set w cy) => Int -- ^ Entities per thread - -> (x -> y) -> System w () + -> (cx -> cy) -> System w () pmap grainSize f = - do sr :: Storage x <- getStore - sw :: Storage y <- getStore + do sr :: Storage cx <- getStore + sw :: Storage cy <- getStore liftIO$ do sl <- explMembers sr parallelize grainSize (\e -> explGet sr e >>= explSet sw e . f) sl diff --git a/src/Apecs/Core.hs b/src/Apecs/Core.hs --- a/src/Apecs/Core.hs +++ b/src/Apecs/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -11,54 +12,58 @@ import Control.Monad.Reader import Data.Functor.Identity -import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed as U -import qualified Apecs.THTuples as T +import qualified Apecs.THTuples as T --- | An Entity is really just an Int in a newtype, used to index into a component store. -newtype Entity = Entity Int deriving (Eq, Ord, Show) +-- | An Entity is just an integer, used to index into a component store. +newtype Entity = Entity {unEntity :: Int} deriving (Num, Eq, Ord, Show) --- | A system is a newtype around `ReaderT w IO a`, where `w` is the game world variable. +-- | A System is a newtype around `ReaderT w IO a`, where `w` is the game world variable. newtype System w a = System {unSystem :: ReaderT w IO a} deriving (Functor, Monad, Applicative, MonadIO) -- | A component is defined by the type of its storage -- The storage in turn supplies runtime types for the component. -- For the component to be valid, its Storage must be an instance of Store. -class (Elem (Storage c) ~ c, Store (Storage c)) => Component c where +class (Elem (Storage c) ~ c) => Component c where type Storage c -- | A world `Has` a component if it can produce its Storage class Component c => Has w c where getStore :: System w (Storage c) --- | Holds components indexed by entities --- --- Laws: --- --- * For all entities in @exmplMembers s@, @explExists s ety@ must be true. --- --- * If for some entity @explExists s ety@, @explGet s ety@ should safely return a non-bottom value. -class Store s where - -- | The type of components stored by this Store - type Elem s +-- | The type of components stored by a Store +type family Elem s +-- | Holds components indexed by entities +class ExplInit s where -- | Initialize the store with its initialization arguments. - initStore :: IO s + explInit :: IO s - -- | Writes a component - explSet :: s -> Int -> Elem s -> IO () +-- | Stores that support @get@ and @exists@ in the IO monad +-- If @existsIO@ +class ExplGet s where -- | Reads a component from the store. What happens if the component does not exist is left undefined. explGet :: s -> Int -> IO (Elem s) + -- | Returns whether there is a component for the given index + explExists :: s -> Int -> IO Bool + +class ExplSet s where + -- | Writes a component + explSet :: s -> Int -> Elem s -> IO () + +class ExplDestroy s where -- | Destroys the component for a given index. explDestroy :: s -> Int -> IO () + +class ExplMembers s where -- | Returns an unboxed vector of member indices explMembers :: s -> IO (U.Vector Int) - -- | Returns whether there is a component for the given index - explExists :: s -> Int -> IO Bool - explExists s n = do - mems <- explMembers s - return $ U.elem n mems +type Get w c = (Has w c, ExplGet (Storage c)) +type Set w c = (Has w c, ExplSet (Storage c)) +type Members w c = (Has w c, ExplMembers (Storage c)) +type Destroy w c = (Has w c, ExplDestroy (Storage c)) instance Component c => Component (Identity c) where type Storage (Identity c) = Identity (Storage c) @@ -66,18 +71,23 @@ instance Has w c => Has w (Identity c) where getStore = Identity <$> getStore -instance Store s => Store (Identity s) where - type Elem (Identity s) = Identity (Elem s) - initStore = error "Initializing Pseudostore" +type instance Elem (Identity s) = Identity (Elem s) + +instance ExplGet s => ExplGet (Identity s) where explGet (Identity s) e = Identity <$> explGet s e - explSet (Identity s) e (Identity x) = explSet s e x explExists (Identity s) = explExists s + +instance ExplSet s => ExplSet (Identity s) where + explSet (Identity s) e (Identity x) = explSet s e x +instance ExplMembers s => ExplMembers (Identity s) where explMembers (Identity s) = explMembers s +instance ExplDestroy s => ExplDestroy (Identity s) where explDestroy (Identity s) = explDestroy s --- Tuple Instances +-- Tuple Instances TODO T.makeInstances [2..8] + -- | Psuedocomponent indicating the absence of @a@. data Not a = Not @@ -90,15 +100,15 @@ instance (Has w c) => Has w (Not c) where getStore = NotStore <$> getStore -instance Store s => Store (NotStore s) where - type Elem (NotStore s) = Not (Elem s) - initStore = error "Initializing Pseudostore" +type instance Elem (NotStore s) = Not (Elem s) + +instance ExplGet s => ExplGet (NotStore s) where explGet _ _ = return Not - explSet (NotStore sa) ety _ = explDestroy sa ety explExists (NotStore sa) ety = not <$> explExists sa ety - explMembers _ = return mempty - explDestroy sa ety = explSet sa ety Not +instance ExplDestroy s => ExplSet (NotStore s) where + explSet (NotStore sa) ety _ = explDestroy sa ety + -- | Pseudostore used to produce values of type @Maybe a@ newtype MaybeStore s = MaybeStore s instance Component c => Component (Maybe c) where @@ -107,42 +117,18 @@ instance (Has w c) => Has w (Maybe c) where getStore = MaybeStore <$> getStore -instance Store s => Store (MaybeStore s) where - type Elem (MaybeStore s) = Maybe (Elem s) - initStore = error "Initializing Pseudostore" +type instance Elem (MaybeStore s) = Maybe (Elem s) + +instance ExplGet s => ExplGet (MaybeStore s) where explGet (MaybeStore sa) ety = do e <- explExists sa ety if e then Just <$> explGet sa ety else return Nothing - explSet (MaybeStore sa) ety Nothing = explDestroy sa ety - explSet (MaybeStore sa) ety (Just x) = explSet sa ety x explExists _ _ = return True - explMembers _ = return mempty - explDestroy (MaybeStore sa) ety = explDestroy sa ety --- | Pseudostore used to produce values of type @Either p q@ -data EitherStore sp sq = EitherStore sp sq -instance (Component p, Component q) => Component (Either p q) where - type Storage (Either p q) = EitherStore (Storage p) (Storage q) - -instance (Has w p, Has w q) => Has w (Either p q) where - getStore = EitherStore <$> getStore <*> getStore - -instance (Store sp, Store sq) => Store (EitherStore sp sq) where - type Elem (EitherStore sp sq) = Either (Elem sp) (Elem sq) - initStore = error "Initializing Pseudostore" - explGet (EitherStore sp sq) ety = do - e <- explExists sp ety - if e then Left <$> explGet sp ety - else Right <$> explGet sq ety - explSet (EitherStore sp _) ety (Left p) = explSet sp ety p - explSet (EitherStore _ sq) ety (Right q) = explSet sq ety q - explExists (EitherStore sp sq) ety = do - e <- explExists sp ety - if e then return True - else explExists sq ety - explMembers _ = return mempty - explDestroy _ _ = return () +instance (ExplDestroy s, ExplSet s) => ExplSet (MaybeStore s) where + explSet (MaybeStore sa) ety Nothing = explDestroy sa ety + explSet (MaybeStore sa) ety (Just x) = explSet sa ety x data Filter c = Filter deriving (Eq, Show) newtype FilterStore s = FilterStore s @@ -153,14 +139,11 @@ instance Has w c => Has w (Filter c) where getStore = FilterStore <$> getStore -instance Store s => Store (FilterStore s) where - type Elem (FilterStore s) = Filter (Elem s) - initStore = error "Initializing Pseudostore" +type instance Elem (FilterStore s) = Filter (Elem s) + +instance ExplGet s => ExplGet (FilterStore s) where explGet _ _ = return Filter - explSet _ _ _ = return () explExists (FilterStore s) ety = explExists s ety - explMembers (FilterStore s) = explMembers s - explDestroy _ _ = return () -- | Pseudostore used to produce components of type @Entity@ data EntityStore = EntityStore @@ -170,11 +153,7 @@ instance (Has w Entity) where getStore = return EntityStore -instance Store EntityStore where - type Elem EntityStore = Entity - initStore = error "Initializing Pseudostore" +type instance Elem EntityStore = Entity +instance ExplGet EntityStore where explGet _ ety = return $ Entity ety - explSet _ _ _ = liftIO$ putStrLn "Warning: Writing Entity is undefined" explExists _ _ = return True - explMembers _ = return mempty - explDestroy _ _ = return () diff --git a/src/Apecs/Stores.hs b/src/Apecs/Stores.hs --- a/src/Apecs/Stores.hs +++ b/src/Apecs/Stores.hs @@ -28,97 +28,93 @@ -- | A map based on @Data.Intmap.Strict@. O(log(n)) for most operations. newtype Map c = Map (IORef (M.IntMap c)) -instance Store (Map c) where - type Elem (Map c) = c - initStore = Map <$> newIORef mempty - explGet (Map ref) ety = fromJust . M.lookup ety <$> readIORef ref - explSet (Map ref) ety x = modifyIORef' ref $ M.insert ety x - explExists (Map ref) ety = M.member ety <$> readIORef ref - explDestroy (Map ref) ety = modifyIORef' ref (M.delete ety) - explMembers (Map ref) = U.fromList . M.keys <$> readIORef ref + +type instance Elem (Map c) = c +instance ExplInit (Map c) where + explInit = Map <$> newIORef mempty + +instance ExplGet (Map c) where + explExists (Map ref) ety = M.member ety <$> readIORef ref + explGet (Map ref) ety = fromJust . M.lookup ety <$> readIORef ref + {-# INLINE explExists #-} {-# INLINE explGet #-} + +instance ExplSet (Map c) where {-# INLINE explSet #-} + explSet (Map ref) ety x = modifyIORef' ref $ M.insert ety x + +instance ExplDestroy (Map c) where {-# INLINE explDestroy #-} + explDestroy (Map ref) ety = modifyIORef' ref (M.delete ety) + +instance ExplMembers (Map c) where {-# INLINE explMembers #-} - {-# INLINE explExists #-} + explMembers (Map ref) = U.fromList . M.keys <$> readIORef ref -- | A Unique contains zero or one component. -- Writing to it overwrites both the previous component and its owner. -- Its main purpose is to be a @Map@ optimized for when only ever one component inhabits it. data Unique c = Unique (IORef Int) (IORef c) -instance Store (Unique c) where - type Elem (Unique c) = c - initStore = Unique <$> newIORef (-1) <*> newIORef (error "Uninitialized Unique value") - explGet (Unique _ cref) _ = readIORef cref - explSet (Unique eref cref) ety x = writeIORef eref ety >> writeIORef cref x +type instance Elem (Unique c) = c +instance ExplInit (Unique c) where + explInit = Unique <$> newIORef (-1) <*> newIORef (error "Uninitialized Unique value") + +instance ExplGet (Unique c) where + {-# INLINE explGet #-} + explGet (Unique _ cref) _ = readIORef cref + {-# INLINE explExists #-} + explExists (Unique eref _) ety = (==ety) <$> readIORef eref + +instance ExplSet (Unique c) where + {-# INLINE explSet #-} + explSet (Unique eref cref) ety x = writeIORef eref ety >> writeIORef cref x + +instance ExplDestroy (Unique c) where + {-# INLINE explDestroy #-} explDestroy (Unique eref _) ety = do e <- readIORef eref; when (e==ety) (writeIORef eref (-1)) + +instance ExplMembers (Unique c) where + {-# INLINE explMembers #-} explMembers (Unique eref _) = f <$> readIORef eref where f (-1) = mempty f x = U.singleton x - explExists (Unique eref _) ety = (==ety) <$> readIORef eref - {-# INLINE explDestroy #-} - {-# INLINE explMembers #-} - {-# INLINE explExists #-} - {-# INLINE explSet #-} - {-# INLINE explGet #-} -- | A Global contains exactly one component. -- Initialized with 'mempty' -- The store will return true for every existence check, but only ever gives (-1) as its inhabitant. -- The entity argument is ignored when setting/getting a global. newtype Global c = Global (IORef c) -instance Monoid c => Store (Global c) where - type Elem (Global c) = c - initStore = Global <$> newIORef mempty - explGet (Global ref) _ = readIORef ref +type instance Elem (Global c) = c +instance Monoid c => ExplInit (Global c) where + explInit = Global <$> newIORef mempty + +instance ExplGet (Global c) where + explGet (Global ref) _ = readIORef ref + explExists _ _ = return True + +instance ExplSet (Global c) where explSet (Global ref) _ c = writeIORef ref c - explExists _ _ = return True - explDestroy s _ = explSet s 0 mempty - explMembers _ = return $ U.singleton (-1) - {-# INLINE explDestroy #-} - {-# INLINE explMembers #-} - {-# INLINE explExists #-} - {-# INLINE explSet #-} - {-# INLINE explGet #-} +-- | An empty type class indicating that the store behaves like a regular map, and can therefore safely be cached. +class Cachable s +instance Cachable (Map s) +instance (KnownNat n, Cachable s) => Cachable (Cache n s) + -- | A cache around another store. -- Note that iterating over a cache is linear in cache size, so sparsely populated caches might actually decrease performance. data Cache (n :: Nat) s = Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s - --- | An empty type class indicating that the store behaves like a regular map, and can therefore safely be cached. -class Store s => Cachable s -instance Cachable (Map s) -instance (KnownNat n, Cachable s) => Cachable (Cache n s) +type instance Elem (Cache n s) = Elem s -instance (KnownNat n, Cachable s) => Store (Cache n s) where - type Elem (Cache n s) = Elem s - initStore = do +instance (ExplInit s, KnownNat n, Cachable s) => ExplInit (Cache n s) where + explInit = do let n = fromIntegral$ natVal (Proxy @n) tags <- UM.replicate n (-1) cache <- VM.new n - child <- initStore + child <- explInit return (Cache n tags cache child) - {-# INLINE explDestroy #-} - explDestroy (Cache n tags _ s) ety = do - tag <- UM.unsafeRead tags (ety `rem` n) - if tag == ety - then UM.unsafeWrite tags (ety `rem` n) (-1) - else explDestroy s ety - - {-# INLINE explExists #-} - explExists (Cache n tags _ s) ety = do - tag <- UM.unsafeRead tags (ety `rem` 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 explGet #-} +instance ExplGet s => ExplGet (Cache n s) where explGet (Cache n tags cache s) ety = do let index = ety `rem` n tag <- UM.unsafeRead tags index @@ -126,7 +122,11 @@ then VM.unsafeRead cache index else explGet s ety - {-# INLINE explSet #-} + explExists (Cache n tags _ s) ety = do + tag <- UM.unsafeRead tags (ety `rem` n) + if tag == ety then return True else explExists s ety + +instance ExplSet s => ExplSet (Cache n s) where explSet (Cache n tags cache s) ety x = do let index = ety `rem` n tag <- UM.unsafeRead tags index @@ -135,3 +135,16 @@ explSet s tag cached UM.unsafeWrite tags index ety VM.unsafeWrite cache index x + +instance ExplDestroy s => ExplDestroy (Cache n s) where + explDestroy (Cache n tags _ s) ety = do + tag <- UM.unsafeRead tags (ety `rem` n) + if tag == ety + then UM.unsafeWrite tags (ety `rem` n) (-1) + else explDestroy s ety + +instance ExplMembers s => ExplMembers (Cache n s) where + explMembers (Cache _ tags _ s) = do + cached <- U.filter (/= (-1)) <$> U.freeze tags + stored <- explMembers s + return $! cached U.++ stored diff --git a/src/Apecs/System.hs b/src/Apecs/System.hs --- a/src/Apecs/System.hs +++ b/src/Apecs/System.hs @@ -7,6 +7,7 @@ module Apecs.System where import Control.Monad.Reader +import Data.Proxy import qualified Data.Vector.Unboxed as U import Apecs.Core @@ -22,7 +23,7 @@ runWith = flip runSystem {-# INLINE get #-} -get :: forall w c. Has w c => Entity -> System w c +get :: forall w c. Get w c => Entity -> System w c get (Entity ety) = do s :: Storage c <- getStore liftIO$ explGet s ety @@ -31,7 +32,7 @@ -- The type was originally 'Entity c -> c -> System w ()', but is relaxed to 'Entity e' -- so you don't always have to write 'set . cast' {-# INLINE set #-} -set :: forall w c. Has w c => Entity -> c -> System w () +set :: forall w c. Set w c => Entity -> c -> System w () set (Entity ety) x = do s :: Storage c <- getStore liftIO$ explSet s ety x @@ -39,39 +40,41 @@ -- | Returns whether the given entity has component @c@ -- Note that @c@ is a phantom argument, used only to convey the type of the entity to be queried. {-# INLINE exists #-} -exists :: forall w c. Has w c => Entity -> c -> System w Bool -exists (Entity ety) ~_ = do +exists :: forall w c. Get w c => Entity -> Proxy c -> System w Bool +exists (Entity ety) _ = do s :: Storage c <- getStore liftIO$ explExists s ety -- | Maps a function over all entities with a @cx@, and writes their @cy@ {-# INLINE cmap #-} -cmap :: forall world cx cy. (Has world cx, Has world cy) - => (cx -> cy) -> System world () +cmap :: forall w cx cy. (Get w cx, Members w cx, Set w cy) + => (cx -> cy) -> System w () cmap f = do sx :: Storage cx <- getStore sy :: Storage cy <- getStore liftIO$ do - sl <- liftIO$ explMembers sx + sl <- explMembers sx U.forM_ sl $ \ e -> do r <- explGet sx e explSet sy e (f r) --- | Monadically iterates over all entites with a cx +-- | Monadically iterates over all entites with a cx, and writes their cy {-# INLINE cmapM #-} -cmapM :: forall world c a. Has world c - => (c -> System world a) -> System world [a] +cmapM :: forall w cx cy. (Get w cx, Set w cy, Members w cx) + => (cx -> System w cy) -> System w () cmapM sys = do - s :: Storage c <- getStore - sl <- liftIO$ explMembers s - forM (U.toList sl) $ \ ety -> do - x <- liftIO$ explGet s ety - sys x + sx :: Storage cx <- getStore + sy :: Storage cy <- getStore + sl <- liftIO$ explMembers sx + U.forM_ sl $ \ e -> do + x <- liftIO$ explGet sx e + y <- sys x + liftIO$ explSet sy e y -- | Monadically iterates over all entites with a cx {-# INLINE cmapM_ #-} -cmapM_ :: forall world c a. Has world c - => (c -> System world a) -> System world () +cmapM_ :: forall w c a. (Get w c, Members w c) + => (c -> System w a) -> System w () cmapM_ sys = do s :: Storage c <- getStore sl <- liftIO$ explMembers s @@ -82,8 +85,8 @@ -- | Get all components @c@. -- Call as @[(c,Entity)]@ to read the entity/index. {-# INLINE getAll #-} -getAll :: forall world c. Has world c - => System world [c] +getAll :: forall w c. (Get w c, Members w c) + => System w [c] getAll = do s :: Storage c <- getStore sl <- liftIO$ explMembers s @@ -93,14 +96,14 @@ -- | Destroys component @c@ for the given entity. -- Note that @c@ is a phantom argument, used only to convey the type of the entity to be destroyed. {-# INLINE destroy #-} -destroy :: forall w c. Has w c => Entity -> c -> System w () -destroy (Entity ety) ~_ = do +destroy :: forall w c. Destroy w c => Entity -> Proxy c -> System w () +destroy (Entity ety) _ = do s :: Storage c <- getStore liftIO$ explDestroy s ety -- | Applies a function, if possible. {-# INLINE modify #-} -modify :: forall w c. Has w c => Entity -> (c -> c) -> System w () +modify :: forall w c. (Get w c, Set w c) => Entity -> (c -> c) -> System w () modify (Entity ety) f = do s :: Storage c <- getStore liftIO$ do @@ -109,7 +112,7 @@ -- | Counts the number of entities with a @c@ {-# INLINE count #-} -count :: forall w c. Has w c => c -> System w Int +count :: forall w c. Members w c => c -> System w Int count ~_ = do s :: Storage c <- getStore sl <- liftIO$ explMembers s diff --git a/src/Apecs/TH.hs b/src/Apecs/TH.hs --- a/src/Apecs/TH.hs +++ b/src/Apecs/TH.hs @@ -1,11 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} module Apecs.TH - ( makeWorld, makeWorldNoEC - )where + ( makeWorld, makeWorldNoEC, makeWorldAndComponents + ) where import Language.Haskell.TH +import Control.Monad +import Apecs.Core +import Apecs.Stores import Apecs.Util (EntityCounter) genName :: String -> Q Name @@ -14,7 +17,9 @@ -- | Same as 'makeWorld', but has no 'EntityCounter' makeWorldNoEC :: String -> [Name] -> Q [Dec] makeWorldNoEC worldName cTypes = do - cTypesNames <- mapM (\t -> do rec <- genName "rec"; return (ConT t, rec)) cTypes + cTypesNames <- forM cTypes $ \t -> do + rec <- genName "rec" + return (ConT t, rec) let wld = mkName worldName has = mkName "Has" @@ -34,13 +39,25 @@ initWorldName = mkName $ "init" ++ worldName initSig = SigD initWorldName (AppT (ConT (mkName "IO")) (ConT wld)) initDecl = FunD initWorldName [Clause [] - (NormalB$ iterate (\wE -> AppE (AppE (VarE $ mkName "<*>") wE) (VarE $ mkName "initStore")) (AppE (VarE $ mkName "return") (ConE wld)) !! length records) + (NormalB$ iterate (\wE -> AppE (AppE (VarE $ mkName "<*>") wE) (VarE $ mkName "explInit")) (AppE (VarE $ mkName "return") (ConE wld)) !! length records) [] ] hasDecl = makeInstance <$> cTypesNames return $ wldDecl : initSig : initDecl : hasDecl +makeComponent :: Name -> Q Dec +makeComponent comp = do + let ct = return$ ConT comp + head <$> [d| instance Component $ct where type Storage $ct = Map $ct |] + +-- | Same as makeWorld, but also makes a component instance: +makeWorldAndComponents :: String -> [Name] -> Q [Dec] +makeWorldAndComponents worldName cTypes = do + wdecls <- makeWorld worldName cTypes + cdecls <- mapM makeComponent cTypes + return $ wdecls ++ cdecls + {-| > makeWorld "WorldName" [''Component1, ''Component2, ...] @@ -59,4 +76,3 @@ |-} makeWorld :: String -> [Name] -> Q [Dec] makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter]) - diff --git a/src/Apecs/THTuples.hs b/src/Apecs/THTuples.hs --- a/src/Apecs/THTuples.hs +++ b/src/Apecs/THTuples.hs @@ -5,46 +5,48 @@ import qualified Data.Vector.Unboxed as U import Language.Haskell.TH --- | Generate tuple instances for the following tuple sizes. -makeInstances :: [Int] -> Q [Dec] -makeInstances is = concat <$> traverse tupleInstances is - {-- -instance (Component a, Component b) => Component (a,b) where +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 + getStore = liftM2 (,) getStore getStore -instance (Store a, Store b) => Store (a,b) where - type Elem (a, b) = (Elem a, Elem b) - type SafeRW (a, b) = (SafeRW a, SafeRW b) - initStore = (,) <$> initStore <*> initStore +type instance Elem (a,b) = (Elem a, Elem b) - explSet (sa,sb) ety (wa,wb) = explSet sa ety wa >> explSet sb ety wb - explDestroy (sa,sb) ety = explDestroy sa ety >> explDestroy sb ety - explExists (sa,sb) ety = explExists sa ety >>= \case False -> return False - True -> explExists sb ety - explMembers (sa,sb) = explMembers sa >>= U.filterM (explExists sb) - {-# INLINE explGet #-} - {-# INLINE explSet #-} - {-# INLINE explMembers #-} - {-# INLINE explDestroy #-} - {-# INLINE explExists #-} +instance (ExplGet a, ExplGet b) => ExplGet (a, b) where + explExists (sa, sb) ety = liftM2 (&&) (explExists sa ety) (explExists sb ety) + explGet (sa, sb) ety = liftM2 (,) (explGet sa ety) (explGet sb ety) + +instance (ExplSet a, ExplSet b) => ExplSet (a, b) where + explSet (sa,sb) ety (a,b) = explSet sa ety a >> explSet sb ety b + +instance (ExplDestroy a, ExplDestroy b) => ExplDestroy (a, b) where + explDestroy (sa, sb) ety = explDestroy sa ety >> explDestroy sb ety + +instance (ExplMembers a, ExplGet b) => ExplMembers (a, b) where + explMembers (sa, sb) = explMembers sa >>= U.filterM (explExists sb) --} + +-- | Generate tuple instances for the following tuple sizes. +makeInstances :: [Int] -> Q [Dec] +makeInstances is = concat <$> traverse tupleInstances is + tupleInstances :: Int -> Q [Dec] tupleInstances n = do let vars = [ VarT . mkName $ "t_" ++ show i | i <- [0..n-1]] + tupleUpT :: [Type] -> Type tupleUpT = foldl AppT (TupleT n) varTuple :: Type varTuple = tupleUpT vars + tupleName :: Name tupleName = tupleDataName n tuplE :: Exp tuplE = ConE tupleName + -- Component compN = mkName "Component" compT var = ConT compN `AppT` var strgN = mkName "Storage" @@ -54,6 +56,7 @@ TySynEqn [varTuple] (tupleUpT . fmap strgT $ vars) ] + -- Has hasN = mkName "Has" hasT var = ConT hasN `AppT` VarT (mkName "w") `AppT` var getStoreN = mkName "getStore" @@ -70,12 +73,12 @@ sequenceAll :: [Exp] -> Exp sequenceAll = foldl1 (\a x -> AppE (AppE (VarE$ mkName ">>") a) x) - strN = mkName "Store" - strsN = mkName "Elem" - - strT var = ConT strN `AppT` var - strsT var = ConT strsN `AppT` var + -- Elem + elemN = mkName "Elem" + elemT var = ConT elemN `AppT` var + elemI = TySynInstD elemN $ TySynEqn [varTuple] (tupleUpT $ fmap elemT vars) + -- s, ety, w arguments sNs = [ mkName $ "s_" ++ show i | i <- [0..n-1]] sPat = ConP tupleName (VarP <$> sNs) sEs = VarE <$> sNs @@ -86,12 +89,21 @@ wPat = ConP tupleName (VarP <$> wNs) wEs = VarE <$> wNs + getN = mkName "ExplGet" + setN = mkName "ExplSet" + membersN = mkName "ExplMembers" + destroyN = mkName "ExplDestroy" + + getT var = ConT getN `AppT` var + setT var = ConT setN `AppT` var + membersT var = ConT membersN `AppT` var + destroyT var = ConT destroyN `AppT` var + explSetN = mkName "explSet" explDestroyN = mkName "explDestroy" explExistsN = mkName "explExists" explMembersN = mkName "explMembers" explGetN = mkName "explGet" - initStoreN = mkName "initStore" explSetE = VarE explSetN explDestroyE = VarE explDestroyN @@ -99,46 +111,46 @@ explMembersE = VarE explMembersN explGetE = VarE explGetN - explSetF sE wE = AppE explSetE sE `AppE` etyE `AppE` wE + explSetF sE wE = AppE explSetE sE `AppE` etyE `AppE` wE explDestroyF sE = AppE explDestroyE sE `AppE` etyE - explExistsF sE = AppE explExistsE sE + explExistsF sE = AppE explExistsE sE explMembersF sE = AppE explMembersE sE - explGetF sE = AppE explGetE sE `AppE` etyE + explGetF sE = AppE explGetE sE `AppE` etyE - explExistsAnd va vb = AppE (AppE (VarE '(>>=)) va) - (LamCaseE [ Match (ConP 'False []) (NormalB$ AppE (VarE 'return) (ConE 'False)) [] - , Match (ConP 'True []) (NormalB vb) [] - ]) + explExistsAnd va vb = + AppE (AppE (VarE '(>>=)) va) + (LamCaseE [ Match (ConP 'False []) (NormalB$ AppE (VarE 'return) (ConE 'False)) [] + , Match (ConP 'True []) (NormalB vb) [] + ]) explMembersFold va vb = AppE (VarE '(>>=)) va `AppE` AppE (VarE 'U.filterM) vb - strI = InstanceD Nothing (strT <$> vars) (strT varTuple) - [ TySynInstD strsN $ TySynEqn [varTuple] (tupleUpT $ fmap strsT vars) + getI = InstanceD Nothing (getT <$> vars) (getT varTuple) + [ FunD explGetN [Clause [sPat, etyPat] + (NormalB$ liftAll tuplE (explGetF <$> sEs)) [] ] + , PragmaD$ InlineP explGetN Inline FunLike AllPhases - , FunD explSetN [Clause [sPat, etyPat, wPat] + , FunD explExistsN [Clause [sPat, etyPat] + (NormalB$ foldr explExistsAnd (AppE (VarE 'pure) (ConE 'True)) ((`AppE` etyE) . explExistsF <$> sEs)) [] ] + , PragmaD$ InlineP explExistsN Inline FunLike AllPhases + ] + + setI = InstanceD Nothing (setT <$> vars) (setT varTuple) + [ FunD explSetN [Clause [sPat, etyPat, wPat] (NormalB$ sequenceAll (zipWith explSetF sEs wEs)) [] ] , PragmaD$ InlineP explSetN Inline FunLike AllPhases + ] - , FunD explDestroyN [Clause [sPat, etyPat] + destroyI = InstanceD Nothing (destroyT <$> vars) (destroyT varTuple) + [ FunD explDestroyN [Clause [sPat, etyPat] (NormalB$ sequenceAll (explDestroyF <$> sEs)) [] ] , PragmaD$ InlineP explDestroyN Inline FunLike AllPhases - - , FunD explExistsN [Clause [sPat, etyPat] - (NormalB$ foldr explExistsAnd (AppE (VarE 'pure) (ConE 'True)) ((`AppE` etyE) . explExistsF <$> sEs)) [] ] - , PragmaD$ InlineP explExistsN Inline FunLike AllPhases + ] - , FunD explMembersN [Clause [sPat] + membersI = InstanceD Nothing (membersT (head vars) : (getT <$> tail vars)) (membersT varTuple) + [ FunD explMembersN [Clause [sPat] (NormalB$ foldl explMembersFold (explMembersF (head sEs)) (explExistsF <$> tail sEs)) [] ] , PragmaD$ InlineP explMembersN Inline FunLike AllPhases - - , FunD explGetN [Clause [sPat, etyPat] - (NormalB$ liftAll tuplE (explGetF <$> sEs)) [] ] - , PragmaD$ InlineP explGetN Inline FunLike AllPhases - - , FunD initStoreN [Clause [] - (NormalB$ liftAll tuplE (VarE initStoreN <$ sEs)) [] ] - , PragmaD$ InlineP initStoreN Inline FunLike AllPhases - ] - return [compI, hasI, strI] + return [compI, hasI, elemI, getI, setI, destroyI, membersI] diff --git a/src/Apecs/Util.hs b/src/Apecs/Util.hs --- a/src/Apecs/Util.hs +++ b/src/Apecs/Util.hs @@ -8,7 +8,7 @@ module Apecs.Util ( -- * Utility - runGC, global, proxy, + runGC, global, -- * EntityCounter EntityCounter, nextEntity, newEntity, @@ -25,6 +25,7 @@ import Control.Applicative (liftA2) import Control.Monad.Reader (liftIO) import Data.Monoid +import Data.Proxy import System.CPUTime import System.Mem (performMajorGC) @@ -36,10 +37,6 @@ global :: Entity global = Entity (-1) --- | Convenience proxy value -proxy :: forall t. t -proxy = error "Proxy value" - -- | Component used by newEntity to track the number of issued entities. -- Automatically added to any world created with @makeWorld@ newtype EntityCounter = EntityCounter {getCounter :: Sum Int} deriving (Monoid, Eq, Show) @@ -57,7 +54,7 @@ -- | Writes the given components to a new entity, and yields that entity. -- The return value is often ignored. {-# INLINE newEntity #-} -newEntity :: (Store (Storage c), Has w c, Has w EntityCounter) +newEntity :: (Set w c, Get w EntityCounter, Set w EntityCounter) => c -> System w Entity newEntity c = do ety <- nextEntity set ety c