{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Apecs.Experimental.Reactive
( Reacts (..), Reactive, withReactive
, Printer
, EnumMap, enumLookup
, OrdMap, ordLookup
, IxMap, ixLookup
, ComponentCounter, readComponentCount, ComponentCount(..)
) 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) <- SystemT w m (Storage (Elem r))
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 (m :: * -> *) a. Monad m => 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 a. a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 a. a -> m a
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 a. IO a -> m a
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 a. a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 :: forall (m :: * -> *) c.
(MonadIO m, Enum c) =>
c -> EnumMap c -> m [Entity]
enumLookup c
c = \(EnumMap IORef (IntMap IntSet)
ref) -> do
IntMap IntSet
emap <- IO (IntMap IntSet) -> m (IntMap IntSet)
forall a. IO a -> m a
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 a. a -> m a
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 a b. (a -> b) -> [a] -> [b]
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 a. IO a -> m a
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 a. a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 :: 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 <- IO (Map c IntSet) -> m (Map c IntSet)
forall a. IO a -> m a
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 a. a -> m a
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 a b. (a -> b) -> [a] -> [b]
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 :: forall i a. Ix i => 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 a b. IO a -> (a -> IO b) -> IO b
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 a. IO a -> m a
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 i. Ix i => (i, i) -> IntSet -> IO (IOArray i 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 a. a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 :: forall (m :: * -> *) c.
(MonadIO m, Ix c) =>
c -> IxMap c -> m [Entity]
ixLookup c
c = \(IxMap IOArray c IntSet
ref) -> do
IO [Entity] -> m [Entity]
forall a. IO a -> m a
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 a b. (a -> b) -> [a] -> [b]
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
newtype ComponentCounter c = ComponentCounter (IORef (ComponentCount c))
type instance Elem (ComponentCounter c) = c
data ComponentCount c = ComponentCount
{ forall c. ComponentCount c -> Int
componentCountCurrent :: !Int
, forall c. ComponentCount c -> Int
componentCountMax :: !Int
} deriving (ComponentCount c -> ComponentCount c -> Bool
(ComponentCount c -> ComponentCount c -> Bool)
-> (ComponentCount c -> ComponentCount c -> Bool)
-> Eq (ComponentCount c)
forall c. ComponentCount c -> ComponentCount c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. ComponentCount c -> ComponentCount c -> Bool
== :: ComponentCount c -> ComponentCount c -> Bool
$c/= :: forall c. ComponentCount c -> ComponentCount c -> Bool
/= :: ComponentCount c -> ComponentCount c -> Bool
Eq, Int -> ComponentCount c -> String -> String
[ComponentCount c] -> String -> String
ComponentCount c -> String
(Int -> ComponentCount c -> String -> String)
-> (ComponentCount c -> String)
-> ([ComponentCount c] -> String -> String)
-> Show (ComponentCount c)
forall c. Int -> ComponentCount c -> String -> String
forall c. [ComponentCount c] -> String -> String
forall c. ComponentCount c -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall c. Int -> ComponentCount c -> String -> String
showsPrec :: Int -> ComponentCount c -> String -> String
$cshow :: forall c. ComponentCount c -> String
show :: ComponentCount c -> String
$cshowList :: forall c. [ComponentCount c] -> String -> String
showList :: [ComponentCount c] -> String -> String
Show)
instance MonadIO m => Reacts m (ComponentCounter c) where
{-# INLINE rempty #-}
rempty :: m (ComponentCounter c)
rempty = IO (ComponentCounter c) -> m (ComponentCounter c)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ComponentCounter c) -> m (ComponentCounter c))
-> IO (ComponentCounter c) -> m (ComponentCounter c)
forall a b. (a -> b) -> a -> b
$ IORef (ComponentCount c) -> ComponentCounter c
forall c. IORef (ComponentCount c) -> ComponentCounter c
ComponentCounter (IORef (ComponentCount c) -> ComponentCounter c)
-> IO (IORef (ComponentCount c)) -> IO (ComponentCounter c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComponentCount c -> IO (IORef (ComponentCount c))
forall a. a -> IO (IORef a)
newIORef ComponentCount
{ componentCountCurrent :: Int
componentCountCurrent = Int
0
, componentCountMax :: Int
componentCountMax = Int
0
}
{-# INLINE react #-}
react :: Entity
-> Maybe (Elem (ComponentCounter c))
-> Maybe (Elem (ComponentCounter c))
-> ComponentCounter c
-> m ()
react Entity
_ent Maybe (Elem (ComponentCounter c))
mOld Maybe (Elem (ComponentCounter c))
mNew (ComponentCounter IORef (ComponentCount c)
ref) =
case (Maybe c
Maybe (Elem (ComponentCounter c))
mOld, Maybe c
Maybe (Elem (ComponentCounter c))
mNew) of
(Maybe c
Nothing, Just {}) -> Int -> m ()
go Int
1
(Just {}, Maybe c
Nothing) -> Int -> m ()
go (-Int
1)
(Maybe c, Maybe c)
_ignored -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
go :: Int -> m ()
go :: Int -> m ()
go Int
i =
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (ComponentCount c)
-> (ComponentCount c -> (ComponentCount c, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (ComponentCount c)
ref ((ComponentCount c -> (ComponentCount c, ())) -> IO ())
-> (ComponentCount c -> (ComponentCount c, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ComponentCount c
cc ->
let cur :: Int
cur = ComponentCount c -> Int
forall c. ComponentCount c -> Int
componentCountCurrent ComponentCount c
cc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
in ( ComponentCount c
cc
{ componentCountCurrent = cur
, componentCountMax = max cur $ componentCountMax cc
}
, ()
)
{-# INLINE readComponentCount #-}
readComponentCount
:: forall c m
. MonadIO m
=> ComponentCounter c
-> m (ComponentCount c)
readComponentCount :: forall c (m :: * -> *).
MonadIO m =>
ComponentCounter c -> m (ComponentCount c)
readComponentCount (ComponentCounter IORef (ComponentCount c)
ref) = IO (ComponentCount c) -> m (ComponentCount c)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ComponentCount c) -> m (ComponentCount c))
-> IO (ComponentCount c) -> m (ComponentCount c)
forall a b. (a -> b) -> a -> b
$ IORef (ComponentCount c) -> IO (ComponentCount c)
forall a. IORef a -> IO a
readIORef IORef (ComponentCount c)
ref