World.hs

{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- Module      :  Games.ECS.World
-- Description : World definitions
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Infrastructure for defining ECS worlds.
module Games.ECS.World
  ( Access (..),
    Props (..),
    World (..),
    OpticsFor,
    EntRefStoringType,
    EntRefField,
    AnAffineTraversal,
    AnAffineTraversal',
    AffineTraversal,
    AffineTraversal',
    affine,
    affine',
    newUniqueEntRef,
  )
where

import Control.Lens
import Control.Monad.IO.Class
import Data.IORef
import Data.IntSet qualified as IS
import Data.Kind
import GHC.Base
import GHC.Num
import Games.ECS.Entity
import Games.ECS.Prototype.PrototypeID    
import Games.ECS.Slot
import System.IO.Unsafe (unsafePerformIO)

-- | HKD parameterisation for an ECS.
data Access
  = -- | We are dealing with the entire collection of  entities in a world, represented structure-of-array style.
    Storing
  | -- | We are dealing with a specific individual with specific component values.
    Individual

-- | Different arities.
data Props
  = -- | An individual may or may not have this component.
    Normal
  | -- | Every individual must have this component.
    Required
  | -- | Either a single individual, or none, may have this component.
    Unique

-- | For entity unique values. We don't want to use Data.Unique, because we would like to be able to set the
-- seed upon loading a save game.
entUniqueSource :: IORef Integer
entUniqueSource = unsafePerformIO (newIORef 0)
{-# NOINLINE entUniqueSource #-}

-- | Atomically construct a new entity reference.
newUniqueEntRef :: IO Entity
newUniqueEntRef = do
  r <- atomicModifyIORef' entUniqueSource $ \x -> let z = x + 1 in (z, z)
  pure (EntRef (integerToInt r))
{-# NOINLINE newUniqueEntRef #-}

-- | An entity component system, parameterised by its access type.
class World (w :: Access -> Type) where
  -- | Construct a new world.
  newWorld :: w Storing

  -- | Create a new entity
  createNewEntity :: (MonadIO m) => m (w Individual)
  {-# INLINE createNewEntity #-}
  createNewEntity = do
    seed <- liftIO newUniqueEntRef
    pure (createNewEntityWithRef seed)

  -- | Create a new entity with a given reference.
  createNewEntityWithRef :: Entity -> w Individual

  -- | Traversal over all entities in the ECS.
  entities :: IndexedTraversal' Entity (w Storing) (w Individual)
  {-# INLINE entities #-}
  default entities :: (HasType (EntRefStoringType) (w Storing)) => IndexedTraversal' Entity (w Storing) (w Individual)
  entities p world = lookupEntities ((world ^.. typed @(EntRefField Storing) . knownEntities)) p world

  -- | Get the entity reference of an individual
  entityReference :: IndexedGetter Entity (w Individual) Entity

  -- | Get and set the entity reference of an individual
  unsafeEntityReference :: Lens' (w Individual) Entity

  -- | Get all of the entity references stored in the world.
  entityReferences :: IndexedFold Entity (w Storing) Entity

  -- | 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)
  lookupEntities list = entities . {-indices-} filtered (\ent -> elemOf folded (ent ^. entityReference) list) -- TODO optimise this fucking thing

  -- | An IndexedTraversal' of individuals matching some constraints. The constraints are included monoidally.
  entitiesWith :: 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) -- IndexedTraversal' Entity (w Storing) (w Individual)
  {-# INLINE entitiesWith #-}
  entitiesWith withComponents p world = lookupEntities ((world ^. withComponents) ^.. knownEntities) p world

  -- | Store an individual in a world, returning the new world.
  storeEntity :: w Individual -> w Storing -> w Storing

  -- | Affine traversal for a specified individual from the world.
  entity :: Entity -> AffineTraversal' (w Storing) (w Individual)
  entity ent = affine' (`lookupEntity` ent) (flip storeEntity)
  {-# INLINE entity #-}

-- TODO make this EntitySet. Just need to implement Ixed/At for it, and change IS.member in World/TH.hs.

-- | A type which holds a collection of 'Entity'.
type EntRefStoringType = IS.IntSet

-- Should this go in Component.hs? Perhaps a typeclass "Using", which converts an (affine) traversal into
-- a lens, given evidence from a function like `filtered (has position)`? either a unique typeclass will
-- have to be generated for each named component, or parameterised by the name itself. the former has the
-- advantage of robustness to renaming, but the latter would allow a nice `using @"position"` syntax.
-- perhaps it could inject a (gdp-style) Fact into the context? that way, the accessor can have a
-- requirement on its optic, and might even be able to specify logical dependencies (e.g. a movable object
-- must have a position; an inventory item must have a mass, etc) with :: (CompTypeClass name a) =>
-- IndexedTraversal' Entity (w Individual) (w Individual)

-- | A type function for simplifying the higher-kinded data implementation.
type family EntRefField (acc :: Access) :: Type where
  EntRefField Individual = Entity
  EntRefField Storing = EntRefStoringType

-- TODO Add a global storage type family

-- type family GlobalStorage (name :: Symbol) :: Type

-- | We want to make sure that the API is consistent based on the access type and availability property, so we
-- have a type family to give us the correct optics.
type family OpticsFor (name :: Symbol) (hkd :: Access -> Type) (acc :: Access) (p :: Props) (a :: Type) :: Type where
  OpticsFor name hkd Individual Required a =
    ReifiedIndexedLens' Entity (hkd Individual) a
  OpticsFor name hkd Individual Normal a =
    AnAffineTraversal' (hkd Individual) a
  OpticsFor name hkd Individual Unique a = AnAffineTraversal' (hkd Individual) a
  OpticsFor name hkd Storing Unique a = ReifiedIndexedTraversal' Entity (hkd Storing) a
  OpticsFor name hkd Storing Normal a = ReifiedIndexedTraversal' Entity (hkd Storing) a
  OpticsFor name hkd Storing Required a = ReifiedIndexedTraversal' Entity (hkd Storing) a

-- class ((CompTypeClassFun name a) ~ a, (CompTypeClassFun name a) ~ (CompTypeFun name a)) => CompTypeClass (name :: Symbol) (a :: Type) where
--   type CompTypeClassFun (name :: Symbol) (a :: Type) :: Type

-- instance ((CompTypeClassFun name a) ~ a, (CompTypeClassFun name a) ~ (CompTypeFun name a)) => CompTypeClass name a where
--   type CompTypeClassFun name a = a

-- type family CompTypeFun (name :: Symbol) (a :: Type) :: Type where
--   CompTypeFun name a = a

-- | A reified 'AffineTraversal'.
type AnAffineTraversal s t a b = ReifiedIndexedTraversal Entity s t a b

-- | A reified `AffineTraversal'`.
type AnAffineTraversal' s a = AnAffineTraversal s s a a

-- | An 'AffineTraversal' is one which traverses either 0 or 1 elements.
type AffineTraversal s t a b = Traversal s t a b

-- | Simplified 'AffineTraversal'.
type AffineTraversal' s a = AffineTraversal s s a a

-- | Construct an `AffineTraversal`.
{-# INLINE affine #-}
affine :: (s -> Either t a) -> (s -> b -> t) -> Traversal s t a b
affine getter setter f s = case getter s of
  Left t -> pure t
  Right a -> (\b -> setter s b) <$> f a

-- | Construct an `AffineTraversal'`.
{-# INLINE affine' #-}
affine' :: (s -> Maybe a) -> (s -> a -> s) -> Traversal' s a
affine' getter setter f s = case getter s of
  Nothing -> pure s
  Just a -> (\b -> setter s b) <$> f a