SpawnedFromPrototype.hs

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