{-|
Stability : experimental

This module is experimental, and its API might change between point releases. Use at your own risk.

Adds the @Reactive r s@ store, which when wrapped around store @s@, will call the @react@ on its @r@.

@Show c => Reactive (Printer c) (Map c)@ will print a message every time a @c@ value is set.

@Enum c => Reactive (EnumMap c) (Map c)@ allows you to look up entities by component value.
Use e.g. @rget >>= mapLookup True@ to retrieve a list of entities that have a @True@ component.

-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}

module Apecs.Experimental.Reactive
  ( Reacts (..), Reactive, withReactive
  , EnumMap, enumLookup
  , OrdMap, ordLookup
  , IxMap, ixLookup
  ) where

import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import qualified Data.Array.IO        as A
import qualified Data.IntMap.Strict   as IM
import qualified Data.IntSet          as S
import           Data.IORef
import           Data.Ix
import qualified Data.Map.Strict      as M

import           Apecs.Components
import           Apecs.Core

-- | Class required by @Reactive@.
--   Given some @r@ and update information about some component, will run a side-effect in monad @m@.
--   Note that there are also instances for @(,)@.
class Monad m => Reacts m r where
  rempty :: m r
  react  :: Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()

-- | Wrapper for reactivity around some store s.
data Reactive r s = Reactive r s

type instance Elem (Reactive r s) = Elem s

-- | Performs an action with a reactive state token.
withReactive :: forall w m r s a.
             ( Component (Elem r)
             , Has w m (Elem r)
             , Storage (Elem r) ~ Reactive r s
             ) => (r -> m a) -> SystemT w m a
withReactive :: forall w (m :: * -> *) r s a.
(Component (Elem r), Has w m (Elem r),
 Storage (Elem r) ~ Reactive r s) =>
(r -> m a) -> SystemT w m a
withReactive r -> m a
f = do
  Reactive r
r (s
_ :: s) <- forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
liftforall a b. (a -> b) -> a -> b
$ r -> m a
f r
r

instance (Reacts m r, ExplInit m s) => ExplInit m (Reactive r s) where
  explInit :: m (Reactive r s)
explInit = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall r s. r -> s -> Reactive r s
Reactive forall (m :: * -> *) r. Reacts m r => m r
rempty forall (m :: * -> *) s. ExplInit m s => m s
explInit

