packages feed

ecstasy (empty) → 0.1.0.0

raw patch · 8 files changed

+609/−0 lines, 8 filesdep +basedep +containersdep +mtlsetup-changed

Dependencies added: base, containers, mtl, transformers

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for ecstasy++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Sandy Maguire++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 Sandy Maguire 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ecstasy.cabal view
@@ -0,0 +1,44 @@+-- Initial ecstasy.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                ecstasy+version:             0.1.0.0+synopsis:+  A GHC.Generics based entity component system.++description:+  Ecstasy is an entity-component system for Haskell. It's inspired by+  <https://hackage.haskell.org/package/apecs apecs>, but makes the design+  decision to focus on being idiomatic rather than being fast. Maybe. I haven't+  actually benchmarked it.+  .+  We achieve being idiomatic by using 'GHC.Generics' and tricky type families+  to derive performant data stores given only a record of the desired+  components.++license:             BSD3+license-file:        LICENSE+author:              Sandy Maguire+maintainer:          sandy@sandymaguire.me+homepage:            http://github.com/isovector/ecstasy/+bug-reports:         http://github.com/isovector/ecstasy/issues+-- copyright:+category:            Game+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10+tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1++source-repository head+  type: git+  location: https://github.com/isovector/ecstasy.git++library+  exposed-modules: Data.Ecstasy+  other-modules:   Data.Ecstasy.Deriving+                 , Data.Ecstasy.Types+                 , Main+  -- other-extensions:+  build-depends:       base >=4.9 && <4.10, containers, mtl, transformers+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Data/Ecstasy.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DefaultSignatures    #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns         #-}++module Data.Ecstasy+  ( module Data.Ecstasy+  , module Data.Ecstasy.Types+  , Generic+  ) where++import           Control.Arrow (first, second)+import           Control.Monad (mzero, void)+import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Trans.Maybe (runMaybeT)+import           Control.Monad.Trans.Reader (runReaderT, ask)+import           Control.Monad.Trans.State (modify, gets, evalStateT)+import qualified Control.Monad.Trans.State as S+import           Data.Ecstasy.Deriving+import qualified Data.Ecstasy.Types as T+import           Data.Ecstasy.Types hiding (unEnt)+import           Data.Foldable (for_)+import           Data.Functor.Identity (runIdentity)+import           Data.Maybe (catMaybes)+import           Data.Traversable (for)+import           GHC.Generics+++------------------------------------------------------------------------------+-- | This class provides all of the functionality necessary to manipulate the+-- ECS.+class HasWorld world where++  ----------------------------------------------------------------------------+  -- | Fetches an entity from the world given its 'Ent'.+  getEntity+      :: ( Monad m+         )+      => Ent+      -> SystemT world m (world 'FieldOf)+  default getEntity+      :: ( GGetEntity (Rep (world 'WorldOf))+                      (Rep (world 'FieldOf))+         , Generic (world 'FieldOf)+         , Generic (world 'WorldOf)+         , Monad m+         )+      => Ent+      -> SystemT world m (world 'FieldOf)+  getEntity e = do+    w <- gets snd+    pure . to . gGetEntity (from w) $ T.unEnt e++  ----------------------------------------------------------------------------+  -- | Updates an 'Ent' in the world given its setter.+  setEntity+      :: Monad m+      => Ent+      -> world 'SetterOf+      -> SystemT world m ()+  default setEntity+      :: ( GSetEntity (Rep (world 'SetterOf))+                      (Rep (world 'WorldOf))+         , Generic (world 'WorldOf)+         , Generic (world 'SetterOf)+         , Monad m+         )+      => Ent+      -> world 'SetterOf+      -> SystemT world m ()+  setEntity e s = do+    w <- gets snd+    let x = to . gSetEntity (from s) (T.unEnt e) $ from w+    modify . second $ const x++  ----------------------------------------------------------------------------+  -- | Transforms an entity into a setter to transform the default entity into+  -- the given one. Used by 'newEntity'.+  convertSetter+      :: world 'FieldOf+      -> world 'SetterOf+  default convertSetter+      :: ( GConvertSetter (Rep (world 'FieldOf))+                          (Rep (world 'SetterOf))+         , Generic (world 'FieldOf)+         , Generic (world 'SetterOf)+         )+      => world 'FieldOf+      -> world 'SetterOf+  convertSetter = to . gConvertSetter . from++  ----------------------------------------------------------------------------+  -- | The default entity, owning no components.+  defEntity :: world 'FieldOf+  default defEntity+      :: ( Generic (world 'FieldOf)+         , GDefault (Rep (world 'FieldOf))+         )+      => world 'FieldOf+  defEntity = def++  ----------------------------------------------------------------------------+  -- | The default setter, which keeps all components with their previous value.+  defEntity' :: world 'SetterOf+  default defEntity'+      :: ( Generic (world 'SetterOf)+         , GDefault (Rep (world 'SetterOf))+         )+      => world 'SetterOf+  defEntity' = def++  ----------------------------------------------------------------------------+  -- | The default world, which contains only empty containers.+  defWorld :: world 'WorldOf+  default defWorld+      :: ( Generic (world 'WorldOf)+         , GDefault (Rep (world 'WorldOf))+         )+      => world 'WorldOf+  defWorld = def+++instance ( Generic (world 'SetterOf)+         , Generic (world 'WorldOf)+         , Generic (world 'FieldOf)+         , GSetEntity (Rep (world 'SetterOf))+                      (Rep (world 'WorldOf))+         , GGetEntity (Rep (world 'WorldOf))+                      (Rep (world 'FieldOf))+         , GConvertSetter (Rep (world 'FieldOf))+                          (Rep (world 'SetterOf))+         , GDefault (Rep (world 'FieldOf))+         , GDefault (Rep (world 'SetterOf))+         , GDefault (Rep (world 'WorldOf))+         ) => HasWorld world+++------------------------------------------------------------------------------+-- | Retrieve a unique 'Ent'.+nextEntity+    :: Monad m+    => SystemT a m Ent+nextEntity = do+  (e, _) <- S.get+  modify . first . const $ e + 1+  pure $ Ent e+++------------------------------------------------------------------------------+-- | Create a new entity.+newEntity+    :: (HasWorld world, Monad m)+    => world 'FieldOf+    -> SystemT world m Ent+newEntity cs = do+  e <- nextEntity+  setEntity e $ convertSetter cs+  pure e+++------------------------------------------------------------------------------+-- | Evaluate a 'QueryT'.+unQueryT+  :: QueryT world m a+  -> world 'FieldOf+  -> m (Maybe a)+unQueryT = (runMaybeT .) . runReaderT+++------------------------------------------------------------------------------+-- | Map a 'QueryT' transformation over all entites that match it.+emap+    :: ( HasWorld world+       , Monad m+       )+    => QueryT world m (world 'SetterOf)+    -> SystemT world m ()+emap f = do+  (es, _) <- S.get+  for_ [0 .. es - 1] $ \(Ent -> e) -> do+    cs <- getEntity e+    sets <- lift $ unQueryT f cs+    for_ sets $ setEntity e+++------------------------------------------------------------------------------+-- | Collect the results of a monadic computation over every entity matching+-- a 'QueryT'.+efor+    :: ( HasWorld world+       , Monad m+       )+    => (Ent -> QueryT world m a)+    -> SystemT world m [a]+efor f = do+  (es, _) <- S.get+  fmap catMaybes $ for [0 .. es - 1] $ \(Ent -> e) -> do+    cs <- getEntity e+    lift $ unQueryT (f e) cs+++------------------------------------------------------------------------------+-- | Run a 'QueryT' over a particular 'Ent'.+runQueryT+    :: ( HasWorld world+       , Monad m+       )+    => Ent+    -> QueryT world m a+    -> SystemT world m (Maybe a)+runQueryT e qt = do+  cs <- getEntity e+  lift $ unQueryT qt cs+++------------------------------------------------------------------------------+-- | Evaluate a 'SystemT'.+runSystemT+    :: Monad m+    => world 'WorldOf+    -> SystemT world m a+    -> m a+runSystemT = flip evalStateT . (0,)+++------------------------------------------------------------------------------+-- | Evaluate a 'System'.+runSystem+    :: world 'WorldOf+    -> System world a+    -> a+runSystem = (runIdentity .) . runSystemT+++------------------------------------------------------------------------------+-- | Get the world.+getWorld+    :: Monad m+    => SystemT world m (world 'WorldOf)+getWorld = gets snd+++------------------------------------------------------------------------------+-- | Only evaluate this 'QueryT' for entities which have the given component.+with+    :: Monad m+    => (world 'FieldOf -> Maybe a)+    -> QueryT world m ()+with = void . get+++------------------------------------------------------------------------------+-- | Only evaluate this 'QueryT' for entities which do not have the given+-- component.+without+    :: Monad m+    => (world 'FieldOf -> Maybe a)+    -> QueryT world m ()+without f = do+  e <- ask+  maybe (pure ()) (const mzero) $ f e+++------------------------------------------------------------------------------+-- | Get the value of a component, failing the 'QueryT' if it isn't present.+get+    :: Monad m+    => (world 'FieldOf -> Maybe a)+    -> QueryT world m a+get f = do+  e <- ask+  maybe mzero pure $ f e+++------------------------------------------------------------------------------+-- | Attempt to get the value of a component.+getMaybe+    :: Monad m+    => (world 'FieldOf -> Maybe a)+    -> QueryT world m (Maybe a)+getMaybe f = fmap f ask+
+ src/Data/Ecstasy/Deriving.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators         #-}++module Data.Ecstasy.Deriving where++import           Data.Ecstasy.Types (Update (..))+import           Data.IntMap (IntMap)+import qualified Data.IntMap as I+import           GHC.Generics+++class GConvertSetter a b where+  gConvertSetter :: a x -> b x++instance GConvertSetter (K1 i a) (K1 i' (Maybe a)) where+  gConvertSetter (K1 a) = K1 $ Just a+  {-# INLINE gConvertSetter #-}++instance GConvertSetter (K1 i a) (K1 i' (Update a)) where+  gConvertSetter (K1 a) = K1 $ Set a+  {-# INLINE gConvertSetter #-}++instance GConvertSetter (K1 i (Maybe a)) (K1 i' (Update a)) where+  gConvertSetter (K1 (Just a)) = K1 $ Set a+  gConvertSetter (K1 Nothing)  = K1 Unset+  {-# INLINE gConvertSetter #-}++instance GConvertSetter f f' => GConvertSetter (M1 i c f) (M1 i' c' f') where+  gConvertSetter (M1 a) = M1 $ gConvertSetter a+  {-# INLINE gConvertSetter #-}++instance (GConvertSetter a c , GConvertSetter b d) => GConvertSetter (a :*: b) (c :*: d) where+  gConvertSetter (a :*: b) = gConvertSetter a :*: gConvertSetter b+  {-# INLINE gConvertSetter #-}+++class GGetEntity a b where+  gGetEntity :: a x -> Int -> b x++instance GGetEntity (K1 i (IntMap a)) (K1 i' (Maybe a)) where+  gGetEntity (K1 a) e = K1 $ I.lookup e $ a+  {-# INLINE gGetEntity #-}++instance GGetEntity (K1 i (Maybe (Int, a))) (K1 i' (Maybe a)) where+  gGetEntity (K1 (Just (e', a))) e | e == e' = K1 $ Just a+  gGetEntity _ _ = K1 Nothing+  {-# INLINE gGetEntity #-}++instance GGetEntity f f' => GGetEntity (M1 i c f) (M1 i' c' f') where+  gGetEntity (M1 a) e = M1 $ gGetEntity a e+  {-# INLINE gGetEntity #-}++instance (GGetEntity a c , GGetEntity b d) => GGetEntity (a :*: b) (c :*: d) where+  gGetEntity (a :*: b) e = gGetEntity a e :*: gGetEntity b e+  {-# INLINE gGetEntity #-}+++class GSetEntity a b where+  gSetEntity :: a x -> Int -> b x -> b x++instance GSetEntity (K1 i (Update a)) (K1 i' (Maybe (Int, a))) where+  gSetEntity (K1 (Set a)) e _ = K1 $ Just (e, a)+  gSetEntity (K1 Unset) e (K1 (Just (e', b))) =+    if e == e'+       then K1 Nothing+       else K1 $ Just (e', b)+  gSetEntity _  _ (K1 b) = K1 b+  {-# INLINE gSetEntity #-}++instance GSetEntity (K1 i (Update a)) (K1 i' (IntMap a)) where+  gSetEntity (K1 Keep) _ (K1 b) = K1 b+  gSetEntity (K1 (Set a)) e (K1 b) = K1 $ I.alter (const $ Just a) e b+  gSetEntity (K1 Unset) e (K1 b) = K1 $ I.alter (const Nothing) e b+  {-# INLINE gSetEntity #-}++instance GSetEntity f f' => GSetEntity (M1 i c f) (M1 i' c' f') where+  gSetEntity (M1 a) e (M1 b) = M1 $ gSetEntity a e b+  {-# INLINE gSetEntity #-}++instance (GSetEntity a c , GSetEntity b d) => GSetEntity (a :*: b) (c :*: d) where+  gSetEntity (a :*: b) e (c :*: d) = gSetEntity a e c :*: gSetEntity b e d+  {-# INLINE gSetEntity #-}+++def :: (Generic a, GDefault (Rep a)) => a+def = to gdef+{-# INLINE def #-}+++class GDefault f where+  gdef :: f a++instance GDefault U1 where+  gdef = U1+  {-# INLINE gdef #-}++instance GDefault (K1 i (Maybe c)) where+  gdef = K1 Nothing+  {-# INLINE gdef #-}++instance GDefault (K1 i (Update c)) where+  gdef = K1 Keep+  {-# INLINE gdef #-}++instance GDefault (K1 i (IntMap c)) where+  gdef = K1 I.empty+  {-# INLINE gdef #-}++instance GDefault f => GDefault (M1 i c f) where+  gdef = M1 gdef+  {-# INLINE gdef #-}++instance (GDefault a, GDefault b) => GDefault (a :*: b) where+  gdef = gdef :*: gdef+  {-# INLINE gdef #-}+
+ src/Data/Ecstasy/Types.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies   #-}++module Data.Ecstasy.Types where++import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.State (StateT)+import Data.Functor.Identity (Identity)+import Data.IntMap (IntMap)+++------------------------------------------------------------------------------+-- | The key for an entity.+newtype Ent = Ent { unEnt :: Int }+  deriving (Eq, Ord)++instance Show Ent where+  show (Ent e) = "Ent " ++ show e++++------------------------------------------------------------------------------+-- | A monad transformer over an ECS given a world 'w'.+type SystemT w = StateT (Int, w 'WorldOf)++------------------------------------------------------------------------------+-- | A monad over an ECS given a world 'w'.+type System  w = SystemT w Identity++------------------------------------------------------------------------------+-- | A computation to run over a particular entity.+type QueryT w m = ReaderT (w 'FieldOf) (MaybeT m)+++------------------------------------------------------------------------------+-- | Data kind used to parameterize the ECS record.+data StorageType+  = FieldOf   -- ^ Used to construct the actual entity.+  | WorldOf   -- ^ Used to construct the world's storage.+  | SetterOf  -- ^ Used to construct a setter to update an entity.+  deriving (Eq, Ord, Show, Read, Enum, Bounded)+++------------------------------------------------------------------------------+-- | Data kind used to parameterize the fields of the ECS record.+data ComponentType+  = Field   -- ^ This component can be owned by any entity.+  | Unique  -- ^ This component can be owned by only a single entity at a time.+  deriving (Eq, Ord, Show, Read, Enum, Bounded)+++------------------------------------------------------------------------------+-- | Describes how we can change an 'a'.+data Update a+  = Keep   -- ^ Keep the current value.+  | Unset  -- ^ Delete the current value if it exists.+  | Set a  -- ^ Set the current value.+  deriving (Eq, Ord, Show, Read)+++------------------------------------------------------------------------------+-- | A type family to be used in your ECS recrod.+type family Component (s :: StorageType)+                      (c :: ComponentType)+                      (a :: *) :: * where+  Component 'FieldOf  c      a = Maybe a+  Component 'SetterOf c      a = Update a++  Component 'WorldOf 'Field  a = IntMap a+  Component 'WorldOf 'Unique a = Maybe (Int, a)+
+ src/Main.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DataKinds                    #-}+{-# LANGUAGE DeriveGeneric                #-}+{-# LANGUAGE TypeFamilies                 #-}++module Main where++import Data.Ecstasy+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+++main :: IO ()+main = do+  e <- runSystemT defWorld $ do+    void $ newEntity $ defEntity+        { pos = Just 0+        , vel = Just 1+        , ack = Just True+        }++    void $ newEntity $ defEntity+      { pos = Just 0+      , ack = Just False+      }++    let+      step = do+        pos' <- get pos+        vel' <- get vel+        pure $ defEntity'+          { pos = Set $ pos' + vel'+          }+    emap step+    emap step++    efor $ \i -> do+      with ack+      pure $ show i++  print e+--   print $ pos e+--   print $ vel e+--   print $ ack e+++data Entity f = Entity+  { pos :: Component f 'Field  Int+  , vel :: Component f 'Field  Int+  , ack :: Component f 'Unique Bool+  } deriving (Generic)++