module Game.Antisplice.Utils.Atoms where
import Control.Arrow
import qualified Control.Category as C
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Data.Dynamic
import Data.Typeable
import Game.Antisplice.Utils.AVL
import Game.Antisplice.Utils.Counter
newtype Atom a = Atom Int deriving (Ord,Eq)
newtype AtomStoreT m a = AtomStore { runAtomStoreT :: AVL (Int,Dynamic) -> m (a,AVL (Int,Dynamic)) }
instance Functor m => Functor (AtomStoreT m) where
fmap f a = AtomStore $ \s -> fmap (first f) $ runAtomStoreT a s
instance Monad m => Monad (AtomStoreT m) where
return a = AtomStore $ \s -> return (a,s)
m >>= f = AtomStore $ \s -> do (a,s') <- runAtomStoreT m s; runAtomStoreT (f a) s'
instance MonadTrans AtomStoreT where
lift m = AtomStore $ \s -> do a <- m; return (a,s)
instance MonadIO m => MonadIO (AtomStoreT m) where
liftIO = lift . liftIO
instance MonadCounter m => MonadCounter (AtomStoreT m) where
countOn = lift countOn
class MonadCounter m => MonadAtoms m where
newAtom :: Typeable v => m (Atom v)
putAtom :: Typeable v => Atom v -> v -> m ()
getAtom :: Typeable v => Atom v -> m v
dispAtom :: Atom v -> m ()
cloneAtom :: Typeable v => Atom v -> m (Atom v)
cloneAtom a = do
b <- newAtom
v <- getAtom a
putAtom b v
return b
instance (Functor m,MonadCounter m) => MonadAtoms (AtomStoreT m) where
newAtom = fmap Atom $ lift countOn
putAtom (Atom a) v = AtomStore $ \s -> return ((),avlInsert (a,toDyn v) s)
getAtom (Atom a) = AtomStore $ \s -> let Just v = avlLookup a s in return (fromDyn v undefined,s)
dispAtom (Atom a) = AtomStore $ \s -> return ((),avlRemove a s)
newtype (Typeable a,Typeable b) => Atomar m a b = Atomar { runAtomar :: Atom a -> m (Atom b) }
mapAtom :: (Typeable a, Typeable b, MonadAtoms m) => (a -> b) -> Atom a -> m (Atom b)
mapAtom f (Atom a) = do
v <- getAtom (Atom a)
putAtom (Atom a) $ f v
return (Atom a)