{-# 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 Monad m => Reacts m r where
rempty :: m r
react :: Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()
data Reactive r s = Reactive r s
type instance Elem (Reactive r s) = Elem s
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
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 ()
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)
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)
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