System.hs

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

module Apecs.System where

import Control.Monad
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.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 = runReaderT

-- | Run a system in a game world
{-# INLINE runWith #-}
runWith :: w -> SystemT w m a -> m a
runWith = flip runSystem

-- | Read a Component
{-# INLINE get #-}
get :: forall w m c. (Get w m c) => Entity -> SystemT w m c
get (Entity ety) = do
  s :: Storage c <- getStore
  lift $ explGet s 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 ety) x = do
  s :: Storage c <- getStore
  lift $ explSet s ety x

-- | @set@ operator
($=) = 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 ety) _ = do
  s :: Storage c <- getStore
  lift $ explExists s 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 ety) ~_ = do
  s :: Storage c <- getStore
  lift $ explDestroy s 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 ety) f = do
  sx :: Storage cx <- getStore
  sy :: Storage cy <- getStore
  lift $ do
    possible <- explExists sx ety
    when possible $ do
      x <- explGet sx ety
      explSet sy ety (f x)

-- | @modify@ operator
($~) = 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 f = do
  sx :: Storage cx <- getStore
  sy :: Storage cy <- getStore
  lift $ do
    sl <- explMembers sx
    U.forM_ sl $ \e -> do
      r <- explGet sx e
      explSet sy e (f 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 cond f = do
  sp :: Storage cp <- getStore
  sx :: Storage cx <- getStore
  sy :: Storage cy <- getStore
  lift $ do
    sl <- explMembers (sx, sp)
    U.forM_ sl $ \e -> do
      p <- explGet sp e
      when (cond p) $ do
        x <- explGet sx e
        explSet sy e (f 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 sys = do
  sx :: Storage cx <- getStore
  sy :: Storage cy <- getStore
  sl <- lift $ explMembers sx
  U.forM_ sl $ \e -> do
    x <- lift $ explGet sx e
    y <- sys x
    lift $ explSet sy e 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_ sys = do
  s :: Storage c <- getStore
  sl <- lift $ explMembers s
  U.forM_ sl $ \ety -> do
    x <- lift $ explGet s ety
    sys 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 f a0 = do
  s :: Storage c <- getStore
  sl <- lift $ explMembers s
  lift $ U.foldM' (\a e -> f a <$> explGet s e) a0 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 sys a0 = do
  s :: Storage c <- getStore
  sl <- lift $ explMembers s
  U.foldM' (\a e -> lift (explGet s e) >>= sys a) a0 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_ sys a0 = do
  s :: Storage c <- getStore
  sl <- lift $ explMembers s
  U.foldM'_ (\a e -> lift (explGet s e) >>= sys a) a0 sl

{- | Collect matching components into a list by using the specified test/process function.
  You can use this to preprocess data before returning.
  And you can do a test here that depends on data from multiple components.
  Pass "Just" to simply collect all the items.
-}
{-# INLINE collect #-}
collect
  :: forall components w m a
   . (Get w m components, Members w m components)
  => (components -> Maybe a)
  -> SystemT w m [a]
collect f = cfold (\acc -> maybe acc (: acc) . f) []