{-# 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 :: IORef Integer
entUniqueSource = IO (IORef Integer) -> IORef Integer
forall a. IO a -> a
unsafePerformIO (Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0)
{-# NOINLINE entUniqueSource #-}

-- | Atomically construct a new entity reference.
newUniqueEntRef :: IO Entity
newUniqueEntRef :: IO Entity
newUniqueEntRef = do
  Integer
r <- IORef Integer -> (Integer -> (Integer, Integer)) -> IO Integer
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Integer
entUniqueSource ((Integer -> (Integer, Integer)) -> IO Integer)
-> (Integer -> (Integer, Integer)) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \Integer
x -> let z :: Integer
z = Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 in (Integer
z, Integer
z)
  pure (Int -> Entity
EntRef (Integer -> Int
integerToInt Integer
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
    Entity
seed <- IO Entity -> m Entity
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Entity
newUniqueEntRef
    pure (Entity -> w 'Individual
forall (w :: Access -> *). World w => Entity -> w 'Individual
createNewEntityWithRef Entity
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 (w 'Individual) (f (w 'Individual))
p w 'Storing
world = [Entity]
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (f :: * -> *) (p :: * -> * -> *) (fol :: * -> *).
(Indexable Entity p, Applicative f, Foldable fol) =>
fol Entity
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (w :: Access -> *) (f :: * -> *) (p :: * -> * -> *)
       (fol :: * -> *).
(World w, Indexable Entity p, Applicative f, Foldable fol) =>
fol Entity
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
lookupEntities ((w 'Storing
world w 'Storing
-> Getting (Endo [Entity]) (w 'Storing) Entity -> [Entity]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a s. HasType a s => Lens' s a
typed @(EntRefField Storing) ((EntRefStoringType -> Const (Endo [Entity]) EntRefStoringType)
 -> w 'Storing -> Const (Endo [Entity]) (w 'Storing))
-> ((Entity -> Const (Endo [Entity]) Entity)
    -> EntRefStoringType -> Const (Endo [Entity]) EntRefStoringType)
-> Getting (Endo [Entity]) (w 'Storing) Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Const (Endo [Entity]) Entity)
-> EntRefStoringType -> Const (Endo [Entity]) EntRefStoringType
forall a. IsEntityStore a => Fold a Entity
Fold EntRefStoringType Entity
knownEntities)) p (w 'Individual) (f (w 'Individual))
p w 'Storing
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 fol Entity
list = p (w 'Individual) (f (w 'Individual))
-> w 'Storing -> f (w 'Storing)
IndexedTraversal' Entity (w 'Storing) (w 'Individual)
forall (w :: Access -> *).
World w =>
IndexedTraversal' Entity (w 'Storing) (w 'Individual)
entities (p (w 'Individual) (f (w 'Individual))
 -> w 'Storing -> f (w 'Storing))
-> (p (w 'Individual) (f (w 'Individual))
    -> p (w 'Individual) (f (w 'Individual)))
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. {-indices-} (w 'Individual -> Bool)
-> p (w 'Individual) (f (w 'Individual))
-> p (w 'Individual) (f (w 'Individual))
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (\w 'Individual
ent -> Getting Any (fol Entity) Entity -> Entity -> fol Entity -> Bool
forall a s. Eq a => Getting Any s a -> a -> s -> Bool
elemOf Getting Any (fol Entity) Entity
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int (fol Entity) Entity
folded (w 'Individual
ent w 'Individual -> Getting Entity (w 'Individual) Entity -> Entity
forall s a. s -> Getting a s a -> a
^. Getting Entity (w 'Individual) Entity
IndexedGetter Entity (w 'Individual) Entity
forall (w :: Access -> *).
World w =>
IndexedGetter Entity (w 'Individual) Entity
entityReference) fol Entity
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 forall r. Monoid r => Getting r (w 'Storing) IntersectionOfEntities
withComponents p (w 'Individual) (f (w 'Individual))
p w 'Storing
world = [Entity]
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (f :: * -> *) (p :: * -> * -> *) (fol :: * -> *).
(Indexable Entity p, Applicative f, Foldable fol) =>
fol Entity
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
forall (w :: Access -> *) (f :: * -> *) (p :: * -> * -> *)
       (fol :: * -> *).
(World w, Indexable Entity p, Applicative f, Foldable fol) =>
fol Entity
-> p (w 'Individual) (f (w 'Individual))
-> w 'Storing
-> f (w 'Storing)
lookupEntities ((w 'Storing
world w 'Storing
-> Getting
     IntersectionOfEntities (w 'Storing) IntersectionOfEntities
-> IntersectionOfEntities
forall s a. s -> Getting a s a -> a
^. Getting IntersectionOfEntities (w 'Storing) IntersectionOfEntities
forall r. Monoid r => Getting r (w 'Storing) IntersectionOfEntities
withComponents) IntersectionOfEntities
-> Getting (Endo [Entity]) IntersectionOfEntities Entity
-> [Entity]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Entity]) IntersectionOfEntities Entity
forall a. IsEntityStore a => Fold a Entity
Fold IntersectionOfEntities Entity
knownEntities) p (w 'Individual) (f (w 'Individual))
p w 'Storing
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 Entity
ent = (w 'Storing -> Maybe (w 'Individual))
-> (w 'Storing -> w 'Individual -> w 'Storing)
-> AffineTraversal' (w 'Storing) (w 'Individual)
forall s a. (s -> Maybe a) -> (s -> a -> s) -> Traversal' s a
affine' (w 'Storing -> Entity -> Maybe (w 'Individual)
forall (w :: Access -> *).
World w =>
w 'Storing -> Entity -> Maybe (w 'Individual)
`lookupEntity` Entity
ent) ((w 'Individual -> w 'Storing -> w 'Storing)
-> w 'Storing -> w 'Individual -> w 'Storing
forall a b c. (a -> b -> c) -> b -> a -> c
flip w 'Individual -> w 'Storing -> w 'Storing
forall (w :: Access -> *).
World w =>
w 'Individual -> w 'Storing -> w 'Storing
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 :: forall s t a b.
(s -> Either t a) -> (s -> b -> t) -> Traversal s t a b
affine s -> Either t a
getter s -> b -> t
setter a -> f b
f s
s = case s -> Either t a
getter s
s of
  Left t
t -> t -> f t
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t
  Right a
a -> (\b
b -> s -> b -> t
setter s
s b
b) (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a

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