packages feed

ohhecs 0.0.1 → 0.0.2

raw patch · 9 files changed

+236/−110 lines, 9 filesdep −polysemydep −polysemy-plugindep ~xml-conduit

Dependencies removed: polysemy, polysemy-plugin

Dependency ranges changed: xml-conduit

Files

ChangeLog.md view
@@ -1,5 +1,7 @@ Changelog for [`ohhecs` package](https://hackage.haskell.org/package/ohhecs)  # 0.0+## 0.0.2+Switched prototype IDs to be text-based, allowing for a much nicer representation. ## 0.0.1 Initial release.
ohhecs.cabal view
@@ -4,14 +4,15 @@ name:           ohhecs category:       Game Engine, Game synopsis:       An Entity-Component-Systems engine core.-version:        0.0.1+version:        0.0.2 description:    Please see the README on GitLab at <https://gitlab.com/spacekitteh/spaceRL#readme> author:         Sophie Taylor maintainer:     sophie@spacekitteh.moe-copyright:      2020- Sophie Taylor+copyright:      2020-2024 Sophie Taylor license:        AGPL-3.0-or-later license-file:   LICENSE build-type:     Simple+tested-with:    GHC == 9.8.2 extra-doc-files:     README.md     ChangeLog.md@@ -20,18 +21,9 @@   type: git   location: https://gitlab.com/spacekitteh/spaceRL     -flag with_polysemy-   description: Include instances for Polysemy.-   default: False- common config  default-language: GHC2021                          ghc-options: -Werror=deriving-defaults -Werror=unused-packages -Werror=unused-imports -Wsafe -Wtrustworthy-safe -Wunused-packages  -fno-ignore-asserts -foptimal-applicative-do -fsimplifier-phases=4 -flate-specialise -fspec-constr-keen -fspec-constr -fliberate-case -flate-dmd-anal  -Wno-error=inline-rule-shadowing -Wall -Wno-orphans  -Wno-unticked-promoted-constructors -Widentities -Wredundant-constraints- if flag(with_polysemy)-   ghc-options: -fplugin=Polysemy.Plugin-   build-depends:-      polysemy >=1.2.3 && < 1.3-    , polysemy-plugin >= 0.4.5.2 && < 0.5                                 default-extensions:       GADTs@@ -75,7 +67,6 @@   import: config   exposed-modules:       Games.ECS-      --      Games.ECS.Archetype       Games.ECS.Component       Games.ECS.Component.Store       Games.ECS.Component.TH@@ -83,6 +74,8 @@       Games.ECS.MessageQueue       Games.ECS.SaveLoad       Games.ECS.Prototype+      Games.ECS.Prototype.PrototypeID+      Games.ECS.Prototype.SpawnedFromPrototype       Games.ECS.Serialisation       Games.ECS.Slot       Games.ECS.System@@ -96,7 +89,7 @@       --  pkgconfig-depends:       --      zlib, bzip2   build-depends:-      base >=4.19 && <5+      base >=4.18 && <5     , ghc-prim >= 0.11.0 && < 0.12     , byte-order >= 0.1.3 && < 0.2     , assert-failure >= 0.1.3 && < 0.2@@ -110,7 +103,7 @@     , unordered-containers >= 0.2.20 && < 0.3     , ordered-containers >= 0.2.3 && < 0.3     , xml-types >=0.3.8 && < 0.4-    , xml-conduit >= 1.9.1 && < 1.10+    , xml-conduit >= 1.9.1 && <= 1.10     , xml-picklers >= 0.3.6 && < 0.4     , vector-th-unbox >=0.2.2 && < 0.3     , witherable >= 0.4.2 && < 0.5
src/Games/ECS.hs view
@@ -8,6 +8,63 @@ -- Portability: GHC -- -- This is the top-level interface to OhhECS. A brief tutorial should probably go here.+--+-- @+--   +--  import GHC.Generics+--  import Control.Lens+--    +--  data Position = Position Int Int+--    deriving stock (Generic, Eq, Show)+--      +--  instance Num Position where+--   (Position a b) + (Position c d) = Position (a + c) (b + d)+--   (*) = undefined+--   abs = undefined+--   signum = undefined+--   fromInteger = undefined+--   negate = undefined+--     +--  instance 'Component' Position where+--    type 'CanonicalName' Position = "position"+--      +--  'makeHasComponentClass' ''Position+--    +--  data GameWorld s where+--    GameWorld ::+--      'EntRefField' s ->+--      'AComponent' "position" s Position ->+--      GameWorld s+--   deriving stock (Generic)     +--  deriving instance Show (GameWorld Individual)+--  deriving instance Show (GameWorld Storing)+--  deriving instance Eq (GameWorld Individual)+--  deriving instance Eq (GameWorld Storing)    +--  'makeWorld' ''GameWorld   +--   +--  data MovementSystem = MovementSystem deriving (Eq, Show, Generic)+--    +--  instance (UsingPosition worldType Individual, Monad m) => 'System' \"MovementSystem\" MovementSystem worldType m where+--    type 'ComponentFilters' \"MovementSystem\" MovementSystem worldType m = (UsingPosition worldType Individual)   +--    'runSystem' world = traverseOf ('entitiesWith' (withPosition)) processCritter world+--      where+--        processCritter :: worldType 'Individual' -> m (worldType 'Individual')+--        processCritter oldCritter = do+--          let newCritter = oldCritter & position .~ (Position 1 0)+--          pure newCritter+--            +--  someEntity :: GameWorld 'Individual'+--  someEntity = ('createNewEntityWithRef' ('EntRef' 123))  & addPosition .~ Position 4 5+--    +--  myWorld :: GameWorld 'Storing'+--  myWorld = newWorld & 'storeEntity' someEntity+--    +--  changed :: IO (GameWorld 'Storing')+--  changed = 'runSystem' @\"MovementSystem\" myWorld+--+-- @+--+ module Games.ECS   ( module Games.ECS,     module Games.ECS.Util.Misc,@@ -22,6 +79,8 @@     module Games.ECS.System,     module Games.ECS.Slot,     module Games.ECS.Prototype,+    module Games.ECS.Prototype.PrototypeID,+    module Games.ECS.Prototype.SpawnedFromPrototype,     module Games.ECS.MessageQueue,   ) where@@ -33,6 +92,8 @@ import Games.ECS.Entity import Games.ECS.MessageQueue import Games.ECS.Prototype+import Games.ECS.Prototype.PrototypeID+import Games.ECS.Prototype.SpawnedFromPrototype     import Games.ECS.SaveLoad import Games.ECS.Serialisation import Games.ECS.Slot@@ -43,3 +104,9 @@  -- | A filter over entities in a world is just an `IndexedTraversal'` that preserves the selection predicate. type EntityFilter worldType = IndexedTraversal' Entity (worldType Storing) (worldType Individual)+++-- $setup+-- >>> :{   ++-- :}
src/Games/ECS/Component.hs view
@@ -102,6 +102,14 @@  type ComponentReference (name :: Symbol) c = (Component c) => TaggedComponent name Entity ++++++++ -- | A component comprised of multiple other components. class (Component c) => CompositeComponent c where   type SubComponentIndex c :: Type
src/Games/ECS/Prototype.hs view
@@ -11,41 +11,20 @@ -- Portability: GHC -- -- Prototypes are exemplar individuals which form a template.-module Games.ECS.Prototype where+module Games.ECS.Prototype (module Games.ECS.Prototype, module Games.ECS.Prototype.PrototypeID) where -import Control.Exception.Assert.Sugar-import Control.Lens-import Control.Monad.IO.Class-import Data.Coerce-import Data.HashMap.Strict qualified as HMS-import Data.Hashable-import Data.Ix-import Data.Vector.Unboxed.Deriving-import GHC.Generics-import Games.ECS.Component-import Games.ECS.Component.TH-import Games.ECS.Entity-import Games.ECS.Serialisation-import Games.ECS.World --- | A prototype's ID is distinct from its entity reference in that it is stable, and in a unique namespace.-newtype PrototypeID = PrototypeID {_unPrototypeID :: Int}-  deriving newtype (Eq, Ord, Enum, Bounded, Ix)-  deriving newtype (XMLPickleAsAttribute)-  deriving stock (Generic)-  deriving newtype (Hashable)--makeClassy ''PrototypeID+import Control.Lens -instance Show PrototypeID where-  {-# INLINE show #-}-  show (PrototypeID ref) = "Prototype ID: " ++ show ref+--import Data.Coerce -derivingUnbox-  "PrototypeID"-  [t|PrototypeID -> Int|]-  [|coerce|]-  [|coerce|]+--import Data.Ix+--import Data.Vector.Unboxed.Deriving+import GHC.Generics+import Games.ECS.Serialisation+import Games.ECS.Prototype.PrototypeID+import Games.ECS.Component.TH+import Games.ECS.Component  -- | A component for denoting that an individual is a prototype, to be instantiated later. data IsPrototype = IsPrototype@@ -76,72 +55,8 @@           )       ) --- | Marks an entity as being spawned from a prototype.-data SpawnedFromPrototype = SpawnedFromPrototype-  { -- | The raw `Entity ` which it is spawned from.-    _prototypeEntity :: !Entity,-    -- | The t`PrototypeID` it is spawned from.-    _spawnedFromPrototypeID :: Maybe PrototypeID-  }-  deriving stock (Eq, Generic, Show)--makeLenses ''SpawnedFromPrototype--instance {-# OVERLAPS #-} XMLPickler [Node] SpawnedFromPrototype where-  {-# INLINE xpickle #-}-  xpickle =-    xpWrap-      (\(pEnt, pid) -> SpawnedFromPrototype pEnt pid)-      (\(SpawnedFromPrototype pEnt pid) -> (pEnt, pid))-      ( xpElemAttrs-          "spawnedFromPrototype"-          ( xpPair-              (pickleAsAttribute "entRef")-              (pickleAsAttribute "prototypeID")-          )-      )- instance Component IsPrototype where   type CanonicalName IsPrototype = "isPrototype" -makeHasComponentClass ''IsPrototype -instance Component SpawnedFromPrototype where-  type CanonicalName SpawnedFromPrototype = "spawnedFromPrototype"--makeHasComponentClass ''SpawnedFromPrototype--{-# INLINEABLE spawnPrototype #-}---- | Spawn a new individual with the given prototype `Entity` reference. Returns the new individual, and the new world.-spawnPrototype :: (UsingSpawnedFromPrototype w Individual, UsingIsPrototype w Individual, MonadIO m) => Entity -> w Storing -> m (Maybe (w Individual, w Storing))-spawnPrototype proto world = do-  let protoCritter = lookupEntity world proto-  case protoCritter of-    Nothing -> pure Nothing-    Just critter -> do-      let protoID = critter ^? isPrototype . prototypeID-      newID <- liftIO newUniqueEntRef-      let newCritter = critter & unsafeEntityReference .~ newID & addSpawnedFromPrototype .~ SpawnedFromPrototype proto protoID & removeIsPrototype-          updatedWorld = world & storeEntity newCritter-      pure (Just (newCritter, updatedWorld))---- | A dictionary between a t`PrototypeID` and the characterising `Entity`.-type PrototypeNameMap = HMS.HashMap PrototypeID Entity---- | Spawns a new individual with a given t`PrototypeID`, which is looked up in the associated map. Returns the new individual, and the new world.-{-# INLINEABLE spawnNamedPrototype #-}-spawnNamedPrototype :: (UsingSpawnedFromPrototype w Individual, UsingIsPrototype w Individual, MonadIO m) => PrototypeNameMap -> PrototypeID -> w Storing -> m (Maybe (w Individual, w Storing))-spawnNamedPrototype prototypeMap proto world = do-  case prototypeMap ^? ix proto of-    Nothing -> assert (False `blame` "Prototype ID doesn't exist!" `swith` proto) (pure Nothing)-    Just ent -> do-      spawned <- spawnPrototype ent world-      case spawned of-        Nothing -> assert (False `blame` ("Prototype ID " ++ show proto ++ " existed, but the entity it refers to doesn't!") `swith` ent) (pure Nothing)-        Just m -> pure (Just m)---- | All the prototypical individuals in a world.-{-# INLINE prototypes #-}-prototypes :: (HasIsPrototype w) => IndexedTraversal' Entity (w Storing) (w Individual)-prototypes = entitiesWith withIsPrototype+makeHasComponentClass ''IsPrototype
+ src/Games/ECS/Prototype/PrototypeID.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+-- |+-- Module      :  Games.ECS.Prototype.PrototypeID+-- Description : Prototype definitions+-- Copyright   :  (C) 2020 Sophie Taylor+-- License     :  AGPL-3.0-or-later+-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>+-- Stability   :  experimental+-- Portability: GHC+--+-- Prototype IDs are essentially just strings.++module Games.ECS.Prototype.PrototypeID where++import Games.ECS.Serialisation+import Control.Lens    +import Data.Interned.Text+import Data.Hashable+import GHC.Generics    +import Data.String++-- | A prototype's ID is distinct from its entity reference in that it is stable, and in a unique namespace.+newtype PrototypeID = PrototypeID {_unPrototypeID :: InternedText}+  deriving newtype (Eq, Ord, Show)+  deriving newtype (XMLPickleAsAttribute)+  deriving stock (Generic)+  deriving newtype (Hashable)+  deriving newtype IsString+makeClassy ''PrototypeID+++instance {-# OVERLAPS #-} XMLPickler [Node] PrototypeID where+  {-# INLINE xpickle #-}+  xpickle =+    xpWrap+      PrototypeID+      _unPrototypeID+      xpickle+
+ src/Games/ECS/Prototype/SpawnedFromPrototype.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+-- |+-- Module      :  Games.ECS.Prototype.SpawnedFromPrototype+-- Description : Prototype definitions+-- Copyright   :  (C) 2020 Sophie Taylor+-- License     :  AGPL-3.0-or-later+-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>+-- Stability   :  experimental+-- Portability: GHC+--+-- A component to mark an entity as being spawned from a prototype.+module Games.ECS.Prototype.SpawnedFromPrototype where++import Control.Exception.Assert.Sugar      +import Games.ECS.World+import Control.Monad.IO.Class++import Games.ECS.Prototype    ++import Games.ECS.Serialisation+import Games.ECS.Entity+import Games.ECS.Component+import Games.ECS.Component.TH+import GHC.Generics+import Control.Lens    ++-- | Marks an entity as being spawned from a prototype.+data SpawnedFromPrototype = SpawnedFromPrototype+  { -- | The raw `Entity ` which it is spawned from.+    _prototypeEntity :: !Entity,+    -- | The t`PrototypeID` it is spawned from.+    _spawnedFromPrototypeID :: Maybe PrototypeID+  }+  deriving stock (Eq, Generic, Show)++makeLenses ''SpawnedFromPrototype++instance {-# OVERLAPS #-} XMLPickler [Node] SpawnedFromPrototype where+  {-# INLINE xpickle #-}+  xpickle =+    xpWrap+      (\(pEnt, pid) -> SpawnedFromPrototype pEnt pid)+      (\(SpawnedFromPrototype pEnt pid) -> (pEnt, pid))+      ( xpElemAttrs+          "spawnedFromPrototype"+          ( xpPair+              (pickleAsAttribute "entRef")+              (pickleAsAttribute "prototypeID")+          )+      )+++    +instance Component SpawnedFromPrototype where+  type CanonicalName SpawnedFromPrototype = "spawnedFromPrototype"++makeHasComponentClass ''SpawnedFromPrototype++{-# INLINEABLE spawnPrototype #-}++-- | Spawn a new individual with the given prototype `Entity` reference. Returns the new individual, and the new world.+spawnPrototype :: (UsingSpawnedFromPrototype w Individual, UsingIsPrototype w Individual, MonadIO m) => Entity -> w Storing -> m (Maybe (w Individual, w Storing))+spawnPrototype proto world = do+  let protoCritter = lookupEntity world proto+  case protoCritter of+    Nothing -> pure Nothing+    Just critter -> do+      let protoID = critter ^? isPrototype . prototypeID+      newID <- liftIO newUniqueEntRef+      let newCritter = critter & unsafeEntityReference .~ newID & addSpawnedFromPrototype .~ SpawnedFromPrototype proto protoID & removeIsPrototype+          updatedWorld = world & storeEntity newCritter+      pure (Just (newCritter, updatedWorld))++-- | Spawns a new individual with a given t`PrototypeID`, which is looked up in the associated map. Returns the new individual, and the new world.+{-# INLINEABLE spawnNamedPrototype #-}+spawnNamedPrototype :: (UsingSpawnedFromPrototype w Individual, UsingIsPrototype w Individual,MonadIO m) => PrototypeID -> w Storing -> m (Maybe (w Individual, w Storing))+spawnNamedPrototype prototypeName world = do+  let proto = world ^? prototype prototypeName . entityReference+  case proto of+    Nothing -> assert (False `blame` "Prototype ID doesn't exist!" `swith` proto) (pure Nothing)+    Just ent -> do+      spawned <- spawnPrototype ent world+      case spawned of+        Nothing -> assert (False `blame` ("Prototype ID " ++ show proto ++ " existed, but the entity it refers to doesn't!") `swith` ent) (pure Nothing)+        Just m -> pure (Just m)++-- | All the prototypical individuals in a world.+{-# INLINE prototypes #-}+prototypes :: (HasIsPrototype w) => IndexedTraversal' Entity (w Storing) (w Individual)+prototypes = entitiesWith withIsPrototype+
src/Games/ECS/World.hs view
@@ -36,6 +36,7 @@ import GHC.Base import GHC.Num import Games.ECS.Entity+import Games.ECS.Prototype.PrototypeID     import Games.ECS.Slot import System.IO.Unsafe (unsafePerformIO) @@ -101,6 +102,9 @@   -- | Check if a given entity exists in the world, and if so, return the individual.   lookupEntity :: w Storing -> Entity -> Maybe (w Individual) +  -- | Get a prototype specification from its name.+  prototype :: HasPrototypeID p => p -> AffineTraversal' (w Storing) (w Individual)+                     -- | An IndexedTraversal' which returns the individuals associated to the entities given as input.   {-# INLINE lookupEntities #-}   lookupEntities :: forall f p fol. (Indexable Entity p, Applicative f, Foldable fol) => fol Entity -> p (w Individual) (f (w Individual)) -> w Storing -> f (w Storing) -- Foldable f => f Entity -> IndexedTraversal' Entity (w Storing) (w Individual)
src/Games/ECS/World/TH.hs view
@@ -25,6 +25,7 @@ import Data.Kind qualified as DK import Data.List (findIndex) import GHC.Generics+import Games.ECS.Prototype import Games.ECS.Component import Games.ECS.Component.TH.Internal import Games.ECS.Entity@@ -196,6 +197,10 @@         entityReferences :: IndexedFold Entity ($worldType Storing) Entity         entityReferences = conjoined ((typed @(EntRefField Storing) @($worldType Storing)) . knownEntities) ((typed @(EntRefField Storing) @($worldType Storing)) . knownEntities . selfIndex) +        {-# INLINE prototype #-}                           +        prototype :: HasPrototypeID p => p -> AffineTraversal' ($worldType Storing) ($worldType Individual)+        prototype p = (entitiesWith withIsPrototype) . filtered (\c -> c ^?! isPrototype . prototypeID == (p^.prototypeID))+                                    {-# INLINE lookupEntities #-}         lookupEntities :: forall f p fol. (Indexable Entity p, Applicative f, Foldable fol) => fol Entity -> p ($worldType Individual) (f ($worldType Individual)) -> $worldType Storing -> f ($worldType Storing)         lookupEntities ents' = conjoined normalVer indexedVer