Entity.hs

{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :  Games.ECS.Entity
-- Description : Entity references.
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- In an ECS, an /entity/ is understood in two senses:
--
--     1. An identifying token, used to specify an /individual/, and
--     2. The /individual/ it refers to, that is, the set of components it has.
--
-- Here, we implement entities in the first sense.
module Games.ECS.Entity
  ( Entity (..),
    HasEntityReferences (..),
    EntitySet (EntitySet),
    theEntitySet,
    singletonEntitySet,
    asIntersection,
    IntersectionOfEntities (Intersect),
    IsEntityStore (..),
    HasEntitySet (..),
  )
where

import Control.Lens
import Data.Coerce
import Data.HashMap.Strict as HMS
import Data.HashSet qualified as HS
import Data.Hashable
import Data.Int
import Data.IntSet qualified as IS
import Data.IntSet.Lens
import Data.Ix
import Data.String
import Data.Vector.Unboxed.Deriving
import GHC.Generics
import Games.ECS.Serialisation
import System.ByteOrder

-- | A reference to an entity in the ECS.
newtype Entity = EntRef {unEntRef :: Int}
  deriving newtype (Eq, Ord, Enum, Bounded, Ix)
  deriving newtype (XMLPickleAsAttribute)
  deriving stock (Generic)

instance {-# OVERLAPS #-} XMLPickler [Node] Entity where
  {-# INLINE xpickle #-}
  xpickle = ("Entity w/ attribute", "") <?+> (xpElemAttrs "entity" (xpAttribute "entRef" (xpWrap EntRef unEntRef xpPrim)))

-- | An instance for constructors which only  contain an entity reference; we put that as an attribute.
instance {-# OVERLAPPING #-} (Constructor c'', ty ~ (M1 C c'' (M1 S c (K1 i Entity)))) => GXmlPickler [Node] (M1 C c'' (M1 S c (K1 i Entity))) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf _ = ("Entity reference wrapper", "") <?+> (xpElemAttrs (fromString . formatElement $ conName (undefined :: ty p)) (xpWrap (M1 . M1 . K1) (unK1 . unM1 . unM1) (pickleAsAttribute "entRef")))

-- | We reverse the byte order, just so there is a bit more variance between hashes.
instance Hashable Entity where
  {-# INLINE hash #-}
  hash (EntRef i) = hash $ toBigEndian @Int64 (fromIntegral i)
  {-# INLINE hashWithSalt #-}
  hashWithSalt salt (EntRef i) = hashWithSalt salt (toBigEndian @Int64 (fromIntegral i))

instance Show Entity where
  {-# INLINE show #-}
  show (EntRef ref) = "EntRef: " ++ show ref

instance {-# OVERLAPPABLE #-} (XMLPickler [Node] v) => XMLPickler [Node] (HashMap Entity v) where
  {-# INLINE xpickle #-}
  xpickle =
    ("Entity-indexed HashMap", "")
      <?+> ( xpWrap HMS.fromList HMS.toList $
               xpAll $
                 xpElem "li" (pickleAsAttribute "entRef") xpickle
           )

-- | A helper class for finding embedded entity references in components.
class HasEntityReferences c where
  getEntityReferences :: Fold c Entity

instance HasEntityReferences Entity where
  {-# INLINE getEntityReferences #-}
  getEntityReferences = id

-- | An efficient storage for a collection of entities.
newtype EntitySet = EntitySet {_theEntitySet :: IS.IntSet}
  deriving newtype (Eq, Show, Semigroup, Monoid)

instance HasEntityReferences EntitySet where
  {-# INLINE getEntityReferences #-}
  getEntityReferences = coerced . members . Control.Lens.to EntRef

makeLensesWith (lensRules & generateSignatures .~ False) ''EntitySet

-- | Access the underlying 'IS.IntSet'.
theEntitySet :: Iso' EntitySet IS.IntSet

{-# INLINE singletonEntitySet #-}

-- | Construct a new t'EntitySet' with a given 'Entity'.
singletonEntitySet :: Entity -> EntitySet
singletonEntitySet (EntRef k) = EntitySet (IS.singleton k)

{-# INLINE asIntersection #-}

-- | Helper `Iso'` for selecting entities which satisfy predicates.
asIntersection :: Iso' IntersectionOfEntities EntitySet
asIntersection = iso (\case Intersect es -> EntitySet es) (Intersect . _theEntitySet)

-- | A helper 'Monoid' for selecting entities which satisfy multiple predicates.
newtype IntersectionOfEntities = Intersect {_unIntersect :: IS.IntSet} deriving stock (Eq, Show)

instance Semigroup IntersectionOfEntities where
  {-# INLINE (<>) #-}
  (Intersect a) <> (Intersect b) = Intersect (IS.intersection a b)

instance Monoid IntersectionOfEntities where
  mempty = error "mempty IntersectionOfEntities"

-- | Generalisation of an t'EntitySet'.
class IsEntityStore a where
  -- | 'Control.Lens.Type.Fold' over each 'Entity' it holds.
  knownEntities :: Fold a Entity

  -- | Empty storage.
  blankEntityStorage :: a

instance IsEntityStore (HS.HashSet Entity) where
  {-# INLINE knownEntities #-}
  knownEntities = folded
  blankEntityStorage = HS.empty

instance IsEntityStore IS.IntSet where
  {-# INLINE knownEntities #-}
  knownEntities = members . coerced @Int @Int @Entity @Entity
  blankEntityStorage = IS.empty

instance IsEntityStore EntitySet where
  {-# INLINE knownEntities #-}
  knownEntities = theEntitySet . knownEntities
  blankEntityStorage = EntitySet blankEntityStorage

instance IsEntityStore IntersectionOfEntities where
  {-# INLINE knownEntities #-}
  knownEntities = asIntersection . knownEntities
  blankEntityStorage = Intersect blankEntityStorage

derivingUnbox
  "Entity"
  [t|Entity -> Int|]
  [|coerce|]
  [|coerce|]

-- | For types which may have one or more t'EntitySet'.
class HasEntitySet a where
  entitySet :: Fold a EntitySet

instance HasEntitySet EntitySet where
  {-# INLINE entitySet #-}
  entitySet = simple

instance HasEntitySet IntersectionOfEntities where
  {-# INLINE entitySet #-}
  entitySet = asIntersection