{-# OPTIONS_GHC -Wno-orphans #-}

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

module Apecs.Components where

import Data.Functor.Identity

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 :: SystemT w m (Storage (Identity c))
getStore = Storage c -> Identity (Storage c)
forall a. a -> Identity a
Identity (Storage c -> Identity (Storage c))
-> SystemT w m (Storage c) -> SystemT w m (Identity (Storage c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore

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

instance ExplGet m s => ExplGet m (Identity s) where
  {-# INLINE explGet #-}
  explGet :: Identity s -> Int -> m (Elem (Identity s))
explGet (Identity s
s) Int
e = Elem s -> Identity (Elem s)
forall a. a -> Identity a
Identity (Elem s -> Identity (Elem s))
-> m (Elem s) -> m (Identity (Elem s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Int -> m (Elem s)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s
s Int
e
  {-# INLINE explExists  #-}
  explExists :: Identity s -> Int -> m Bool
explExists  (Identity s
s) = s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s

instance ExplSet m s => ExplSet m (Identity s) where
  {-# INLINE explSet #-}
  explSet :: Identity s -> Int -> Elem (Identity s) -> m ()
explSet (Identity s
s) Int
e (Identity x) = s -> Int -> Elem s -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
s Int
e Elem s
x
instance ExplMembers m s => ExplMembers m (Identity s) where
  {-# INLINE explMembers #-}
  explMembers :: Identity s -> m (Vector Int)
explMembers (Identity s
s) = s -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
s
instance ExplDestroy m s => ExplDestroy m (Identity s) where
  {-# INLINE explDestroy #-}
  explDestroy :: Identity s -> Int -> m ()
explDestroy (Identity s
s) = s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
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 :: SystemT w m (Storage (Not c))
getStore = Storage c -> NotStore (Storage c)
forall s. s -> NotStore s
NotStore (Storage c -> NotStore (Storage c))
-> SystemT w m (Storage c) -> SystemT w m (NotStore (Storage c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore

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

instance ExplGet m s => ExplGet m (NotStore s) where
  {-# INLINE explGet #-}
  explGet :: NotStore s -> Int -> m (Elem (NotStore s))
explGet NotStore s
_ Int
_ = Not (Elem s) -> m (Not (Elem s))
forall (m :: * -> *) a. Monad m => a -> m a
return Not (Elem s)
forall a. Not a
Not
  {-# INLINE explExists #-}
  explExists :: NotStore s -> Int -> m Bool
explExists (NotStore s
sa) Int
ety = Bool -> Bool
not (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
sa Int
ety

instance ExplDestroy m s => ExplSet m (NotStore s) where
  {-# INLINE explSet #-}
  explSet :: NotStore s -> Int -> Elem (NotStore s) -> m ()
explSet (NotStore s
sa) Int
ety Elem (NotStore s)
_ = s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
sa Int
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 :: SystemT w m (Storage (Maybe c))
getStore = Storage c -> MaybeStore (Storage c)
forall s. s -> MaybeStore s
MaybeStore (Storage c -> MaybeStore (Storage c))
-> SystemT w m (Storage c) -> SystemT w m (MaybeStore (Storage c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore

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

instance ExplGet m s => ExplGet m (MaybeStore s) where
  {-# INLINE explGet #-}
  explGet :: MaybeStore s -> Int -> m (Elem (MaybeStore s))
explGet (MaybeStore s
sa) Int
ety = do
    Bool
e <- s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
sa Int
ety
    if Bool
e then Elem s -> Maybe (Elem s)
forall a. a -> Maybe a
Just (Elem s -> Maybe (Elem s)) -> m (Elem s) -> m (Maybe (Elem s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Int -> m (Elem s)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s
sa Int
ety
         else Maybe (Elem s) -> m (Maybe (Elem s))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Elem s)
forall a. Maybe a
Nothing
  explExists :: MaybeStore s -> Int -> m Bool
explExists MaybeStore s
_ Int
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

instance (ExplDestroy m s, ExplSet m s) => ExplSet m (MaybeStore s) where
  {-# INLINE explSet #-}
  explSet :: MaybeStore s -> Int -> Elem (MaybeStore s) -> m ()
explSet (MaybeStore s
sa) Int
ety Elem (MaybeStore s)
Nothing  = s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
sa Int
ety
  explSet (MaybeStore s
sa) Int
ety (Just x) = s -> Int -> Elem s -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
sa Int
ety Elem s
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 :: SystemT w m (Storage (Either ca cb))
getStore = Storage ca -> Storage cb -> EitherStore (Storage ca) (Storage cb)
forall sa sb. sa -> sb -> EitherStore sa sb
EitherStore (Storage ca -> Storage cb -> EitherStore (Storage ca) (Storage cb))
-> SystemT w m (Storage ca)
-> SystemT
     w m (Storage cb -> EitherStore (Storage ca) (Storage cb))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Storage ca)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore SystemT w m (Storage cb -> EitherStore (Storage ca) (Storage cb))
-> SystemT w m (Storage cb)
-> SystemT w m (EitherStore (Storage ca) (Storage cb))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SystemT w m (Storage cb)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
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 -> Int -> m (Elem (EitherStore sa sb))
explGet (EitherStore sa
sa sb
sb) Int
ety = do
    Bool
e <- sb -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists sb
sb Int
ety
    if Bool
e then Elem sb -> Either (Elem sa) (Elem sb)
forall a b. b -> Either a b
Right (Elem sb -> Either (Elem sa) (Elem sb))
-> m (Elem sb) -> m (Either (Elem sa) (Elem sb))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sb -> Int -> m (Elem sb)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet sb
sb Int
ety
         else Elem sa -> Either (Elem sa) (Elem sb)
forall a b. a -> Either a b
Left (Elem sa -> Either (Elem sa) (Elem sb))
-> m (Elem sa) -> m (Either (Elem sa) (Elem sb))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sa -> Int -> m (Elem sa)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet sa
sa Int
ety
  {-# INLINE explExists #-}
  explExists :: EitherStore sa sb -> Int -> m Bool
explExists (EitherStore sa
sa sb
sb) Int
ety = do
    Bool
e <- sb -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists sb
sb Int
ety
    if Bool
e then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
         else sa -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists sa
sa Int
ety

instance (ExplSet m sa, ExplSet m sb) => ExplSet m (EitherStore sa sb) where
  {-# INLINE explSet #-}
  explSet :: EitherStore sa sb -> Int -> Elem (EitherStore sa sb) -> m ()
explSet (EitherStore sa
_ sb
sb) Int
ety (Right b) = sb -> Int -> Elem sb -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet sb
sb Int
ety Elem sb
b
  explSet (EitherStore sa
sa sb
_) Int
ety (Left a)  = sa -> Int -> Elem sa -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet sa
sa Int
ety Elem sa
a

instance (ExplDestroy m sa, ExplDestroy m sb)
       => ExplDestroy m (EitherStore sa sb) where
  {-# INLINE explDestroy #-}
  explDestroy :: EitherStore sa sb -> Int -> m ()
explDestroy (EitherStore sa
sa sb
sb) Int
ety =
    sa -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy sa
sa Int
ety m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> sb -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy sb
sb Int
ety

-- Unit instances ()
instance Monad m => Has w m () where
  {-# INLINE getStore #-}
  getStore :: SystemT w m (Storage ())
getStore = () -> SystemT w m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance Component () where
  type Storage () = ()
type instance Elem () = ()
instance Monad m => ExplGet m () where
  {-# INLINE explExists #-}
  explExists :: () -> Int -> m Bool
explExists ()
_ Int
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  {-# INLINE explGet #-}
  explGet :: () -> Int -> m (Elem ())
explGet ()
_ Int
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance Monad m => ExplSet m () where
  {-# INLINE explSet #-}
  explSet :: () -> Int -> Elem () -> m ()
explSet ()
_ Int
_ Elem ()
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance Monad m => ExplDestroy m () where
  {-# INLINE explDestroy #-}
  explDestroy :: () -> Int -> m ()
explDestroy ()
_ Int
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 (Filter c -> Filter c -> Bool
(Filter c -> Filter c -> Bool)
-> (Filter c -> Filter c -> Bool) -> Eq (Filter c)
forall c. Filter c -> Filter c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Filter c -> Filter c -> Bool
$c/= :: forall c. Filter c -> Filter c -> Bool
== :: Filter c -> Filter c -> Bool
$c== :: forall c. Filter c -> Filter c -> Bool
Eq, Int -> Filter c -> ShowS
[Filter c] -> ShowS
Filter c -> String
(Int -> Filter c -> ShowS)
-> (Filter c -> String) -> ([Filter c] -> ShowS) -> Show (Filter c)
forall c. Int -> Filter c -> ShowS
forall c. [Filter c] -> ShowS
forall c. Filter c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Filter c] -> ShowS
$cshowList :: forall c. [Filter c] -> ShowS
show :: Filter c -> String
$cshow :: forall c. Filter c -> String
showsPrec :: Int -> Filter c -> ShowS
$cshowsPrec :: forall c. Int -> Filter c -> ShowS
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 :: SystemT w m (Storage (Filter c))
getStore = Storage c -> FilterStore (Storage c)
forall s. s -> FilterStore s
FilterStore (Storage c -> FilterStore (Storage c))
-> SystemT w m (Storage c) -> SystemT w m (FilterStore (Storage c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore

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

instance ExplGet m s => ExplGet m (FilterStore s) where
  {-# INLINE explGet #-}
  explGet :: FilterStore s -> Int -> m (Elem (FilterStore s))
explGet FilterStore s
_ Int
_ = Filter (Elem s) -> m (Filter (Elem s))
forall (m :: * -> *) a. Monad m => a -> m a
return Filter (Elem s)
forall c. Filter c
Filter
  {-# INLINE explExists #-}
  explExists :: FilterStore s -> Int -> m Bool
explExists (FilterStore s
s) Int
ety = s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s Int
ety

instance ExplMembers m s => ExplMembers m (FilterStore s) where
  {-# INLINE explMembers #-}
  explMembers :: FilterStore s -> m (Vector Int)
explMembers (FilterStore s
s) = s -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
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 :: SystemT w m (Storage Entity)
getStore = EntityStore -> SystemT w m EntityStore
forall (m :: * -> *) a. Monad m => a -> m a
return EntityStore
EntityStore

type instance Elem EntityStore = Entity
instance Monad m => ExplGet m EntityStore where
  {-# INLINE explGet #-}
  explGet :: EntityStore -> Int -> m (Elem EntityStore)
explGet EntityStore
_ Int
ety = Entity -> m Entity
forall (m :: * -> *) a. Monad m => a -> m a
return (Entity -> m Entity) -> Entity -> m Entity
forall a b. (a -> b) -> a -> b
$ Int -> Entity
Entity Int
ety
  {-# INLINE explExists #-}
  explExists :: EntityStore -> Int -> m Bool
explExists EntityStore
_ Int
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True