{-# 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 :: (r -> m a) -> SystemT w m a
withReactive r -> m a
f = do
Reactive r
r (s
_ :: s) <- SystemT w m (Reactive r s)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
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
$ 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 = (r -> s -> Reactive r s) -> m r -> m s -> m (Reactive r s)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> s -> Reactive r s
forall r s. r -> s -> Reactive r s
Reactive m r
forall (m :: * -> *) r. Reacts m r => m r
rempty m s
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 <- MaybeStore s -> Int -> m (Elem (MaybeStore s))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (s -> MaybeStore s
forall s. s -> MaybeStore s
MaybeStore s
s) Int
ety
Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()
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 (Elem r -> Maybe (Elem r)
forall a. a -> Maybe a
Just Elem r
Elem (Reactive r s)
c) r
r
s -> Int -> Elem s -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
s Int
ety Elem s
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 <- MaybeStore s -> Int -> m (Elem (MaybeStore s))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (s -> MaybeStore s
forall s. s -> MaybeStore s
MaybeStore s
s) Int
ety
Entity -> Maybe (Elem r) -> Maybe (Elem r) -> r -> m ()
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 Maybe (Elem r)
forall a. Maybe a
Nothing r
r
s -> Int -> m ()
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) = s -> Int -> m Bool
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) = s -> Int -> m (Elem 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) = s -> m (Vector Int)
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 = Printer c -> m (Printer c)
forall (m :: * -> *) a. Monad m => a -> m a
return Printer c
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
_ = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Entity " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ety String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": destroyed component " String -> String -> String
forall a. [a] -> [a] -> [a]
++ c -> String
forall a. Show a => a -> String
show c
Elem (Printer c)
c
react (Entity Int
ety) Maybe (Elem (Printer c))
Nothing (Just Elem (Printer c)
c) Printer c
_ = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Entity " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ety String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": created component " String -> String -> String
forall a. [a] -> [a] -> [a]
++ c -> String
forall a. Show a => a -> String
show c
Elem (Printer c)
c
react (Entity Int
ety) (Just Elem (Printer c)
old) (Just Elem (Printer c)
new) Printer c
_ = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Entity " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ety String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": update component " String -> String -> String
forall a. [a] -> [a] -> [a]
++ c -> String
forall a. Show a => a -> String
show c
Elem (Printer c)
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ c -> String
forall a. Show a => a -> String
show c
Elem (Printer c)
new
react Entity
_ Maybe (Elem (Printer c))
_ Maybe (Elem (Printer c))
_ Printer c
_ = () -> m ()
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 = IO (EnumMap c) -> m (EnumMap c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (EnumMap c) -> m (EnumMap c))
-> IO (EnumMap c) -> m (EnumMap c)
forall a b. (a -> b) -> a -> b
$ IORef (IntMap IntSet) -> EnumMap c
forall c. IORef (IntMap IntSet) -> EnumMap c
EnumMap (IORef (IntMap IntSet) -> EnumMap c)
-> IO (IORef (IntMap IntSet)) -> IO (EnumMap c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap IntSet -> IO (IORef (IntMap IntSet))
forall a. a -> IO (IORef a)
newIORef IntMap IntSet
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
_ = () -> m ()
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) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IORef (IntMap IntSet) -> (IntMap IntSet -> IntMap IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap IntSet)
ref ((IntSet -> IntSet) -> Int -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (Int -> IntSet -> IntSet
S.delete Int
ety) (c -> Int
forall a. Enum a => a -> Int
fromEnum c
Elem (EnumMap c)
c))
react (Entity Int
ety) Maybe (Elem (EnumMap c))
Nothing (Just Elem (EnumMap c)
c) (EnumMap IORef (IntMap IntSet)
ref) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IORef (IntMap IntSet) -> (IntMap IntSet -> IntMap IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap IntSet)
ref ((IntSet -> IntSet -> IntSet)
-> Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
forall a. Monoid a => a -> a -> a
mappend (c -> Int
forall a. Enum a => a -> Int
fromEnum c
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) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
IORef (IntMap IntSet) -> (IntMap IntSet -> IntMap IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap IntSet)
ref ((IntSet -> IntSet) -> Int -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (Int -> IntSet -> IntSet
S.delete Int
ety) (c -> Int
forall a. Enum a => a -> Int
fromEnum c
Elem (EnumMap c)
old))
IORef (IntMap IntSet) -> (IntMap IntSet -> IntMap IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap IntSet)
ref ((IntSet -> IntSet -> IntSet)
-> Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
forall a. Monoid a => a -> a -> a
mappend (c -> Int
forall a. Enum a => a -> Int
fromEnum c
Elem (EnumMap c)
new) (Int -> IntSet
S.singleton Int
ety))
{-# INLINE enumLookup #-}
enumLookup :: (MonadIO m, Enum c) => c -> EnumMap c -> m [Entity]
enumLookup :: c -> EnumMap c -> m [Entity]
enumLookup c
c = \(EnumMap IORef (IntMap IntSet)
ref) -> do
IntMap IntSet
emap <- IO (IntMap IntSet) -> m (IntMap IntSet)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IntMap IntSet) -> m (IntMap IntSet))
-> IO (IntMap IntSet) -> m (IntMap IntSet)
forall a b. (a -> b) -> a -> b
$ IORef (IntMap IntSet) -> IO (IntMap IntSet)
forall a. IORef a -> IO a
readIORef IORef (IntMap IntSet)
ref
[Entity] -> m [Entity]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Entity] -> m [Entity]) -> [Entity] -> m [Entity]
forall a b. (a -> b) -> a -> b
$ [Entity] -> (IntSet -> [Entity]) -> Maybe IntSet -> [Entity]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Int -> Entity) -> [Int] -> [Entity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Entity
Entity ([Int] -> [Entity]) -> (IntSet -> [Int]) -> IntSet -> [Entity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
S.toList) (Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup (c -> Int
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 = IO (OrdMap c) -> m (OrdMap c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (OrdMap c) -> m (OrdMap c)) -> IO (OrdMap c) -> m (OrdMap c)
forall a b. (a -> b) -> a -> b
$ IORef (Map c IntSet) -> OrdMap c
forall c. IORef (Map c IntSet) -> OrdMap c
OrdMap (IORef (Map c IntSet) -> OrdMap c)
-> IO (IORef (Map c IntSet)) -> IO (OrdMap c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map c IntSet -> IO (IORef (Map c IntSet))
forall a. a -> IO (IORef a)
newIORef Map c IntSet
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
_ = () -> m ()
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) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IORef (Map c IntSet) -> (Map c IntSet -> Map c IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map c IntSet)
ref ((IntSet -> IntSet) -> c -> Map c IntSet -> Map c IntSet
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (Int -> IntSet -> IntSet
S.delete Int
ety) c
Elem (OrdMap c)
c)
react (Entity Int
ety) Maybe (Elem (OrdMap c))
Nothing (Just Elem (OrdMap c)
c) (OrdMap IORef (Map c IntSet)
ref) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IORef (Map c IntSet) -> (Map c IntSet -> Map c IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map c IntSet)
ref ((IntSet -> IntSet -> IntSet)
-> c -> IntSet -> Map c IntSet -> Map c IntSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith IntSet -> IntSet -> IntSet
forall a. Monoid a => a -> a -> a
mappend c
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) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
IORef (Map c IntSet) -> (Map c IntSet -> Map c IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map c IntSet)
ref ((IntSet -> IntSet) -> c -> Map c IntSet -> Map c IntSet
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (Int -> IntSet -> IntSet
S.delete Int
ety) c
Elem (OrdMap c)
old)
IORef (Map c IntSet) -> (Map c IntSet -> Map c IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map c IntSet)
ref ((IntSet -> IntSet -> IntSet)
-> c -> IntSet -> Map c IntSet -> Map c IntSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith IntSet -> IntSet -> IntSet
forall a. Monoid a => a -> a -> a
mappend c
Elem (OrdMap c)
new (Int -> IntSet
S.singleton Int
ety))
{-# INLINE ordLookup #-}
ordLookup :: (MonadIO m, Ord c) => c -> OrdMap c -> m [Entity]
ordLookup :: c -> OrdMap c -> m [Entity]
ordLookup c
c = \(OrdMap IORef (Map c IntSet)
ref) -> do
Map c IntSet
emap <- IO (Map c IntSet) -> m (Map c IntSet)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map c IntSet) -> m (Map c IntSet))
-> IO (Map c IntSet) -> m (Map c IntSet)
forall a b. (a -> b) -> a -> b
$ IORef (Map c IntSet) -> IO (Map c IntSet)
forall a. IORef a -> IO a
readIORef IORef (Map c IntSet)
ref
[Entity] -> m [Entity]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Entity] -> m [Entity]) -> [Entity] -> m [Entity]
forall a b. (a -> b) -> a -> b
$ [Entity] -> (IntSet -> [Entity]) -> Maybe IntSet -> [Entity]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Int -> Entity) -> [Int] -> [Entity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Entity
Entity ([Int] -> [Entity]) -> (IntSet -> [Int]) -> IntSet -> [Entity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
S.toList) (c -> Map c IntSet -> Maybe IntSet
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 :: IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray i a
ref i
ix a -> a
f = IOArray i a -> i -> IO a
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 IO a -> (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IOArray i a -> i -> a -> IO ()
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 (a -> IO ()) -> (a -> a) -> a -> IO ()
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 = IO (IxMap c) -> m (IxMap c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (IxMap c) -> m (IxMap c)) -> IO (IxMap c) -> m (IxMap c)
forall a b. (a -> b) -> a -> b
$ IOArray c IntSet -> IxMap c
forall c. IOArray c IntSet -> IxMap c
IxMap (IOArray c IntSet -> IxMap c)
-> IO (IOArray c IntSet) -> IO (IxMap c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (c, c) -> IntSet -> IO (IOArray c IntSet)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
A.newArray (c
forall a. Bounded a => a
minBound, c
forall a. Bounded a => a
maxBound) IntSet
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
_ = () -> m ()
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) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IOArray c IntSet -> c -> (IntSet -> IntSet) -> IO ()
forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray c IntSet
ref c
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) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IOArray c IntSet -> c -> (IntSet -> IntSet) -> IO ()
forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray c IntSet
ref c
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) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
IOArray c IntSet -> c -> (IntSet -> IntSet) -> IO ()
forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray c IntSet
ref c
Elem (IxMap c)
old (Int -> IntSet -> IntSet
S.delete Int
ety)
IOArray c IntSet -> c -> (IntSet -> IntSet) -> IO ()
forall i a. Ix i => IOArray i a -> i -> (a -> a) -> IO ()
modifyArray IOArray c IntSet
ref c
Elem (IxMap c)
new (Int -> IntSet -> IntSet
S.insert Int
ety)
{-# INLINE ixLookup #-}
ixLookup :: (MonadIO m, Ix c) => c -> IxMap c -> m [Entity]
ixLookup :: c -> IxMap c -> m [Entity]
ixLookup c
c = \(IxMap IOArray c IntSet
ref) -> do
IO [Entity] -> m [Entity]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Entity] -> m [Entity]) -> IO [Entity] -> m [Entity]
forall a b. (a -> b) -> a -> b
$ (Int -> Entity) -> [Int] -> [Entity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Entity
Entity ([Int] -> [Entity]) -> (IntSet -> [Int]) -> IntSet -> [Entity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
S.toList (IntSet -> [Entity]) -> IO IntSet -> IO [Entity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOArray c IntSet -> c -> IO IntSet
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