{-# 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.
    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 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))

-- | 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 :: forall (w :: Access -> *) (m :: * -> *).
(UsingSpawnedFromPrototype w 'Individual,
 UsingIsPrototype w 'Individual, MonadIO m) =>
PrototypeID -> w 'Storing -> m (Maybe (w 'Individual, w 'Storing))
spawnNamedPrototype PrototypeID
prototypeName w 'Storing
world = do
  let proto :: Maybe Entity
proto = w 'Storing
world w 'Storing
-> Getting (First Entity) (w 'Storing) Entity -> Maybe Entity
forall s a. s -> Getting (First a) s a -> Maybe a
^? PrototypeID -> AffineTraversal' (w 'Storing) (w 'Individual)
forall p.
HasPrototypeID p =>
p -> AffineTraversal' (w 'Storing) (w 'Individual)
forall (w :: Access -> *) p.
(World w, HasPrototypeID p) =>
p -> AffineTraversal' (w 'Storing) (w 'Individual)
prototype PrototypeID
prototypeName ((w 'Individual -> Const (First Entity) (w 'Individual))
 -> w 'Storing -> Const (First Entity) (w 'Storing))
-> ((Entity -> Const (First Entity) Entity)
    -> w 'Individual -> Const (First Entity) (w 'Individual))
-> Getting (First Entity) (w 'Storing) Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Const (First Entity) Entity)
-> w 'Individual -> Const (First Entity) (w 'Individual)
IndexedGetter Entity (w 'Individual) Entity
forall (w :: Access -> *).
World w =>
IndexedGetter Entity (w 'Individual) Entity
entityReference
  case Maybe Entity
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, Maybe Entity) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` String
"Prototype ID doesn't exist!" String -> Maybe Entity -> (String, Maybe Entity)
forall v. String -> v -> (String, v)
`swith` Maybe Entity
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]
++ Maybe Entity -> String
forall a. Show a => a -> String
show Maybe Entity
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