{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- Module      :  Games.ECS.Prototype
-- Description : Prototype definitions
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Prototypes are exemplar individuals which form a template.
module Games.ECS.Prototype 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 {PrototypeID -> Int
_unPrototypeID :: Int}
  deriving newtype (PrototypeID -> PrototypeID -> Bool
(PrototypeID -> PrototypeID -> Bool)
-> (PrototypeID -> PrototypeID -> Bool) -> Eq PrototypeID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrototypeID -> PrototypeID -> Bool
== :: PrototypeID -> PrototypeID -> Bool
$c/= :: PrototypeID -> PrototypeID -> Bool
/= :: PrototypeID -> PrototypeID -> Bool
Eq, Eq PrototypeID
Eq PrototypeID =>
(PrototypeID -> PrototypeID -> Ordering)
-> (PrototypeID -> PrototypeID -> Bool)
-> (PrototypeID -> PrototypeID -> Bool)
-> (PrototypeID -> PrototypeID -> Bool)
-> (PrototypeID -> PrototypeID -> Bool)
-> (PrototypeID -> PrototypeID -> PrototypeID)
-> (PrototypeID -> PrototypeID -> PrototypeID)
-> Ord PrototypeID
PrototypeID -> PrototypeID -> Bool
PrototypeID -> PrototypeID -> Ordering
PrototypeID -> PrototypeID -> PrototypeID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PrototypeID -> PrototypeID -> Ordering
compare :: PrototypeID -> PrototypeID -> Ordering
$c< :: PrototypeID -> PrototypeID -> Bool
< :: PrototypeID -> PrototypeID -> Bool
$c<= :: PrototypeID -> PrototypeID -> Bool
<= :: PrototypeID -> PrototypeID -> Bool
$c> :: PrototypeID -> PrototypeID -> Bool
> :: PrototypeID -> PrototypeID -> Bool
$c>= :: PrototypeID -> PrototypeID -> Bool
>= :: PrototypeID -> PrototypeID -> Bool
$cmax :: PrototypeID -> PrototypeID -> PrototypeID
max :: PrototypeID -> PrototypeID -> PrototypeID
$cmin :: PrototypeID -> PrototypeID -> PrototypeID
min :: PrototypeID -> PrototypeID -> PrototypeID
Ord, Int -> PrototypeID
PrototypeID -> Int
PrototypeID -> [PrototypeID]
PrototypeID -> PrototypeID
PrototypeID -> PrototypeID -> [PrototypeID]
PrototypeID -> PrototypeID -> PrototypeID -> [PrototypeID]
(PrototypeID -> PrototypeID)
-> (PrototypeID -> PrototypeID)
-> (Int -> PrototypeID)
-> (PrototypeID -> Int)
-> (PrototypeID -> [PrototypeID])
-> (PrototypeID -> PrototypeID -> [PrototypeID])
-> (PrototypeID -> PrototypeID -> [PrototypeID])
-> (PrototypeID -> PrototypeID -> PrototypeID -> [PrototypeID])
-> Enum PrototypeID
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: PrototypeID -> PrototypeID
succ :: PrototypeID -> PrototypeID
$cpred :: PrototypeID -> PrototypeID
pred :: PrototypeID -> PrototypeID
$ctoEnum :: Int -> PrototypeID
toEnum :: Int -> PrototypeID
$cfromEnum :: PrototypeID -> Int
fromEnum :: PrototypeID -> Int
$cenumFrom :: PrototypeID -> [PrototypeID]
enumFrom :: PrototypeID -> [PrototypeID]
$cenumFromThen :: PrototypeID -> PrototypeID -> [PrototypeID]
enumFromThen :: PrototypeID -> PrototypeID -> [PrototypeID]
$cenumFromTo :: PrototypeID -> PrototypeID -> [PrototypeID]
enumFromTo :: PrototypeID -> PrototypeID -> [PrototypeID]
$cenumFromThenTo :: PrototypeID -> PrototypeID -> PrototypeID -> [PrototypeID]
enumFromThenTo :: PrototypeID -> PrototypeID -> PrototypeID -> [PrototypeID]
Enum, PrototypeID
PrototypeID -> PrototypeID -> Bounded PrototypeID
forall a. a -> a -> Bounded a
$cminBound :: PrototypeID
minBound :: PrototypeID
$cmaxBound :: PrototypeID
maxBound :: PrototypeID
Bounded, Ord PrototypeID
Ord PrototypeID =>
((PrototypeID, PrototypeID) -> [PrototypeID])
-> ((PrototypeID, PrototypeID) -> PrototypeID -> Int)
-> ((PrototypeID, PrototypeID) -> PrototypeID -> Int)
-> ((PrototypeID, PrototypeID) -> PrototypeID -> Bool)
-> ((PrototypeID, PrototypeID) -> Int)
-> ((PrototypeID, PrototypeID) -> Int)
-> Ix PrototypeID
(PrototypeID, PrototypeID) -> Int
(PrototypeID, PrototypeID) -> [PrototypeID]
(PrototypeID, PrototypeID) -> PrototypeID -> Bool
(PrototypeID, PrototypeID) -> PrototypeID -> Int
forall a.
Ord a =>
((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
$crange :: (PrototypeID, PrototypeID) -> [PrototypeID]
range :: (PrototypeID, PrototypeID) -> [PrototypeID]
$cindex :: (PrototypeID, PrototypeID) -> PrototypeID -> Int
index :: (PrototypeID, PrototypeID) -> PrototypeID -> Int
$cunsafeIndex :: (PrototypeID, PrototypeID) -> PrototypeID -> Int
unsafeIndex :: (PrototypeID, PrototypeID) -> PrototypeID -> Int
$cinRange :: (PrototypeID, PrototypeID) -> PrototypeID -> Bool
inRange :: (PrototypeID, PrototypeID) -> PrototypeID -> Bool
$crangeSize :: (PrototypeID, PrototypeID) -> Int
rangeSize :: (PrototypeID, PrototypeID) -> Int
$cunsafeRangeSize :: (PrototypeID, PrototypeID) -> Int
unsafeRangeSize :: (PrototypeID, PrototypeID) -> Int
Ix)
  deriving newtype (Name -> PU [Attribute] PrototypeID
(Name -> PU [Attribute] PrototypeID)
-> XMLPickleAsAttribute PrototypeID
forall a. (Name -> PU [Attribute] a) -> XMLPickleAsAttribute a
$cpickleAsAttribute :: Name -> PU [Attribute] PrototypeID
pickleAsAttribute :: Name -> PU [Attribute] PrototypeID
XMLPickleAsAttribute)
  deriving stock ((forall x. PrototypeID -> Rep PrototypeID x)
-> (forall x. Rep PrototypeID x -> PrototypeID)
-> Generic PrototypeID
forall x. Rep PrototypeID x -> PrototypeID
forall x. PrototypeID -> Rep PrototypeID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PrototypeID -> Rep PrototypeID x
from :: forall x. PrototypeID -> Rep PrototypeID x
$cto :: forall x. Rep PrototypeID x -> PrototypeID
to :: forall x. Rep PrototypeID x -> PrototypeID
Generic)
  deriving newtype (Eq PrototypeID
Eq PrototypeID =>
(Int -> PrototypeID -> Int)
-> (PrototypeID -> Int) -> Hashable PrototypeID
Int -> PrototypeID -> Int
PrototypeID -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> PrototypeID -> Int
hashWithSalt :: Int -> PrototypeID -> Int
$chash :: PrototypeID -> Int
hash :: PrototypeID -> Int
Hashable)

makeClassy ''PrototypeID

instance Show PrototypeID where
  {-# INLINE show #-}
  show :: PrototypeID -> String
show (PrototypeID Int
ref) = String
"Prototype ID: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ref

derivingUnbox
  "PrototypeID"
  [t|PrototypeID -> Int|]
  [|coerce|]
  [|coerce|]

-- | A component for denoting that an individual is a prototype, to be instantiated later.
data IsPrototype = IsPrototype
  { -- | The t'PrototypeID'.
    IsPrototype -> PrototypeID
_rawIsPrototypeID :: !PrototypeID,
    -- | Indicates that this extends --- and overrides, in case of conflicting values --- another prototype.
    IsPrototype -> Maybe PrototypeID
_extendsPrototype :: Maybe PrototypeID
  }
  deriving stock (IsPrototype -> IsPrototype -> Bool
(IsPrototype -> IsPrototype -> Bool)
-> (IsPrototype -> IsPrototype -> Bool) -> Eq IsPrototype
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsPrototype -> IsPrototype -> Bool
== :: IsPrototype -> IsPrototype -> Bool
$c/= :: IsPrototype -> IsPrototype -> Bool
/= :: IsPrototype -> IsPrototype -> Bool
Eq, (forall x. IsPrototype -> Rep IsPrototype x)
-> (forall x. Rep IsPrototype x -> IsPrototype)
-> Generic IsPrototype
forall x. Rep IsPrototype x -> IsPrototype
forall x. IsPrototype -> Rep IsPrototype x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IsPrototype -> Rep IsPrototype x
from :: forall x. IsPrototype -> Rep IsPrototype x
$cto :: forall x. Rep IsPrototype x -> IsPrototype
to :: forall x. Rep IsPrototype x -> IsPrototype
Generic, Int -> IsPrototype -> ShowS
[IsPrototype] -> ShowS
IsPrototype -> String
(Int -> IsPrototype -> ShowS)
-> (IsPrototype -> String)
-> ([IsPrototype] -> ShowS)
-> Show IsPrototype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsPrototype -> ShowS
showsPrec :: Int -> IsPrototype -> ShowS
$cshow :: IsPrototype -> String
show :: IsPrototype -> String
$cshowList :: [IsPrototype] -> ShowS
showList :: [IsPrototype] -> ShowS
Show)

makeLenses ''IsPrototype

instance HasPrototypeID IsPrototype where
  {-# INLINE prototypeID #-}
  prototypeID :: Lens' IsPrototype PrototypeID
prototypeID = (PrototypeID -> f PrototypeID) -> IsPrototype -> f IsPrototype
Lens' IsPrototype PrototypeID
rawIsPrototypeID

instance {-# OVERLAPS #-} XMLPickler [Node] IsPrototype where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] IsPrototype
xpickle =
    ((PrototypeID, Maybe PrototypeID) -> IsPrototype)
-> (IsPrototype -> (PrototypeID, Maybe PrototypeID))
-> PU [Node] (PrototypeID, Maybe PrototypeID)
-> PU [Node] IsPrototype
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap
      (\(PrototypeID
pid, Maybe PrototypeID
epid) -> PrototypeID -> Maybe PrototypeID -> IsPrototype
IsPrototype PrototypeID
pid Maybe PrototypeID
epid)
      (\(IsPrototype PrototypeID
pid Maybe PrototypeID
epid) -> (PrototypeID
pid, Maybe PrototypeID
epid))
      ( Name
-> PU [Attribute] (PrototypeID, Maybe PrototypeID)
-> PU [Node] (PrototypeID, Maybe PrototypeID)
forall b. Name -> PU [Attribute] b -> PU [Node] b
xpElemAttrs
          Name
"prototype"
          ( PU [Attribute] PrototypeID
-> PU [Attribute] (Maybe PrototypeID)
-> PU [Attribute] (PrototypeID, Maybe PrototypeID)
forall a b1 b2. PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)
xpPair
              (Name -> PU [Attribute] PrototypeID
forall a. XMLPickleAsAttribute a => Name -> PU [Attribute] a
pickleAsAttribute Name
"prototypeID")
              (Name -> PU [Attribute] (Maybe PrototypeID)
forall a. XMLPickleAsAttribute a => Name -> PU [Attribute] a
pickleAsAttribute Name
"extends")
          )
      )

-- | Marks an entity as being spawned from a prototype.
data SpawnedFromPrototype = SpawnedFromPrototype
  { -- | The raw `Entity ` which it is spawned from.
    SpawnedFromPrototype -> Entity
_prototypeEntity :: !Entity,
    -- | The t`PrototypeID` it is spawned from.
    SpawnedFromPrototype -> Maybe PrototypeID
_spawnedFromPrototypeID :: Maybe PrototypeID
  }
  deriving stock (SpawnedFromPrototype -> SpawnedFromPrototype -> Bool
(SpawnedFromPrototype -> SpawnedFromPrototype -> Bool)
-> (SpawnedFromPrototype -> SpawnedFromPrototype -> Bool)
-> Eq SpawnedFromPrototype
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpawnedFromPrototype -> SpawnedFromPrototype -> Bool
== :: SpawnedFromPrototype -> SpawnedFromPrototype -> Bool
$c/= :: SpawnedFromPrototype -> SpawnedFromPrototype -> Bool
/= :: SpawnedFromPrototype -> SpawnedFromPrototype -> Bool
Eq, (forall x. SpawnedFromPrototype -> Rep SpawnedFromPrototype x)
-> (forall x. Rep SpawnedFromPrototype x -> SpawnedFromPrototype)
-> Generic SpawnedFromPrototype
forall x. Rep SpawnedFromPrototype x -> SpawnedFromPrototype
forall x. SpawnedFromPrototype -> Rep SpawnedFromPrototype x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SpawnedFromPrototype -> Rep SpawnedFromPrototype x
from :: forall x. SpawnedFromPrototype -> Rep SpawnedFromPrototype x
$cto :: forall x. Rep SpawnedFromPrototype x -> SpawnedFromPrototype
to :: forall x. Rep SpawnedFromPrototype x -> SpawnedFromPrototype
Generic, Int -> SpawnedFromPrototype -> ShowS
[SpawnedFromPrototype] -> ShowS
SpawnedFromPrototype -> String
(Int -> SpawnedFromPrototype -> ShowS)
-> (SpawnedFromPrototype -> String)
-> ([SpawnedFromPrototype] -> ShowS)
-> Show SpawnedFromPrototype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpawnedFromPrototype -> ShowS
showsPrec :: Int -> SpawnedFromPrototype -> ShowS
$cshow :: SpawnedFromPrototype -> String
show :: SpawnedFromPrototype -> String
$cshowList :: [SpawnedFromPrototype] -> ShowS
showList :: [SpawnedFromPrototype] -> ShowS
Show)

makeLenses ''SpawnedFromPrototype

instance {-# OVERLAPS #-} XMLPickler [Node] SpawnedFromPrototype where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] SpawnedFromPrototype
xpickle =
    ((Entity, Maybe PrototypeID) -> SpawnedFromPrototype)
-> (SpawnedFromPrototype -> (Entity, Maybe PrototypeID))
-> PU [Node] (Entity, Maybe PrototypeID)
-> PU [Node] SpawnedFromPrototype
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap
      (\(Entity
pEnt, Maybe PrototypeID
pid) -> Entity -> Maybe PrototypeID -> SpawnedFromPrototype
SpawnedFromPrototype Entity
pEnt Maybe PrototypeID
pid)
      (\(SpawnedFromPrototype Entity
pEnt Maybe PrototypeID
pid) -> (Entity
pEnt, Maybe PrototypeID
pid))
      ( Name
-> PU [Attribute] (Entity, Maybe PrototypeID)
-> PU [Node] (Entity, Maybe PrototypeID)
forall b. Name -> PU [Attribute] b -> PU [Node] b
xpElemAttrs
          Name
"spawnedFromPrototype"
          ( PU [Attribute] Entity
-> PU [Attribute] (Maybe PrototypeID)
-> PU [Attribute] (Entity, Maybe PrototypeID)
forall a b1 b2. PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)
xpPair
              (Name -> PU [Attribute] Entity
forall a. XMLPickleAsAttribute a => Name -> PU [Attribute] a
pickleAsAttribute Name
"entRef")
              (Name -> PU [Attribute] (Maybe PrototypeID)
forall a. XMLPickleAsAttribute a => Name -> PU [Attribute] a
pickleAsAttribute Name
"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 :: forall (w :: Access -> *) (m :: * -> *).
(UsingSpawnedFromPrototype w 'Individual,
 UsingIsPrototype w 'Individual, MonadIO m) =>
Entity -> w 'Storing -> m (Maybe (w 'Individual, w 'Storing))
spawnPrototype Entity
proto w 'Storing
world = do
  let protoCritter :: Maybe (w 'Individual)
protoCritter = w 'Storing -> Entity -> Maybe (w 'Individual)
forall (w :: Access -> *).
World w =>
w 'Storing -> Entity -> Maybe (w 'Individual)
lookupEntity w 'Storing
world Entity
proto
  case Maybe (w 'Individual)
protoCritter of
    Maybe (w 'Individual)
Nothing -> Maybe (w 'Individual, w 'Storing)
-> m (Maybe (w 'Individual, w 'Storing))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (w 'Individual, w 'Storing)
forall a. Maybe a
Nothing
    Just w 'Individual
critter -> do
      let protoID :: Maybe PrototypeID
protoID = w 'Individual
critter w 'Individual
-> Getting (First PrototypeID) (w 'Individual) PrototypeID
-> Maybe PrototypeID
forall s a. s -> Getting (First a) s a -> Maybe a
^? (IsPrototype -> Const (First PrototypeID) IsPrototype)
-> w 'Individual -> Const (First PrototypeID) (w 'Individual)
forall {s :: Access}.
(EntityProperty "isPrototype" w s (Prop IsPrototype) IsPrototype,
 OpticsFor "isPrototype" w s (Prop IsPrototype) IsPrototype
 ~ ReifiedIndexedTraversal' Entity (w s) IsPrototype) =>
IndexedTraversal' Entity (w s) IsPrototype
IndexedTraversal' Entity (w 'Individual) IsPrototype
forall (worldType :: Access -> *) {s :: Access}.
(HasIsPrototype worldType,
 (EntityProperty
    "isPrototype" worldType s (Prop IsPrototype) IsPrototype,
  OpticsFor "isPrototype" worldType s (Prop IsPrototype) IsPrototype
  ~ ReifiedIndexedTraversal' Entity (worldType s) IsPrototype)) =>
IndexedTraversal' Entity (worldType s) IsPrototype
isPrototype ((IsPrototype -> Const (First PrototypeID) IsPrototype)
 -> w 'Individual -> Const (First PrototypeID) (w 'Individual))
-> ((PrototypeID -> Const (First PrototypeID) PrototypeID)
    -> IsPrototype -> Const (First PrototypeID) IsPrototype)
-> Getting (First PrototypeID) (w 'Individual) PrototypeID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrototypeID -> Const (First PrototypeID) PrototypeID)
-> IsPrototype -> Const (First PrototypeID) IsPrototype
forall c. HasPrototypeID c => Lens' c PrototypeID
Lens' IsPrototype PrototypeID
prototypeID
      Entity
newID <- IO Entity -> m Entity
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Entity
newUniqueEntRef
      let newCritter :: w 'Individual
newCritter = w 'Individual
critter w 'Individual -> (w 'Individual -> w 'Individual) -> w 'Individual
forall a b. a -> (a -> b) -> b
& (Entity -> Identity Entity)
-> w 'Individual -> Identity (w 'Individual)
Lens' (w 'Individual) Entity
forall (w :: Access -> *). World w => Lens' (w 'Individual) Entity
unsafeEntityReference ((Entity -> Identity Entity)
 -> w 'Individual -> Identity (w 'Individual))
-> Entity -> w 'Individual -> w 'Individual
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Entity
newID w 'Individual -> (w 'Individual -> w 'Individual) -> w 'Individual
forall a b. a -> (a -> b) -> b
& (SpawnedFromPrototype -> Identity SpawnedFromPrototype)
-> w 'Individual -> Identity (w 'Individual)
IndexedSetter' Entity (w 'Individual) SpawnedFromPrototype
forall (worldType :: Access -> *).
HasSpawnedFromPrototype worldType =>
IndexedSetter' Entity (worldType 'Individual) SpawnedFromPrototype
addSpawnedFromPrototype ((SpawnedFromPrototype -> Identity SpawnedFromPrototype)
 -> w 'Individual -> Identity (w 'Individual))
-> SpawnedFromPrototype -> w 'Individual -> w 'Individual
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Entity -> Maybe PrototypeID -> SpawnedFromPrototype
SpawnedFromPrototype Entity
proto Maybe PrototypeID
protoID w 'Individual -> (w 'Individual -> w 'Individual) -> w 'Individual
forall a b. a -> (a -> b) -> b
& w 'Individual -> w 'Individual
forall (worldType :: Access -> *).
HasIsPrototype worldType =>
worldType 'Individual -> worldType 'Individual
removeIsPrototype
          updatedWorld :: w 'Storing
updatedWorld = w 'Storing
world w 'Storing -> (w 'Storing -> w 'Storing) -> w 'Storing
forall a b. a -> (a -> b) -> b
& w 'Individual -> w 'Storing -> w 'Storing
forall (w :: Access -> *).
World w =>
w 'Individual -> w 'Storing -> w 'Storing
storeEntity w 'Individual
newCritter
      Maybe (w 'Individual, w 'Storing)
-> m (Maybe (w 'Individual, w 'Storing))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((w 'Individual, w 'Storing) -> Maybe (w 'Individual, w 'Storing)
forall a. a -> Maybe a
Just (w 'Individual
newCritter, w 'Storing
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 :: forall (w :: Access -> *) (m :: * -> *).
(UsingSpawnedFromPrototype w 'Individual,
 UsingIsPrototype w 'Individual, MonadIO m) =>
PrototypeNameMap
-> PrototypeID
-> w 'Storing
-> m (Maybe (w 'Individual, w 'Storing))
spawnNamedPrototype PrototypeNameMap
prototypeMap PrototypeID
proto w 'Storing
world = do
  case PrototypeNameMap
prototypeMap PrototypeNameMap
-> Getting (First Entity) PrototypeNameMap Entity -> Maybe Entity
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index PrototypeNameMap
-> Traversal' PrototypeNameMap (IxValue PrototypeNameMap)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index PrototypeNameMap
PrototypeID
proto of
    Maybe Entity
Nothing -> Bool
-> m (Maybe (w 'Individual, w 'Storing))
-> m (Maybe (w 'Individual, w 'Storing))
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool
False Bool -> (String, PrototypeID) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` String
"Prototype ID doesn't exist!" String -> PrototypeID -> (String, PrototypeID)
forall v. String -> v -> (String, v)
`swith` PrototypeID
proto) (Maybe (w 'Individual, w 'Storing)
-> m (Maybe (w 'Individual, w 'Storing))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (w 'Individual, w 'Storing)
forall a. Maybe a
Nothing)
    Just Entity
ent -> do
      Maybe (w 'Individual, w 'Storing)
spawned <- Entity -> w 'Storing -> m (Maybe (w 'Individual, w 'Storing))
forall (w :: Access -> *) (m :: * -> *).
(UsingSpawnedFromPrototype w 'Individual,
 UsingIsPrototype w 'Individual, MonadIO m) =>
Entity -> w 'Storing -> m (Maybe (w 'Individual, w 'Storing))
spawnPrototype Entity
ent w 'Storing
world
      case Maybe (w 'Individual, w 'Storing)
spawned of
        Maybe (w 'Individual, w 'Storing)
Nothing -> Bool
-> m (Maybe (w 'Individual, w 'Storing))
-> m (Maybe (w 'Individual, w 'Storing))
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool
False Bool -> (String, Entity) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (String
"Prototype ID " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PrototypeID -> String
forall a. Show a => a -> String
show PrototypeID
proto String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" existed, but the entity it refers to doesn't!") String -> Entity -> (String, Entity)
forall v. String -> v -> (String, v)
`swith` Entity
ent) (Maybe (w 'Individual, w 'Storing)
-> m (Maybe (w 'Individual, w 'Storing))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (w 'Individual, w 'Storing)
forall a. Maybe a
Nothing)
        Just (w 'Individual, w 'Storing)
m -> Maybe (w 'Individual, w 'Storing)
-> m (Maybe (w 'Individual, w 'Storing))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((w 'Individual, w 'Storing) -> Maybe (w 'Individual, w 'Storing)
forall a. a -> Maybe a
Just (w 'Individual, w 'Storing)
m)

-- | All the prototypical individuals in a world.
{-# INLINE prototypes #-}
prototypes :: (HasIsPrototype w) => IndexedTraversal' Entity (w Storing) (w Individual)
prototypes :: forall (w :: Access -> *).
HasIsPrototype w =>
IndexedTraversal' Entity (w 'Storing) (w 'Individual)
prototypes = (forall r.
 Monoid r =>
 Getting r (w 'Storing) IntersectionOfEntities)
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (f :: * -> *) (p :: * -> * -> *).
(Indexable Entity p, Applicative f) =>
(forall r.
 Monoid r =>
 Getting r (w 'Storing) IntersectionOfEntities)
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (w :: Access -> *) (f :: * -> *) (p :: * -> * -> *).
(World w, Indexable Entity p, Applicative f) =>
(forall r.
 Monoid r =>
 Getting r (w 'Storing) IntersectionOfEntities)
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
entitiesWith (IntersectionOfEntities -> Const r IntersectionOfEntities)
-> w 'Storing -> Const r (w 'Storing)
forall r. Monoid r => Getting r (w 'Storing) IntersectionOfEntities
Fold (w 'Storing) IntersectionOfEntities
forall (worldType :: Access -> *).
HasIsPrototype worldType =>
Fold (worldType 'Storing) IntersectionOfEntities
withIsPrototype