Components.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Apecs.Components where

import Data.Functor.Identity
import qualified Data.IntSet as IS
import qualified Data.Vector.Unboxed as U

import Apecs.Core
import qualified Apecs.THTuples as T

-- | Identity component. @Identity c@ is equivalent to @c@, so mostly useless.
instance (Component c) => Component (Identity c) where
  type Storage (Identity c) = Identity (Storage c)

instance (Has w m c) => Has w m (Identity c) where
  {-# INLINE getStore #-}
  getStore = Identity <$> getStore

type instance Elem (Identity s) = Identity (Elem s)

instance (ExplGet m s) => ExplGet m (Identity s) where
  {-# INLINE explGet #-}
  explGet (Identity s) e = Identity <$> explGet s e
  {-# INLINE explExists #-}
  explExists (Identity s) = explExists s

instance (ExplSet m s) => ExplSet m (Identity s) where
  {-# INLINE explSet #-}
  explSet (Identity s) e (Identity x) = explSet s e x
instance (ExplMembers m s) => ExplMembers m (Identity s) where
  {-# INLINE explMembers #-}
  explMembers (Identity s) = explMembers s
  {-# INLINE explMemberSet #-}
  explMemberSet (Identity s) = explMemberSet s
instance (ExplDestroy m s) => ExplDestroy m (Identity s) where
  {-# INLINE explDestroy #-}
  explDestroy (Identity s) = explDestroy s

T.makeInstances [2 .. 8]

{- | Pseudocomponent indicating the absence of @a@.
  Mainly used as e.g. @cmap $ \(a, Not b) -> c@ to iterate over entities with an @a@ but no @b@.
  Can also be used to delete components, like @cmap $ \a -> (Not :: Not a)@ to delete every @a@ component.
-}
data Not a = Not

-- | Pseudostore used to produce values of type @Not a@, inverts @explExists@, and destroys instead of @explSet@.
newtype NotStore s = NotStore s

instance (Component c) => Component (Not c) where
  type Storage (Not c) = NotStore (Storage c)

instance (Has w m c) => Has w m (Not c) where
  {-# INLINE getStore #-}
  getStore = NotStore <$> getStore

type instance Elem (NotStore s) = Not (Elem s)

instance (ExplGet m s) => ExplGet m (NotStore s) where
  {-# INLINE explGet #-}
  explGet _ _ = return Not
  {-# INLINE explExists #-}
  explExists (NotStore sa) ety = not <$> explExists sa ety

instance (ExplDestroy m s) => ExplSet m (NotStore s) where
  {-# INLINE explSet #-}
  explSet (NotStore sa) ety _ = explDestroy sa ety

{- | Pseudostore used to produce values of type @Maybe a@.
  Will always return @True@ for @explExists@.
  Writing can both set and delete a component using @Just@ and @Nothing@ respectively.
-}
newtype MaybeStore s = MaybeStore s

instance (Component c) => Component (Maybe c) where
  type Storage (Maybe c) = MaybeStore (Storage c)

instance (Has w m c) => Has w m (Maybe c) where
  {-# INLINE getStore #-}
  getStore = MaybeStore <$> getStore

type instance Elem (MaybeStore s) = Maybe (Elem s)

instance (ExplGet m s) => ExplGet m (MaybeStore s) where
  {-# INLINE explGet #-}
  explGet (MaybeStore sa) ety = do
    e <- explExists sa ety
    if e then
      Just <$> explGet sa ety
    else
      return Nothing
  explExists _ _ = return True

instance (ExplDestroy m s, ExplSet m s) => ExplSet m (MaybeStore s) where
  {-# INLINE explSet #-}
  explSet (MaybeStore sa) ety Nothing = explDestroy sa ety
  explSet (MaybeStore sa) ety (Just x) = explSet sa ety x

{- | Used for 'Either', a logical disjunction between two components.
  As expected, Either is used to model error values.
Getting an @Either a b@ will first attempt to get a @b@ and return it as @Right b@, or if it does not exist, get an @a@ as @Left a@.
Can also be used to set one of two things.
-}
data EitherStore sa sb = EitherStore sa sb

instance (Component ca, Component cb) => Component (Either ca cb) where
  type Storage (Either ca cb) = EitherStore (Storage ca) (Storage cb)

instance (Has w m ca, Has w m cb) => Has w m (Either ca cb) where
  {-# INLINE getStore #-}
  getStore = EitherStore <$> getStore <*> getStore

type instance Elem (EitherStore sa sb) = Either (Elem sa) (Elem sb)

instance (ExplGet m sa, ExplGet m sb) => ExplGet m (EitherStore sa sb) where
  {-# INLINE explGet #-}
  explGet (EitherStore sa sb) ety = do
    e <- explExists sb ety
    if e then
      Right <$> explGet sb ety
    else
      Left <$> explGet sa ety
  {-# INLINE explExists #-}
  explExists (EitherStore sa sb) ety = do
    e <- explExists sb ety
    if e then
      return True
    else
      explExists sa ety

instance (ExplSet m sa, ExplSet m sb) => ExplSet m (EitherStore sa sb) where
  {-# INLINE explSet #-}
  explSet (EitherStore _ sb) ety (Right b) = explSet sb ety b
  explSet (EitherStore sa _) ety (Left a) = explSet sa ety a

instance
  (ExplDestroy m sa, ExplDestroy m sb)
  => ExplDestroy m (EitherStore sa sb)
  where
  {-# INLINE explDestroy #-}
  explDestroy (EitherStore sa sb) ety =
    explDestroy sa ety >> explDestroy sb ety

instance (ExplMembers m sa, ExplMembers m sb) => ExplMembers m (EitherStore sa sb) where
  {-# INLINE explMemberSet #-}
  explMemberSet (EitherStore sa sb) = IS.union <$> explMemberSet sa <*> explMemberSet sb
  {-# INLINE explMembers #-}
  explMembers s = U.fromList . IS.toList <$> explMemberSet s

-- Unit instances ()
instance (Monad m) => Has w m () where
  {-# INLINE getStore #-}
  getStore = return ()
instance Component () where
  type Storage () = ()
type instance Elem () = ()
instance (Monad m) => ExplGet m () where
  {-# INLINE explExists #-}
  explExists _ _ = return True
  {-# INLINE explGet #-}
  explGet _ _ = return ()
instance (Monad m) => ExplSet m () where
  {-# INLINE explSet #-}
  explSet _ _ _ = return ()
instance (Monad m) => ExplDestroy m () where
  {-# INLINE explDestroy #-}
  explDestroy _ _ = return ()

{- | Pseudocomponent that functions normally for @explExists@ and @explMembers@, but always return @Filter@ for @explGet@.
  Can be used in cmap as @cmap $ \(Filter :: Filter a) -> b@.
  Since the above can be written more consicely as @cmap $ \(_ :: a) -> b@, it is rarely directly.
  More interestingly, we can define reusable filters like @movables = Filter :: Filter (Position, Velocity)@.
  Note that 'Filter c' is equivalent to 'Not (Not c)'.
-}
data Filter c = Filter deriving (Eq, Show)

-- Pseudostore for 'Filter'.
newtype FilterStore s = FilterStore s

instance (Component c) => Component (Filter c) where
  type Storage (Filter c) = FilterStore (Storage c)

instance (Has w m c) => Has w m (Filter c) where
  {-# INLINE getStore #-}
  getStore = FilterStore <$> getStore

type instance Elem (FilterStore s) = Filter (Elem s)

instance (ExplGet m s) => ExplGet m (FilterStore s) where
  {-# INLINE explGet #-}
  explGet _ _ = return Filter
  {-# INLINE explExists #-}
  explExists (FilterStore s) ety = explExists s ety

instance (ExplMembers m s) => ExplMembers m (FilterStore s) where
  {-# INLINE explMembers #-}
  explMembers (FilterStore s) = explMembers s
  {-# INLINE explMemberSet #-}
  explMemberSet (FilterStore s) = explMemberSet s

{- | Pseudostore used to produce components of type 'Entity'.
Always returns @True@ for @explExists@, and echoes back the entity argument for @explGet@.
Used in e.g. @cmap $ \(a, ety :: Entity) -> b@ to access the current entity.
-}
data EntityStore = EntityStore

instance Component Entity where
  type Storage Entity = EntityStore

instance (Monad m) => Has w m Entity where
  {-# INLINE getStore #-}
  getStore = return EntityStore

type instance Elem EntityStore = Entity
instance (Monad m) => ExplGet m EntityStore where
  {-# INLINE explGet #-}
  explGet _ ety = return $ Entity ety
  {-# INLINE explExists #-}
  explExists _ _ = return True