{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE Strict                #-}

module Apecs.System where

import           Control.Monad
import           Control.Monad.Reader
import           Data.Proxy
import qualified Data.Vector.Unboxed  as U

import Apecs.Components ()
import Apecs.Core

-- | Run a system in a game world
{-# INLINE runSystem #-}
runSystem :: SystemT w m a -> w -> m a
runSystem :: SystemT w m a -> w -> m a
runSystem SystemT w m a
sys = ReaderT w m a -> w -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SystemT w m a -> ReaderT w m a
forall w (m :: * -> *) a. SystemT w m a -> ReaderT w m a
unSystem SystemT w m a
sys)

-- | Run a system in a game world
{-# INLINE runWith #-}
runWith :: w -> SystemT w m a -> m a
runWith :: w -> SystemT w m a -> m a
runWith = (SystemT w m a -> w -> m a) -> w -> SystemT w m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip SystemT w m a -> w -> m a
forall w (m :: * -> *) a. SystemT w m a -> w -> m a
runSystem

-- | Read a Component
{-# INLINE get #-}
get :: forall w m c. Get w m c => Entity -> SystemT w m c
get :: Entity -> SystemT w m c
get (Entity Int
ety) = do
  s :: Storage c <- SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m c -> SystemT w m c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m c -> SystemT w m c) -> m c -> SystemT w m c
forall a b. (a -> b) -> a -> b
$ Storage c -> Int -> m (Elem (Storage c))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage c
s Int
ety

-- | Writes a Component to a given Entity. Will overwrite existing Components.
{-# INLINE set #-}
set, ($=) :: forall w m c. Set w m c => Entity -> c -> SystemT w m ()
set :: Entity -> c -> SystemT w m ()
set (Entity Int
ety) c
x = do
  s :: Storage c <- SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ Storage c -> Int -> Elem (Storage c) -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Storage c
s Int
ety c
Elem (Storage c)
x

-- | @set@ operator
$= :: Entity -> c -> SystemT w m ()
($=) = Entity -> c -> SystemT w m ()
forall w (m :: * -> *) c.
Set w m c =>
Entity -> c -> SystemT w m ()
set
infixr 2 $=

-- | Returns whether the given entity has component @c@
{-# INLINE exists #-}
exists :: forall w m c. Get w m c => Entity -> Proxy c -> SystemT w m Bool
exists :: Entity -> Proxy c -> SystemT w m Bool
exists (Entity Int
ety) Proxy c
_ = do
  s :: Storage c <- SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m Bool -> SystemT w m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m Bool -> SystemT w m Bool) -> m Bool -> SystemT w m Bool
forall a b. (a -> b) -> a -> b
$ Storage c -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists Storage c
s Int
ety

-- | Destroys component @c@ for the given entity.
{-# INLINE destroy #-}
destroy :: forall w m c. Destroy w m c => Entity -> Proxy c -> SystemT w m ()
destroy :: Entity -> Proxy c -> SystemT w m ()
destroy (Entity Int
ety) ~Proxy c
_ = do
  s :: Storage c <- SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ Storage c -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy Storage c
s Int
ety

-- | Applies a function, if possible.
{-# INLINE modify #-}
modify, ($~) :: forall w m cx cy. (Get w m cx, Set w m cy) => Entity -> (cx -> cy) -> SystemT w m ()
modify :: Entity -> (cx -> cy) -> SystemT w m ()
modify (Entity Int
ety) cx -> cy
f = do
  sx :: Storage cx <- SystemT w m (Storage cx)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  sy :: Storage cy <- SystemT w m (Storage cy)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
possible <- Storage cx -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists Storage cx
sx Int
ety
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
possible (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      cx
x <- Storage cx -> Int -> m (Elem (Storage cx))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage cx
sx Int
ety
      Storage cy -> Int -> Elem (Storage cy) -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Storage cy
sy Int
ety (cx -> cy
f cx
x)

-- | @modify@ operator
$~ :: Entity -> (cx -> cy) -> SystemT w m ()
($~) = Entity -> (cx -> cy) -> SystemT w m ()
forall w (m :: * -> *) cx cy.
(Get w m cx, Set w m cy) =>
Entity -> (cx -> cy) -> SystemT w m ()
modify
infixr 2 $~

-- | Maps a function over all entities with a @cx@, and writes their @cy@.
{-# INLINE cmap #-}
cmap :: forall w m cx cy. (Get w m cx, Members w m cx, Set w m cy)
     => (cx -> cy) -> SystemT w m ()
cmap :: (cx -> cy) -> SystemT w m ()
cmap cx -> cy
f = do
  sx :: Storage cx <- SystemT w m (Storage cx)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  sy :: Storage cy <- SystemT w m (Storage cy)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ do
    Vector Int
sl <- Storage cx -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers Storage cx
sx
    Vector Int -> (Int -> m ()) -> m ()
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
Vector a -> (a -> m b) -> m ()
U.forM_ Vector Int
sl ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ Int
e -> do
      cx
r <- Storage cx -> Int -> m (Elem (Storage cx))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage cx
sx Int
e
      Storage cy -> Int -> Elem (Storage cy) -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Storage cy
sy Int
e (cx -> cy
f cx
r)

-- | Conditional @cmap@, that first tests whether the argument satisfies some property.
--   The entity needs to have both a cx and cp component.
{-# INLINE cmapIf #-}
cmapIf :: forall w m cp cx cy.
  ( Get w m cx
  , Get w m cp
  , Members w m cx
  , Set w m cy )
  => (cp -> Bool)
  -> (cx -> cy)
  -> SystemT w m ()
cmapIf :: (cp -> Bool) -> (cx -> cy) -> SystemT w m ()
cmapIf cp -> Bool
cond cx -> cy
f = do
  sp :: Storage cp <- SystemT w m (Storage cp)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  sx :: Storage cx <- SystemT w m (Storage cx)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  sy :: Storage cy <- SystemT w m (Storage cy)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ do
    Vector Int
sl <- (Storage cx, Storage cp) -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers (Storage cx
sx,Storage cp
sp)
    Vector Int -> (Int -> m ()) -> m ()
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
Vector a -> (a -> m b) -> m ()
U.forM_ Vector Int
sl ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ Int
e -> do
      cp
p <- Storage cp -> Int -> m (Elem (Storage cp))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage cp
sp Int
e
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (cp -> Bool
cond cp
p) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        cx
x <- Storage cx -> Int -> m (Elem (Storage cx))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage cx
sx Int
e
        Storage cy -> Int -> Elem (Storage cy) -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Storage cy
sy Int
e (cx -> cy
f cx
x)

-- | Monadically iterates over all entites with a @cx@, and writes their @cy@.
{-# INLINE cmapM #-}
cmapM :: forall w m cx cy. (Get w m cx, Set w m cy, Members w m cx)
      => (cx -> SystemT w m cy) -> SystemT w m ()
cmapM :: (cx -> SystemT w m cy) -> SystemT w m ()
cmapM cx -> SystemT w m cy
sys = do
  sx :: Storage cx <- SystemT w m (Storage cx)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  sy :: Storage cy <- SystemT w m (Storage cy)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  Vector Int
sl <- m (Vector Int) -> SystemT w m (Vector Int)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m (Vector Int) -> SystemT w m (Vector Int))
-> m (Vector Int) -> SystemT w m (Vector Int)
forall a b. (a -> b) -> a -> b
$ Storage cx -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers Storage cx
sx
  Vector Int -> (Int -> SystemT w m ()) -> SystemT w m ()
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
Vector a -> (a -> m b) -> m ()
U.forM_ Vector Int
sl ((Int -> SystemT w m ()) -> SystemT w m ())
-> (Int -> SystemT w m ()) -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ \ Int
e -> do
    cx
x <- m cx -> SystemT w m cx
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m cx -> SystemT w m cx) -> m cx -> SystemT w m cx
forall a b. (a -> b) -> a -> b
$ Storage cx -> Int -> m (Elem (Storage cx))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage cx
sx Int
e
    cy
y <- cx -> SystemT w m cy
sys cx
x
    m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ Storage cy -> Int -> Elem (Storage cy) -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet Storage cy
sy Int
e cy
Elem (Storage cy)
y

-- | Monadically iterates over all entites with a @cx@
{-# INLINE cmapM_ #-}
cmapM_ :: forall w m c. (Get w m c, Members w m c)
       => (c -> SystemT w m ()) -> SystemT w m ()
cmapM_ :: (c -> SystemT w m ()) -> SystemT w m ()
cmapM_ c -> SystemT w m ()
sys = do
  s :: Storage c <- SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  Vector Int
sl <- m (Vector Int) -> SystemT w m (Vector Int)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m (Vector Int) -> SystemT w m (Vector Int))
-> m (Vector Int) -> SystemT w m (Vector Int)
forall a b. (a -> b) -> a -> b
$ Storage c -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers Storage c
s
  Vector Int -> (Int -> SystemT w m ()) -> SystemT w m ()
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
Vector a -> (a -> m b) -> m ()
U.forM_ Vector Int
sl ((Int -> SystemT w m ()) -> SystemT w m ())
-> (Int -> SystemT w m ()) -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ \ Int
ety -> do
    c
x <- m c -> SystemT w m c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m c -> SystemT w m c) -> m c -> SystemT w m c
forall a b. (a -> b) -> a -> b
$ Storage c -> Int -> m (Elem (Storage c))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage c
s Int
ety
    c -> SystemT w m ()
sys c
x

-- | Fold over the game world; for example, @cfold max (minBound :: Foo)@ will find the maximum value of @Foo@.
--   Strict in the accumulator.
{-# INLINE cfold #-}
cfold :: forall w m c a. (Members w m c, Get w m c)
      => (a -> c -> a) -> a -> SystemT w m a
cfold :: (a -> c -> a) -> a -> SystemT w m a
cfold a -> c -> a
f a
a0 = do
  s :: Storage c <- SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  Vector Int
sl <- m (Vector Int) -> SystemT w m (Vector Int)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m (Vector Int) -> SystemT w m (Vector Int))
-> m (Vector Int) -> SystemT w m (Vector Int)
forall a b. (a -> b) -> a -> b
$ Storage c -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers Storage c
s
  m a -> SystemT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m a -> SystemT w m a) -> m a -> SystemT w m a
forall a b. (a -> b) -> a -> b
$ (a -> Int -> m a) -> a -> Vector Int -> m a
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m a
U.foldM' (\a
a Int
e -> a -> c -> a
f a
a (c -> a) -> m c -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage c -> Int -> m (Elem (Storage c))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage c
s Int
e) a
a0 Vector Int
sl

-- | Monadically fold over the game world.
--   Strict in the accumulator.
{-# INLINE cfoldM #-}
cfoldM :: forall w m c a. (Members w m c, Get w m c)
       => (a -> c -> SystemT w m a) -> a -> SystemT w m a
cfoldM :: (a -> c -> SystemT w m a) -> a -> SystemT w m a
cfoldM a -> c -> SystemT w m a
sys a
a0 = do
  s :: Storage c <- SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  Vector Int
sl <- m (Vector Int) -> SystemT w m (Vector Int)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m (Vector Int) -> SystemT w m (Vector Int))
-> m (Vector Int) -> SystemT w m (Vector Int)
forall a b. (a -> b) -> a -> b
$ Storage c -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers Storage c
s
  (a -> Int -> SystemT w m a) -> a -> Vector Int -> SystemT w m a
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m a
U.foldM' (\a
a Int
e -> m c -> SystemT w m c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Storage c -> Int -> m (Elem (Storage c))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage c
s Int
e) SystemT w m c -> (c -> SystemT w m a) -> SystemT w m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> c -> SystemT w m a
sys a
a) a
a0 Vector Int
sl

-- | Monadically fold over the game world.
--   Strict in the accumulator.
{-# INLINE cfoldM_ #-}
cfoldM_ :: forall w m c a. (Members w m c, Get w m c)
       => (a -> c -> SystemT w m a) -> a -> SystemT w m ()
cfoldM_ :: (a -> c -> SystemT w m a) -> a -> SystemT w m ()
cfoldM_ a -> c -> SystemT w m a
sys a
a0 = do
  s :: Storage c <- SystemT w m (Storage c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  Vector Int
sl <- m (Vector Int) -> SystemT w m (Vector Int)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(m (Vector Int) -> SystemT w m (Vector Int))
-> m (Vector Int) -> SystemT w m (Vector Int)
forall a b. (a -> b) -> a -> b
$ Storage c -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers Storage c
s
  (a -> Int -> SystemT w m a) -> a -> Vector Int -> SystemT w m ()
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m ()
U.foldM'_ (\a
a Int
e -> m c -> SystemT w m c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Storage c -> Int -> m (Elem (Storage c))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet Storage c
s Int
e) SystemT w m c -> (c -> SystemT w m a) -> SystemT w m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> c -> SystemT w m a
sys a
a) a
a0 Vector Int
sl