Prototype.hs

{-# 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 {_unPrototypeID :: Int}
  deriving newtype (Eq, Ord, Enum, Bounded, Ix)
  deriving newtype (XMLPickleAsAttribute)
  deriving stock (Generic)
  deriving newtype (Hashable)

makeClassy ''PrototypeID

instance Show PrototypeID where
  {-# INLINE show #-}
  show (PrototypeID ref) = "Prototype ID: " ++ show 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'.
    _rawIsPrototypeID :: !PrototypeID,
    -- | Indicates that this extends --- and overrides, in case of conflicting values --- another prototype.
    _extendsPrototype :: Maybe PrototypeID
  }
  deriving stock (Eq, Generic, Show)

makeLenses ''IsPrototype

instance HasPrototypeID IsPrototype where
  {-# INLINE prototypeID #-}
  prototypeID = rawIsPrototypeID

instance {-# OVERLAPS #-} XMLPickler [Node] IsPrototype where
  {-# INLINE xpickle #-}
  xpickle =
    xpWrap
      (\(pid, epid) -> IsPrototype pid epid)
      (\(IsPrototype pid epid) -> (pid, epid))
      ( xpElemAttrs
          "prototype"
          ( xpPair
              (pickleAsAttribute "prototypeID")
              (pickleAsAttribute "extends")
          )
      )

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