instance (Reacts m r, ExplSet m s, ExplGet m s, Elem s ~ Elem r)
  => ExplSet m (Reactive r s) where
  {-# INLINE explSet #-}
  explSet :: Reactive r s -> Int -> Elem (Reactive r s) -> m ()
explSet (Reactive r
r s
s) Int
ety Elem (Reactive r s)
c = do
    Maybe (Elem r)
old <- forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (forall s. s -> MaybeStore s
MaybeStore s
s) Int
ety
    forall (m :: * -> *) r.
Reacts m r =>
Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()
react (Int -> Entity
Entity Int
ety) Maybe (Elem r)
old (forall a. a -> Maybe a
Just Elem (Reactive r s)
c) r
r
    forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
s Int
ety Elem (Reactive r s)
c

instance (Reacts m r, ExplDestroy m s, ExplGet m s, Elem s ~ Elem r)
  => ExplDestroy m (Reactive r s) where
  {-# INLINE explDestroy #-}
  explDestroy :: Reactive r s -> Int -> m ()
explDestroy (Reactive r
r s
s) Int
ety = do
    Maybe (Elem r)
old <- forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (forall s. s -> MaybeStore s
MaybeStore s
s) Int
ety
    forall (m :: * -> *) r.
Reacts m r =>
Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()
react (Int -> Entity
Entity Int
ety) Maybe (Elem r)
old forall a. Maybe a
Nothing r
r
    forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
s Int
ety

instance ExplGet m s => ExplGet m (Reactive r s) where
  {-# INLINE explExists #-}
  explExists :: Reactive r s -> Int -> m Bool
explExists (Reactive r
_ s
s) = forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s
  {-# INLINE explGet    #-}
  explGet :: Reactive r s -> Int -> m (Elem (Reactive r s))
explGet    (Reactive r
_ s
s) = forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet    s
s

instance ExplMembers m s => ExplMembers m (Reactive r s) where
  {-# INLINE explMembers #-}
  explMembers :: Reactive r s -> m (Vector Int)
explMembers (Reactive r
_ s
s) = forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
s

-- | Prints a message to stdout every time a component is updated.
data Printer c = Printer
type instance Elem (Printer c) = c

instance (MonadIO m, Show c) => Reacts m (Printer c) where
  {-# INLINE rempty #-}
  rempty :: m (Printer c)
rempty = forall (m :: * -> *) a. Monad m => a -> m a
return forall c. Printer c
Printer
  {-# INLINE react #-}
  react :: Entity
-> Maybe (Elem (Printer c))
-> Maybe (Elem (Printer c))
-> Printer c
-> m ()
react (Entity Int
ety) (Just Elem (Printer c)
c) Maybe (Elem (Printer c))
Nothing Printer c
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Entity " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
ety forall a. [a] -> [a] -> [a]
++ String
": destroyed component " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Elem (Printer c)
c
  react (Entity Int
ety) Maybe (Elem (Printer c))
Nothing (Just Elem (Printer c)
c) Printer c
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Entity " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
ety forall a. [a] -> [a] -> [a]
++ String
": created component " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Elem (Printer c)
c
  react (Entity Int
ety) (Just Elem (Printer c)
old) (Just Elem (Printer c)
new) Printer c
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Entity " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
ety forall a. [a] -> [a] -> [a]
++ String
": update component " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Elem (Printer c)
old forall a. [a] -> [a] -> [a]
++ String
" to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Elem (Printer c)
new
  react Entity
_ Maybe (Elem (Printer c))
_ Maybe (Elem (Printer c))
_ Printer c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Allows you to look up entities by component value.
--   Use e.g. @withReactive $ mapLookup True@ to retrieve a list of entities that have a @True@ component.
--   Based on an @IntMap IntSet@ internally.
newtype EnumMap c = EnumMap (IORef (IM.IntMap S.IntSet))

type instance Elem (EnumMap c) = c
instance (MonadIO m, Enum c) => Reacts m (EnumMap c) where
  {-# INLINE rempty #-}
  rempty :: m (EnumMap c)
rempty = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$ forall c. IORef (IntMap IntSet) -> EnumMap c
EnumMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
  {-# INLINE react #-}
  react :: Entity
-> Maybe (Elem (EnumMap c))
-> Maybe (Elem (EnumMap c))
-> EnumMap c
-> m ()
react Entity
_ Maybe (Elem (EnumMap c))
Nothing Maybe (Elem (EnumMap c))
Nothing EnumMap c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  react (Entity Int
ety) (Just Elem (EnumMap c)
c) Maybe (Elem (EnumMap c))
Nothing (EnumMap IORef (IntMap IntSet)
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap IntSet)
ref (forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (Int -> IntSet -> IntSet
S.delete Int
ety) (forall a. Enum a => a -> Int
fromEnum Elem (EnumMap c)
c))
  react (Entity Int
ety) Maybe (Elem (EnumMap c))
Nothing (Just Elem (EnumMap c)
c) (EnumMap IORef (IntMap IntSet)
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap IntSet)
ref (forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith forall a. Monoid a => a -> a -> a
mappend (forall a. Enum a => a -> Int
fromEnum Elem (EnumMap c)
c) (Int -> IntSet
S.singleton Int
ety))
  react (Entity Int
ety) (Just Elem (EnumMap c)
old) (Just Elem (EnumMap c)
new) (EnumMap IORef (IntMap IntSet)
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$ do
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap IntSet)
ref (forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (Int -> IntSet -> IntSet
S.delete Int
ety) (forall a. Enum a => a -> Int
fromEnum Elem (EnumMap c)
old))
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap IntSet)
ref (forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith forall a. Monoid a => a -> a -> a
mappend (forall a. Enum a => a -> Int
fromEnum Elem (EnumMap c)
new) (Int -> IntSet
S.singleton Int
ety))

{-# INLINE enumLookup #-}
enumLookup :: (MonadIO m, Enum c) => c -> EnumMap c -> m [Entity]
enumLookup :: forall (m :: * -> *) c.
(MonadIO m, Enum c) =>
c -> EnumMap c -> m [Entity]
enumLookup c
c = \(EnumMap IORef (IntMap IntSet)
ref) -> do
  IntMap IntSet
emap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (IntMap IntSet)
ref
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Entity
Entity forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
S.toList) (forall a. Int -> IntMap a -> Maybe a
IM.lookup (forall a. Enum a => a -> Int
fromEnum c
c) IntMap IntSet
emap)

-- | Allows you to look up entities by component value.
--   Based on a @Map c IntSet@ internally
newtype OrdMap c = OrdMap (IORef (M.Map c S.IntSet))

type instance Elem (OrdMap c) = c
instance (MonadIO m, Ord c) => Reacts m (OrdMap c) where
  {-# INLINE rempty #-}
  rempty :: m (OrdMap c)
rempty = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$ forall c. IORef (Map c IntSet) -> OrdMap c
OrdMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
  {-# INLINE react #-}
  react :: Entity
-> Maybe (Elem (OrdMap c))
-> Maybe (Elem (OrdMap c))
-> OrdMap c
-> m ()
react Entity
_ Maybe (Elem (OrdMap c))
Nothing Maybe (Elem (OrdMap c))
Nothing OrdMap c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  react (Entity Int
ety) (Just Elem (OrdMap c)
c) Maybe (Elem (OrdMap c))
Nothing (OrdMap IORef (Map c IntSet)
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map c IntSet)
ref (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (Int -> IntSet -> IntSet
S.delete Int
ety) Elem (OrdMap c)
c)
  react (Entity Int
ety) Maybe (Elem (OrdMap c))
Nothing (Just Elem (OrdMap c)
c) (OrdMap IORef (Map c IntSet)
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map c IntSet)
ref (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Monoid a => a -> a -> a
mappend Elem (OrdMap c)
c (Int -> IntSet
S.singleton Int
ety))
  react (Entity Int
ety) (Just Elem (OrdMap c)
old) (Just Elem (OrdMap c)
new) (OrdMap IORef (Map c IntSet)
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$ do
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map c IntSet)
ref (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (Int -> IntSet -> IntSet
S.delete Int
ety) Elem (OrdMap c)
old)
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map c IntSet)
ref (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Monoid a => a -> a -> a
mappend Elem (OrdMap c)
new (Int -> IntSet
S.singleton Int
ety))

{-# INLINE ordLookup #-}
ordLookup :: (MonadIO m, Ord c) => c -> OrdMap c -> m [Entity]
ordLookup :: forall (m :: * -> *) c.
(MonadIO m, Ord c) =>
c -> OrdMap c -> m [Entity]
ordLookup c
c = \(OrdMap IORef (Map c IntSet)
ref) -> do
  Map c IntSet
emap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Map c IntSet)
ref
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Entity
Entity forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
S.toList) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup c
c Map c IntSet
emap)

-- | Allows you to look up entities by component value.
--   Based on an @IOArray c IntSet@ internally
newtype IxMap c = IxMap (A.IOArray c S.IntSet)

{-# INLINE modifyArray #-}
modifyArray :: Ix i => A.IOArray i a -> i -> (a -> a) -> IO ()
modifyArray :: forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray i a
ref i
ix a -> a
f = forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
A.readArray IOArray i a
ref i
ix forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
A.writeArray IOArray i a
ref i
ix forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f

type instance Elem (IxMap c) = c
instance (MonadIO m, Ix c, Bounded c) => Reacts m (IxMap c) where
  {-# INLINE rempty #-}
  rempty :: m (IxMap c)
rempty = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$ forall c. IOArray c IntSet -> IxMap c
IxMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
A.newArray (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound) forall a. Monoid a => a
mempty
  {-# INLINE react #-}
  react :: Entity
-> Maybe (Elem (IxMap c))
-> Maybe (Elem (IxMap c))
-> IxMap c
-> m ()
react Entity
_ Maybe (Elem (IxMap c))
Nothing Maybe (Elem (IxMap c))
Nothing IxMap c
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  react (Entity Int
ety) (Just Elem (IxMap c)
c) Maybe (Elem (IxMap c))
Nothing (IxMap IOArray c IntSet
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray c IntSet
ref Elem (IxMap c)
c (Int -> IntSet -> IntSet
S.delete Int
ety)
  react (Entity Int
ety) Maybe (Elem (IxMap c))
Nothing (Just Elem (IxMap c)
c) (IxMap IOArray c IntSet
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$
    forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray c IntSet
ref Elem (IxMap c)
c (Int -> IntSet -> IntSet
S.insert Int
ety)
  react (Entity Int
ety) (Just Elem (IxMap c)
old) (Just Elem (IxMap c)
new) (IxMap IOArray c IntSet
ref) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$ do
    forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray c IntSet
ref Elem (IxMap c)
old (Int -> IntSet -> IntSet
S.delete Int
ety)
    forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray c IntSet
ref Elem (IxMap c)
new (Int -> IntSet -> IntSet
S.insert Int
ety)

{-# INLINE ixLookup #-}
ixLookup :: (MonadIO m, Ix c) => c -> IxMap c -> m [Entity]
ixLookup :: forall (m :: * -> *) c.
(MonadIO m, Ix c) =>
c -> IxMap c -> m [Entity]
ixLookup c
c = \(IxMap IOArray c IntSet
ref) -> do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Entity
Entity forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
S.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
A.readArray IOArray c IntSet
ref c
c