diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/ohhecs.cabal b/ohhecs.cabal --- a/ohhecs.cabal +++ b/ohhecs.cabal @@ -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 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 diff --git a/src/Games/ECS.hs b/src/Games/ECS.hs --- a/src/Games/ECS.hs +++ b/src/Games/ECS.hs @@ -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 +-- >>> :{ + +-- :} diff --git a/src/Games/ECS/Component.hs b/src/Games/ECS/Component.hs --- a/src/Games/ECS/Component.hs +++ b/src/Games/ECS/Component.hs @@ -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 diff --git a/src/Games/ECS/Prototype.hs b/src/Games/ECS/Prototype.hs --- a/src/Games/ECS/Prototype.hs +++ b/src/Games/ECS/Prototype.hs @@ -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 diff --git a/src/Games/ECS/Prototype/PrototypeID.hs b/src/Games/ECS/Prototype/PrototypeID.hs new file mode 100644 --- /dev/null +++ b/src/Games/ECS/Prototype/PrototypeID.hs @@ -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 +-- 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 + diff --git a/src/Games/ECS/Prototype/SpawnedFromPrototype.hs b/src/Games/ECS/Prototype/SpawnedFromPrototype.hs new file mode 100644 --- /dev/null +++ b/src/Games/ECS/Prototype/SpawnedFromPrototype.hs @@ -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 +-- 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 + diff --git a/src/Games/ECS/World.hs b/src/Games/ECS/World.hs --- a/src/Games/ECS/World.hs +++ b/src/Games/ECS/World.hs @@ -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) diff --git a/src/Games/ECS/World/TH.hs b/src/Games/ECS/World/TH.hs --- a/src/Games/ECS/World/TH.hs +++ b/src/Games/ECS/World/TH.hs @@ -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