{-|
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 :: (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

-- | 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 = 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 ()

-- | 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 = 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)

-- | 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 = 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)

-- | 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 :: 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