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