Components.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Mischief.ECS.Components
  ( -- * Component
    Component (..),
    ComponentId (..),
    Exclusivity (..),

    -- * Meta
    ComponentArchetypes (..),
    ComponentPairs (..),
    DefaultValue (..),
    Requires (..),
    RequiredBy (..),
    ComponentType (..),

    -- * Erasure
    ErasedComponent (..),
    tryGetComponent,
    DefaultComponentType (..),

    -- * Archetypes
    ArchetypeId (..),

    -- * Bundles
    BundleData (..),
    BundleElement (..),

    -- * Tables
    ComponentTick (..),

    -- * Storage
    Components (..),
    emptyComponents,
    getComponentId,

    -- * Utils
    Pair (..),
    Rel (..),
    From (..),
    Res (..),
    ComponentRep (..),
    Tick (..),
    ErasedComponentEq (..),
    IsExclusive (..),
    isPair,
    setCompIdTarget,
    IsExclusiveRelationship (..),
  )
where

import Data.Default
import Data.HashTable.IO qualified as H
import Data.Kind
import Data.List qualified as List
import Data.Map (Map)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Typeable
import Data.Word (Word64)
import GHC.Base (Word (W#), Word#, compareWord#, eqWord#, isTrue#)
import GHC.Generics
import Mischief.ECS.Collectable
import Mischief.ECS.Components.HooksDef
import Mischief.ECS.EntityDef
import Mischief.ECS.Utils

data Exclusivity = Inclusive | Exclusive

-- | The @Component@ typeclass.
class (Typeable c, IsExclusive (IsExclusiveRel c)) => Component c where
  -- | List of components required by this one.
  -- All required components must be 'Default'
  --
  -- Example
  --
  -- @
  -- data A = A
  -- instance 'Component' A where
  --   'required' = 'Mischief.ECS.Components.Required.require' @(B, C)
  --
  -- data B = B 'Int' deriving ('Component', 'Generic', 'Default')
  --
  -- data C = C 'String' deriving ('Component')
  -- instance 'Default' C where
  --   'def' = C "Default String"
  -- @
  required :: Set DefaultComponentType
  required = Set.empty

  -- | Set whether the relationships this component is used in are exclusive or not.
  type IsExclusiveRel c :: Bool

  type IsExclusiveRel c = False

  onAdd :: [Hook c]
  onAdd = []

  onSet :: [Hook c]
  onSet = []

  onRemove :: [Hook c]
  onRemove = []

  onAddRel :: [HookRel c]
  onAddRel = []

  onSetRel :: [HookRel c]
  onSetRel = []

  onRemoveRel :: [HookRel c]
  onRemoveRel = []

class IsExclusive (e :: Bool) where
  isExclusive :: Bool

instance IsExclusive False where
  isExclusive = False

instance IsExclusive True where
  isExclusive = True

-- | Unique id for components and component pairs.
data ComponentId = ComponentId (# Word#, Maybe Entity #)

instance Show ComponentId where
  show (ComponentId (# !a, !b #)) = "Component (" ++ show (W# a) ++ ", " ++ show b ++ ")"

instance Eq ComponentId where
  (==) :: ComponentId -> ComponentId -> Bool
  (==) (ComponentId (# !a, !b #)) (ComponentId (# !x, !y #)) = isTrue# (eqWord# a x) && b == y

instance Ord ComponentId where
  compare :: ComponentId -> ComponentId -> Ordering
  compare (ComponentId (# !a, !b #)) ((ComponentId (# !x, !y #))) =
    case compareWord# a x of
      EQ -> compare b y
      x -> x

-- { -- | The component's entity.
--   id :: Entity,
--   -- | Optional target entity in case this is a pair / relationship.
--   entity :: Maybe Entity
-- }
-- deriving (Show, Eq, Ord)

isPair :: ComponentId -> Bool
isPair (ComponentId (# _, Just _ #)) = True
isPair _ = False

setCompIdTarget :: Maybe Entity -> ComponentId -> ComponentId
setCompIdTarget Nothing (ComponentId (# !a, _ #)) = ComponentId (# a, Nothing #)
setCompIdTarget (Just !e) (ComponentId (# !a, _ #)) = ComponentId (# a, Just e #)

newtype Pair = Pair (ComponentType, Entity)

type HashMap k v = H.BasicHashTable k v

-- | Contains data and methods for assigning 'ComponentId's to new components (via their 'TypeRep').
newtype Components = Components
  { -- | Maps 'TypeRep's to Ints, to be used as the first half of a 'ComponentId'.
    components :: HashMap TypeRep Word
  }

-- | @Meta@ component with a set of all archetypes that a components is part of.
newtype ComponentArchetypes = ComponentArchetypes {inner :: Set ArchetypeId}
  deriving anyclass (Component)
  deriving newtype (Default)
  deriving stock (Show)

-- | @Meta@ component with a set of all archetypes containing pairs made with this component.
data ComponentPairs = ComponentPairs
  { -- | Archetypes that contain any pair formed with this component.
    any :: Set ArchetypeId,
    -- | Specific archetypes between this component and a particular entity.
    pairs :: Map Entity (Set ArchetypeId)
  }
  deriving anyclass (Component, Default)
  deriving stock (Show, Generic)

-- | Construct an empty 'Components'.
emptyComponents :: IO Components
emptyComponents = Components <$> H.new

-- | Get the id of a component through IO.
getComponentId :: TypeRep -> Components -> IO (Maybe ComponentId)
getComponentId !t Components {components = !components} = do
  !comp <- H.lookup components t
  pure $ case comp of
    Nothing -> Nothing
    Just (W# !t) -> Just $ ComponentId (# t, Nothing #)

-- | Try to get the inner data of a 'ErasedComponent'.
tryGetComponent :: forall c. (Component c) => ErasedComponent -> Maybe c
tryGetComponent (ErasedComponent (!s :: c')) =
  case eqT @c @c' of
    Just Refl -> Just s
    Nothing -> Nothing

instance {-# OVERLAPPING #-} EraseIntoStorage () (BundleData ErasedComponent) where
  erase _ = BundleData Set.empty Set.empty Set.empty

instance {-# OVERLAPPING #-} EraseIntoStorage (BundleData ErasedComponent) (BundleData ErasedComponent) where
  erase = id

instance (Component c) => EraseIntoStorage c (BundleData ErasedComponent) where
  erase !c =
    BundleData (Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponent c}) Set.empty Set.empty

instance {-# OVERLAPPING #-} (Component c) => EraseIntoStorage (Rel c) (BundleData ErasedComponent) where
  erase (Rel !c !entity) =
    BundleData (Set.singleton BundleElement {rep = PairRep (ComponentType $ Proxy @c, entity), component = ErasedComponent c}) Set.empty Set.empty

instance {-# OVERLAPPING #-} (Component c) => EraseIntoStorage (Res c) (BundleData ErasedComponent) where
  erase (Res !c) = BundleData Set.empty (Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponent c}) Set.empty

instance {-# OVERLAPPING #-} (Collectable c (BundleData ErasedComponent)) => EraseIntoStorage (From c) (BundleData ErasedComponent) where
  erase (From !e !c) = BundleData Set.empty Set.empty (Set.singleton (e, collect c))

instance {-# OVERLAPPING #-} (Collectable c (BundleData ErasedComponent)) => EraseIntoStorage [c] (BundleData ErasedComponent) where
  erase = foldr ((<>) . collect) (BundleData Set.empty Set.empty Set.empty)

instance (Component c, Eq c) => EraseIntoStorage c (BundleData ErasedComponentEq) where
  erase !c =
    BundleData (Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponentEq c}) Set.empty Set.empty

instance {-# OVERLAPPING #-} (Component c, Eq c) => EraseIntoStorage (Rel c) (BundleData ErasedComponentEq) where
  erase (Rel !c !entity) =
    BundleData (Set.singleton BundleElement {rep = PairRep (ComponentType $ Proxy @c, entity), component = ErasedComponentEq c}) Set.empty Set.empty

instance {-# OVERLAPPING #-} (Component c, Eq c) => EraseIntoStorage (Res c) (BundleData ErasedComponentEq) where
  erase (Res !c) = BundleData Set.empty (Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponentEq c}) Set.empty

instance {-# OVERLAPPING #-} (Collectable c (BundleData ErasedComponentEq)) => EraseIntoStorage (From c) (BundleData ErasedComponentEq) where
  erase (From !e !c) = BundleData Set.empty Set.empty (Set.singleton (e, collect c))

instance {-# OVERLAPPING #-} (Collectable c (BundleData ErasedComponentEq)) => EraseIntoStorage [c] (BundleData ErasedComponentEq) where
  erase = foldr ((<>) . collect) (BundleData Set.empty Set.empty Set.empty)

instance {-# OVERLAPPING #-} EraseIntoStorage (BundleData ErasedComponentEq) (BundleData ErasedComponentEq) where
  erase = id

-- | Unique id corresponding to an archetype.
newtype ArchetypeId = ArchetypeId
  { id :: Int
  }
  deriving (Show, Eq, Ord)

-- | Data extracted from a 'Mischief.ECS.Components.Bundle.Bundle'.
data BundleData e = BundleData {elements :: Set (BundleElement e), resources :: Set (BundleElement e), external :: Set (Entity, BundleData e)} deriving (Eq, Ord)

instance Semigroup (BundleData e) where
  (<>) (BundleData a0 b0 c0) (BundleData a1 b1 c1) = BundleData (a0 <> a1) (b0 <> b1) (c0 <> c1)

instance Show (BundleData e) where
  show BundleData {elements = !elements} = mconcat ["BundleData e [", List.intercalate ", " ts, "]"]
    where
      !ts = map (\bundle -> show bundle.rep) (Set.toList elements)

-- | Change ticks for a specific component.
newtype ComponentTick = ComponentTick Tick deriving (Show)

-- | Type used for querying and inserting relationships.
data Rel c = Rel {comp :: c, target :: Entity} deriving (Eq)

instance Functor Rel where
  fmap !f (Rel !c !target) = Rel (f c) target

instance (Show c) => Show (Rel c) where
  show Rel {comp = !comp, target = !target} = "Rel (" ++ show comp ++ ", " ++ show target ++ ")"

data From c = From {entity :: Entity, comp :: c} deriving (Eq)

instance Functor From where
  fmap :: (a -> b) -> From a -> From b
  fmap !f (From !c !x) = From c (f x)

instance (Show c) => Show (From c) where
  show From {entity = !entity, comp = !comp} = "From (" ++ show entity ++ ", " ++ show comp ++ ")"

newtype Res c = Res {comp :: c} deriving newtype (Show, Eq)

instance Functor Res where
  fmap !f (Res !c) = Res (f c)

-- | @Meta@ component with the /erased/ default value of this component. Added to components required by other components.
newtype DefaultValue = DefaultValue ErasedComponent deriving anyclass (Component)

instance Component ComponentType where
  required = Set.fromList [DefaultComponentType $ Proxy @ComponentArchetypes, DefaultComponentType $ Proxy @ComponentPairs]

-- | @Meta@ relationship.
data RequiredBy = RequiredBy deriving (Component)

-- | @Meta@ relationship.
data Requires = Requires deriving (Component)

-- | Type for component erasure.
data ErasedComponent where
  ErasedComponent :: (Component c) => c -> ErasedComponent

data ErasedComponentEq where
  ErasedComponentEq :: (Component c, Eq c) => c -> ErasedComponentEq

data ComponentRep = ComponentRep ComponentType | PairRep (ComponentType, Entity) deriving (Show, Eq, Ord)

-- | Element of a 'BundleData e'.
data BundleElement e = BundleElement {rep :: ComponentRep, component :: e}

instance Show (BundleElement a) where
  show :: BundleElement a -> String
  show !e = show e.rep

instance Eq (BundleElement a) where
  (==) :: BundleElement a -> BundleElement a -> Bool
  (==) BundleElement {rep = !rep1} BundleElement {rep = !rep2} = rep1 == rep2

instance Ord (BundleElement a) where
  compare :: BundleElement a -> BundleElement a -> Ordering
  compare BundleElement {rep = !rep1} BundleElement {rep = !rep2} = compare rep1 rep2

-- @Meta@ component containing the erased type of this component.
data ComponentType where
  ComponentType :: forall (c :: Type). (Component c) => (Proxy c) -> ComponentType

instance Show ComponentType where
  show :: ComponentType -> String
  show !x = show $ getRep x

instance Eq ComponentType where
  (==) :: ComponentType -> ComponentType -> Bool
  (==) !a !b = getRep a == getRep b

instance Ord ComponentType where
  compare :: ComponentType -> ComponentType -> Ordering
  compare !a !b = compare (getRep a) (getRep b)

data DefaultComponentType where
  DefaultComponentType :: forall (c :: Type). (Component c, Default c) => (Proxy c) -> DefaultComponentType

instance Show DefaultComponentType where
  show :: DefaultComponentType -> String
  show !x = show $ getRep x

instance Eq DefaultComponentType where
  (==) :: DefaultComponentType -> DefaultComponentType -> Bool
  (==) !a !b = getRep a == getRep b

instance Ord DefaultComponentType where
  compare :: DefaultComponentType -> DefaultComponentType -> Ordering
  compare !a !b = compare (getRep a) (getRep b)

instance GetRep ComponentType where
  getRep :: ComponentType -> TypeRep
  getRep (ComponentType (_ :: (Proxy t))) = typeRep $ Proxy @t

instance GetRep ErasedComponent where
  getRep :: ErasedComponent -> TypeRep
  getRep (ErasedComponent (_ :: c)) = typeRep $ Proxy @c

instance GetRep DefaultComponentType where
  getRep :: DefaultComponentType -> TypeRep
  getRep (DefaultComponentType (_ :: (Proxy t))) = typeRep $ Proxy @t

newtype Tick = Tick Word64
  deriving stock (Show, Eq, Ord)
  deriving newtype (Default)

data IsExclusiveRelationship = IsExclusiveRelationship deriving (Show, Component)