Component.hs

{-# OPTIONS_GHC "-Wno-orphans" #-}

-- |
-- Module      :  Games.ECS.Component
-- Description : Components and their infrastructure.
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Components are what hold data in an ECS system.
module Games.ECS.Component where

import Control.Applicative
import Control.Lens
import Data.Coerce
import Data.Foldable qualified as DF
import Data.Kind (Type)
import Data.Maybe qualified as DM
import Data.Proxy
import Data.String
import Data.XML.Types (Element)
import GHC.Generics
import GHC.OverloadedLabels
import GHC.TypeLits
import Games.ECS.Component.Store
import Games.ECS.Entity
import Games.ECS.Serialisation
import Games.ECS.Slot
import Games.ECS.World

class PseudoComponent c

-- type family DefaultStorageForFlags (b :: Bool) where
--     type instance DefaultStorageForFlags False = ComponentStore
--     type instance DefaultStorageForFlags True =

-- | A component represented in the entity component system.
class
  ( AsEmpty (Storage c c),
    KnownSymbol (CanonicalName c),
    At (Storage c c),
    Index (Storage c c) ~ Entity,
    HasEntitySet (Storage c c)
  ) =>
  Component c
  where
  -- | What to name accessors if the type name isn't ergonomic.
  type CanonicalName c :: Symbol

  -- | Is the type a flag component?
  type IsFlag c :: Bool

  type IsFlag c = False

  -- | What datatype to store all instances of a component in. Allows for a generalisation of
  -- "Structure-of-Arrays". Defaults to `Data.HashMap.Strict.HashMap`.
  type Storage c :: Type -> Type

  type Storage c = ComponentStore

  -- | Arity of the component. Defaults to `Normal`.
  type Prop c :: Props

  type Prop c = Normal

  -- | A prism for serialising and deserialising the component as XML.
  _ComponentFromXML :: String -> Prism' Element c
  {-# INLINE _ComponentFromXML #-}
  default _ComponentFromXML :: (XMLSerialise c) => String -> Prism' Element c
  _ComponentFromXML name =
    prism'
      (serialise name)
      ( \n -> case deserialise name n of
          Right a -> Just a
          Left _ -> Nothing
      )

  -- | The collection of entities held in storage.
  {-# INLINE entityKeys #-}
  entityKeys :: Fold (Storage c c) EntitySet
  entityKeys = entitySet

  -- | Construct new storage.
  {-# INLINE emptyStorage #-}
  emptyStorage :: Storage c c
  emptyStorage = review _Empty () :: (Storage c c)

  -- | An AffineTraversal lookup of a given `Entity`'s component. This probably should be in `World.hs`.
  entityHasComponent :: Entity -> IndexedTraversal' Entity (Storage c c) c
  default entityHasComponent ::
    (IxValue (Storage c c) ~ c) =>
    Entity ->
    IndexedTraversal' Entity (Storage c c) c
  entityHasComponent ent = conjoined (ix ent) (iix ent)
  {-# INLINE entityHasComponent #-}

  -- | When the component is required, provide a default value.
  defaultValue :: ((Prop c) ~ Required) => c
  defaultValue = error ("No default value specified for required component " Prelude.++ symbolVal (Proxy :: Proxy (CanonicalName c)) Prelude.++ "!")

type ComponentReference (name :: Symbol) c = (Component c) => TaggedComponent name Entity









-- | A component comprised of multiple other components.
class (Component c) => CompositeComponent c where
  type SubComponentIndex c :: Type

  -- | Look up the entity references of the subcomponents.
  subComponentReferences :: IndexedFold (SubComponentIndex c) c Entity

  {-# INLINE components #-}

  -- | An IndexedTraversal' of the subcomponents of a composite component.
  components ::
    forall p f worldType.
    (World worldType, Indexable (SubComponentIndex c) p, Applicative f) =>
    -- | The composite component
    c ->
    p (worldType Individual) (f (worldType Individual)) ->
    worldType Storing ->
    f (worldType Storing)
  components comp = conjoined normalVer indexedVer
    where
      normalVer prof world = result
        where
          applied :: [f (worldType Individual)]
          applied =
            fmap (prof) $
              DM.mapMaybe
                (lookupEntity world)
                (comp ^.. subComponentReferences)

          result = liftA3 DF.foldl' (pure (flip storeEntity)) (pure world) (sequenceA applied)
      indexedVer prof world = result
        where
          applied :: [f (worldType Individual)]
          applied =
            fmap (uncurry (Control.Lens.indexed prof)) $
              DM.mapMaybe
                ( \(partName', ent) -> case lookupEntity world ent of
                    Just partIndividual -> Just (partName', partIndividual)
                    Nothing -> Nothing
                )
                (comp ^@.. subComponentReferences)

          result = liftA3 DF.foldl' (pure (flip storeEntity)) (pure world) (sequenceA applied)

-- | Indicates a component behaves like a sensor.
class (Component c) => SensoryComponent c

-- sensors :: c -> IndexedTraversal' Entity (worldType Storing) (worldType Individual)

-- | Indicates that a component can perform actions in the world.
class (Component c) => EffectorComponent c

class (Component c) => AttributeComponent c

-- | Indicates whether a component is a simple Boolean flag.
class (Component c) => FlagComponent c

-- | A component representing an /intent/ to do something.
class (Component c) => IntentComponent c

class (Component c) => ReferenceComponent c

-- | A component which indicates an ability to emit intents.
class (IntentComponent (Intent c), Component c) => CapabilityComponent c where
  type Intent c :: Type

-- TODO look at `specs`  storage mechanisms
-- TODO look at unity archetypes (the storage kind)

-- Look at bitsets, hibitsets, bloom filters, slotmaps

-- | Storage for 'Unique' components. As a 'Unique' component will have, at most, a single instance in the world, we only need to store the component and its 'Entity' naively.
newtype UniqueStore a = UniqueStore (Maybe (Entity, a)) deriving (Eq, Show, Generic)

instance HasEntitySet (UniqueStore a) where
  {-# INLINE entitySet #-}
  entitySet = (coerced :: Iso' (UniqueStore a) (Maybe (Entity, a))) . _Just . _1 . Control.Lens.to singletonEntitySet

instance AsEmpty (UniqueStore a) where
  {-# INLINE _Empty #-}
  _Empty = coerced @(UniqueStore a) @(UniqueStore a) @(Maybe (Entity, a)) @(Maybe (Entity, a)) . _Nothing

instance Ixed (UniqueStore a)

type instance Index (UniqueStore a) = Entity

type instance IxValue (UniqueStore a) = a

instance (Index (UniqueStore a) ~ Entity, (IxValue (UniqueStore a)) ~ a) => At (UniqueStore a) where
  {- at ::
     Functor f =>
     Entity ->
     (Maybe a -> f (Maybe a)) ->
     UniqueStore a ->
     f (UniqueStore a)-}
  {-# INLINE at #-}
  at e f us =
    f lookedUp <&> \case
      Nothing -> maybe us (const (UniqueStore Nothing)) lookedUp
      Just v' -> UniqueStore (Just (e, v'))
    where
      lookedUp =
        ( case us of
            UniqueStore (Just (ref, a)) | e == ref -> Just a
            _ -> Nothing
        )

-- | This is an unlawful instance due to `entityHasComponent` allowing write-back.
-- FIXME: Write a valid definition of entityHasComponent, or make it only a psuedocomponent.
-- instance Component Entity where
--  type Prop Entity = Required

-- Some (future) psuedocomponents?

data Has entity component = Has

type HasA component entity = Has entity component

data Hasn't entity component = Hasn't

-- | Simplified type signature to use in world definitions.
type AComponent name s a = Field name s (Prop a) a

instance ({-HasType (Field name acc p a) (hkd acc), Generic (hkd acc),-} EntityProperty name hkd acc p a, accessorType ~ OpticsFor name hkd acc p a) => IsLabel name accessorType where
  fromLabel = accessor @name @hkd @acc @p @a
  {-# INLINE fromLabel #-}

-- instance (HasType (Tagged name a) (hkd Individual), (Tagged name a) ~ (Field name hkd Individual p a), EntityProperty name hkd Individual p a) => HasField name (hkd Individual) a where

--  getField = unTagged . getTyped

-- | A component with an arbitrary name tag.
newtype TaggedComponent name a = Tagged {unTagged :: a} deriving newtype (Eq, Show, Ord, Generic)

{-# INLINE untag #-}

-- | Get the raw component.
untag :: TaggedComponent name a -> a
untag = unTagged

instance {-# OVERLAPPING #-} (KnownSymbol name, KnownSymbol (AppendSymbol name "TaggedComponent wrapper"), XMLPickler [Node] a) => XMLPickler [Node] (TaggedComponent name a) where
  {-# INLINE xpickle #-}
  xpickle = xpElemNodes (fromString (symbolVal (Proxy :: Proxy name))) $ (fromString $ (symbolVal (Proxy :: Proxy (AppendSymbol name "TaggedComponent wrapper"))), "") <?+> (xpWrap Tagged untag (("inside Tagged", "") <?+> xpickle))

instance {-# OVERLAPPING #-} (Eq a, KnownSymbol name, KnownSymbol (AppendSymbol name "TaggedComponent wrapper"), XMLPickler [Node] a) => XMLPickler [Node] (TaggedComponent name (Maybe a)) where
  {-# INLINE xpickle #-}
  xpickle = xpDefault (Tagged Nothing) $ xpElemNodes (fromString (symbolVal (Proxy :: Proxy name))) $ (fromString $ (symbolVal (Proxy :: Proxy (AppendSymbol name "TaggedComponent wrapper"))), "") <?+> (xpWrap Tagged untag (("inside Tagged", "") <?+> xpOption (("inside option", "") <?+> ({-xpMayFail-} xpickle))))

-- | An instance for wrapper components. Don't bother with the wrapper constructor or fieldname; just the wrapped data.
instance {-# OVERLAPPING #-} (KnownSymbol name, XMLPickler [Node] a, Datatype d, ty ~ (M1 D d (M1 C c'' (M1 S c (K1 i a))))) => GXmlPickler [Node] (M1 D d (M1 C c'' (M1 S c (K1 i (TaggedComponent name (Maybe a)))))) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf _ = {-xpElemNodes (fromString . formatElement $ datatypeName (undefined :: ty p))-} xpElemNodes (fromString (symbolVal (Proxy :: Proxy name))) $ (fromString $ datatypeName (undefined :: M1 D d f p), "") <?+> (xpWrap (M1 . M1 . M1 . K1 . Tagged) (unTagged . unK1 . unM1 . unM1 . unM1) (xpOption ({-xpMayFail-} xpickle)))

-- | The core mechanics of the higher-kinded representation for the ECS system.
type family Field (name :: Symbol) (acc :: Access) (p :: Props) (a :: Type) :: Type where
  Field name Individual Required a = TaggedComponent name a
  Field name Individual Normal a = TaggedComponent name (Maybe a)
  Field name Individual Unique a = TaggedComponent name (Maybe a)
  Field name Storing Unique a = TaggedComponent name (UniqueStore a)
  Field name Storing Required a = TaggedComponent name (Storage a a)
  Field name Storing Normal a = TaggedComponent name (Storage a a)

instance {-# OVERLAPS #-} (Show a) => Show (TaggedComponent (name :: Symbol) (Maybe a)) where
  show (Tagged Nothing) = ""
  show (Tagged (Just a)) = show a

-- | Plumbing class for a higher-kinded data representation of a game world.
-- | Generalisation of "Array of Structures" vs "Structure of Arrays".
class {-((CompTypeClass name a {- ,(CompTypeClassFun name a) ~ (CompType' name hkd acc p a)-})) => -} EntityProperty (name :: Symbol) (hkd :: Access -> Type) (acc :: Access) (p :: Props) (a :: Type) where
  accessor :: OpticsFor name hkd acc p a
  injectToField :: (acc ~ Individual) => a -> Field name Individual p a
  maybeGet :: (acc ~ Individual) => Field name Individual p a -> Maybe a
  {-# INLINE CONLIKE injectMaybe #-}
  injectMaybe :: (acc ~ Individual) => Maybe a -> Field name Individual p a
  injectMaybe (Just a) = injectToField @name @hkd @acc @p @a a
  injectMaybe Nothing = defaultField @name @hkd @acc @p @a

  defaultField :: (acc ~ Individual) => Field name Individual p a
  defaultStorage :: (acc ~ Storing) => Field name Storing p a
  storage :: (acc ~ Storing) => Lens' (hkd acc) (Storage a a)

instance forall name hkd a. (HasType (Field name Individual Required a) (hkd Individual), World hkd, Component a, Prop a ~ Required) => EntityProperty name hkd Individual Required a where
  {-# INLINE CONLIKE injectToField #-}
  {-# INLINE CONLIKE maybeGet #-}
  {-# INLINE CONLIKE defaultField #-}
  {-# INLINE CONLIKE accessor #-}
  injectToField = Tagged
  defaultStorage = error "what"
  maybeGet = Just . untag
  storage = error "what"
  defaultField = injectToField @name @hkd @Individual @Required @a defaultValue
  accessor =
    IndexedLens
      ( conjoined ((lens (getTyped @(TaggedComponent name a)) (\(s :: hkd Individual) (a :: TaggedComponent name a) -> setTyped a s)) . coerced) ((ilens getter (\(s :: hkd Individual) (a :: TaggedComponent name a) -> setTyped a s)) . coerced)
      )
    where
      getter :: hkd Individual -> (Entity, Field name Individual Required a)
      getter s = (s ^. entityReference, (getTyped @(TaggedComponent name a)) $ s)

{-{-# RULES "component/set . get" forall w. set accessor (view accessor w) w = w #-}

{-# RULES "component/set . get" forall v w. view accessor (set accessor v w) = v #-}-}

instance forall name hkd a. (HasType (Field name Individual Normal a) (hkd Individual), World hkd, Component a) => EntityProperty name hkd Individual Normal a where
  {-# INLINE CONLIKE injectToField #-}
  {-# INLINE CONLIKE maybeGet #-}
  {-# INLINE CONLIKE defaultField #-}
  {-# INLINE CONLIKE accessor #-}
  injectToField = Tagged . Just
  maybeGet = untag
  defaultField = Tagged Nothing
  defaultStorage = error "what"
  storage = error "what"
  accessor =
    IndexedTraversal $
      (conjoined ((lens (unTagged . boringGetter) (\(s :: hkd Individual) (a :: Maybe a) -> setTyped (Tagged @name a) s)) . _Just) ((ilens getter (\(s :: hkd Individual) (a :: TaggedComponent name (Maybe a)) -> setTyped a s)) . (coerced :: Iso' (TaggedComponent name (Maybe a)) (Maybe a)) . _Just))
    where
      boringGetter :: hkd Individual -> Field name Individual Normal a
      boringGetter s = (getTyped @(TaggedComponent name (Maybe a))) $ s
      getter :: hkd Individual -> (Entity, Field name Individual Normal a)
      getter s = (s ^. entityReference, (getTyped @(TaggedComponent name (Maybe a))) $ s)

instance forall name hkd a. (HasType (Field name Individual Unique a) (hkd Individual), World hkd, Component a) => EntityProperty name hkd Individual Unique a where
  {-# INLINE CONLIKE injectToField #-}
  {-# INLINE CONLIKE maybeGet #-}
  {-# INLINE CONLIKE defaultField #-}
  {-# INLINE CONLIKE accessor #-}
  injectToField = Tagged . Just
  maybeGet = untag
  storage = error "what"
  defaultStorage = error "what"
  defaultField = Tagged Nothing
  accessor =
    IndexedTraversal
      (conjoined ((lens (unTagged . boringGetter) (\(s :: hkd Individual) (a :: Maybe a) -> setTyped (Tagged @name a) s)) . _Just) ((ilens getter (\(s :: hkd Individual) (a :: TaggedComponent name (Maybe a)) -> setTyped a s)) . (coerced :: Iso' (TaggedComponent name (Maybe a)) (Maybe a)) . _Just))
    where
      getter :: hkd Individual -> (Entity, Field name Individual Unique a)
      getter s = (s ^. entityReference, (getTyped @(TaggedComponent name (Maybe a))) $ s)
      boringGetter :: hkd Individual -> Field name Individual Normal a
      boringGetter s = (getTyped @(TaggedComponent name (Maybe a))) $ s

instance
  {-# OVERLAPPABLE #-}
  ( OpticsFor name hkd 'Storing prop a
      ~ ReifiedIndexedTraversal' Entity (hkd 'Storing) a,
    HasType (Field name Storing prop a) (hkd Storing),
    EntityIndexedTraversable (Storage a) a,
    World hkd,
    Component a,
    Coercible (Field name 'Storing prop a) (Storage a a),
    (Field name 'Storing prop a ~ TaggedComponent name (Storage a a))
  ) =>
  EntityProperty name hkd Storing prop a
  where
  {-# INLINE CONLIKE injectToField #-}
  {-# INLINE CONLIKE accessor #-}
  {-# INLINE CONLIKE storage #-}
  injectToField = error "what"
  maybeGet = error "what"
  defaultField = error "what"
  defaultStorage = Tagged (emptyStorage @a) :: TaggedComponent name ((Storage a) a)
  storage = unwrappedField
    where
      taggedStorageField :: Lens' (hkd Storing) (Field name Storing prop a)
      taggedStorageField = (typed @(Field name Storing prop a) @(hkd Storing))
      unwrappedField :: Lens' (hkd Storing) (Storage a a)
      unwrappedField = (taggedStorageField . coerced)
  accessor = IndexedTraversal @Entity (storage @name @hkd @Storing @prop @a .> entitiesTraversed)

instance {-# OVERLAPPING #-} (Storage a a ~ UniqueStore a, HasType (Field name Storing Unique a) (hkd Storing), World hkd, Component a) => EntityProperty name hkd Storing Unique a where
  {-# INLINE CONLIKE injectToField #-}
  {-# INLINE CONLIKE accessor #-}
  {-# INLINE CONLIKE storage #-}
  injectToField = error "what"
  maybeGet = error "what"
  defaultField = error "what"
  defaultStorage = Tagged (UniqueStore Nothing)
  storage = unwrappedField
    where
      taggedStorageField :: Lens' (hkd Storing) (Field name Storing Unique a)
      taggedStorageField = (typed @(Field name Storing Unique a) @(hkd Storing))
      unwrappedField :: Lens' (hkd Storing) (UniqueStore a)
      unwrappedField = (taggedStorageField . coerced)
  accessor =
    IndexedTraversal @Entity
      ( conjoined
          (storage @name @hkd @Storing @Unique @a . (coerced :: Iso' (UniqueStore a) (Maybe (Entity, a))) . _Just . traversed)
          ((storage @name @hkd @Storing @Unique @a :: Lens' (hkd Storing) (UniqueStore a)) . (coerced :: Iso' (UniqueStore a) (Maybe (Entity, a))) . _Just .> itraversed)
      )