Store.hs

{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- Module      :  Games.ECS.Component.Store
-- Description : Collection types for components.
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Different components, when stored in bulk, may be suited to different collection types.
module Games.ECS.Component.Store
  ( EntityIndexedTraversable (..),
    InternedComponentStore,
    ComponentStore,
    EntitySet,
    theKeys,
    theMap,
    theInternedMap,
    IntersectionOfEntities,
  )
where

import Control.Lens
import Data.Hashable
import Data.IntMap.Strict qualified as IM
import Data.IntSet qualified as IS
import Data.Interned
import GHC.Generics (Generic, Generic1)
import Games.ECS.Entity

-- | A class for types which contain objects which are indexed by an 'Entity'.
class EntityIndexedTraversable t c where -- TODO make this kind polymorphic

  -- | Traverse the collection.
  entitiesTraversed :: IndexedTraversal' Entity (t c) c
  default entitiesTraversed :: (TraversableWithIndex Entity t) => IndexedTraversal' Entity (t c) c
  entitiesTraversed = itraversed
  {-# INLINE entitiesTraversed #-}

-- | An 'IS.IntMap'-based 'Games.ECS.Component.Component' store
data ComponentStore c = ComponentStore {_theMap :: IM.IntMap c, _theKeys :: EntitySet} deriving (Eq, Show, Functor, Generic1, Foldable, Traversable, Generic)

-- deriving instance Generic (ComponentStore c)
instance FunctorWithIndex Entity (ComponentStore) where
  {-# INLINE imap #-}
  imap f (ComponentStore s ks) = ComponentStore (IM.mapWithKey (f . EntRef) s) ks

instance EntityIndexedTraversable ComponentStore c

instance FoldableWithIndex Entity ComponentStore where
  {-# INLINE ifoldMap #-}
  {-# INLINE ifoldr #-}
  {-# INLINE ifoldl' #-}
  ifoldMap f (ComponentStore s _) = IM.foldMapWithKey (f . EntRef) s
  ifoldr f b (ComponentStore s _) = IM.foldrWithKey (f . EntRef) b s
  ifoldl' f b (ComponentStore s _) = IM.foldlWithKey' (flip (f . EntRef)) b s

instance TraversableWithIndex Entity ComponentStore where
  {-# INLINE itraverse #-}
  itraverse f (ComponentStore s ks) = fmap (\i -> ComponentStore i ks) $ itraverse (f . EntRef) s

type instance Index (ComponentStore c) = Entity

type instance IxValue (ComponentStore c) = c

instance At (ComponentStore c) where
  {-# INLINE at #-}
  at (EntRef k) f cs@(ComponentStore s (EntitySet ks)) =
    f mv <&> \r -> case r of
      Nothing -> maybe cs (const (ComponentStore (IM.delete k s) (EntitySet (IS.delete k ks)))) mv
      Just v' -> ComponentStore (IM.insert k v' s) (EntitySet (IS.insert k ks))
    where
      mv = IM.lookup k s

instance Ixed (ComponentStore c) where
  {-# INLINE ix #-}
  ix (EntRef k) f (ComponentStore s ks) = fmap (\i -> ComponentStore i ks) $ ix k f s

instance AsEmpty (ComponentStore c) where
  {-# INLINE _Empty #-}
  _Empty = nearly (ComponentStore IM.empty (EntitySet IS.empty)) (\(ComponentStore _ (EntitySet ks)) -> IS.null ks)

makeLenses ''ComponentStore

instance HasEntitySet (ComponentStore c) where
  {-# INLINE entitySet #-}
  entitySet = theKeys

data InternedComponent c = InternedComponent {_internedId :: Id, _internedValue :: c} deriving (Generic, Show)

instance Eq (InternedComponent c) where
  {-# INLINE (==) #-}
  InternedComponent a _ == InternedComponent b _ = a == b

instance Ord (InternedComponent c) where
  {-# INLINE compare #-}
  compare (InternedComponent a _) (InternedComponent b _) = compare a b

instance Hashable (InternedComponent c) where
  {-# INLINE hashWithSalt #-}
  hashWithSalt s (InternedComponent i _) = hashWithSalt s i

instance (Hashable c, Eq c) => Interned (InternedComponent c) where
  type Uninterned (InternedComponent c) = c
  newtype Description (InternedComponent c) = DSC c deriving (Eq)
  {-# INLINE CONLIKE describe #-}
  describe = DSC
  {-# INLINE CONLIKE identify #-}
  identify = InternedComponent
  {-# INLINE CONLIKE cache #-}
  cache = itCache

itCache :: (Eq c, Hashable c) => Cache (InternedComponent c)
itCache = mkCache
{-# NOINLINE itCache #-}

instance (Hashable c) => Hashable (Description (InternedComponent c)) where
  hashWithSalt s (DSC c) = hashWithSalt s c
  {-# INLINE hashWithSalt #-}

instance (Eq c, Hashable c) => Uninternable (InternedComponent c) where
  unintern (InternedComponent _ c) = c
  {-# INLINE unintern #-}

-- | Some components may be shared in common among a large number of entities, and may be expensive to compare for equality. This type can be used to store them efficiently by keeping only a single example around.
data InternedComponentStore c = InternedComponentStore {_theInternedMap :: IM.IntMap (InternedComponent c), _theInternedKeys :: EntitySet} deriving (Eq, Show, Generic, Generic1)

type instance Index (InternedComponentStore c) = Entity

type instance IxValue (InternedComponentStore c) = c

instance (Eq c, Hashable c) => At (InternedComponentStore c) where
  {-# INLINE at #-}
  at (EntRef k) f cs@(InternedComponentStore s (EntitySet ks)) =
    f mv <&> \r -> case r of
      Nothing -> maybe cs (const (InternedComponentStore (IM.delete k s) (EntitySet (IS.delete k ks)))) mv
      Just v' -> InternedComponentStore (IM.insert k (intern v') s) (EntitySet (IS.insert k ks))
    where
      mv = fmap unintern $ IM.lookup k s

instance (Eq c, Hashable c) => Ixed (InternedComponentStore c) where
  {-# INLINE ix #-}
  ix (EntRef k) f (InternedComponentStore s ks) = fmap (\i -> InternedComponentStore i ks) $ ix k (fmap intern . f . unintern) s

instance AsEmpty (InternedComponentStore c) where
  {-# INLINE _Empty #-}
  _Empty = nearly (InternedComponentStore IM.empty (EntitySet IS.empty)) (\(InternedComponentStore _ (EntitySet ks)) -> IS.null ks)

makeLenses ''InternedComponentStore

{-# INLINE toNormalCS #-}
toNormalCS :: (Uninternable (InternedComponent c)) => InternedComponentStore c -> ComponentStore c
toNormalCS (InternedComponentStore ics iks) = ComponentStore (fmap unintern ics) iks

{-# INLINE toInternedCS #-}
toInternedCS :: (Interned (InternedComponent c)) => ComponentStore c -> InternedComponentStore c
toInternedCS (ComponentStore cs ks) = InternedComponentStore (fmap intern cs) ks

internedComponentStore :: (Uninternable (InternedComponent c)) => Iso' (ComponentStore c) (InternedComponentStore c)
internedComponentStore = iso toInternedCS toNormalCS
{-# INLINE internedComponentStore #-}

instance HasEntitySet (InternedComponentStore c) where
  {-# INLINE entitySet #-}
  entitySet = theInternedKeys

instance (Uninternable (InternedComponent c)) => EntityIndexedTraversable InternedComponentStore c where
  {-# INLINE entitiesTraversed #-}
  entitiesTraversed = (from internedComponentStore) . entitiesTraversed