gore-and-ash-actor (empty) → 1.1.0.0

raw patch · 12 files changed

+998/−0 lines, 12 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, exceptions, gore-and-ash, hashable, mtl, unordered-containers

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• gore-and-ash-actor.cabal +51/−0
• src/Game/GoreAndAsh/Actor.hs +135/−0
• src/Game/GoreAndAsh/Actor/API.hs +305/−0
• src/Game/GoreAndAsh/Actor/Collection.hs +115/−0
• src/Game/GoreAndAsh/Actor/Collection/Data.hs +87/−0
• src/Game/GoreAndAsh/Actor/Indexed.hs +59/−0
• src/Game/GoreAndAsh/Actor/Message.hs +37/−0
• src/Game/GoreAndAsh/Actor/Module.hs +59/−0
• src/Game/GoreAndAsh/Actor/State.hs +68/−0
• src/Game/GoreAndAsh/Actor/TypeRep.hs +50/−0

@@ -0,0 +1,30 @@+Copyright Gushcha Anton (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of  nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,51 @@+name:                gore-and-ash-actor+version:             1.1.0.0+synopsis:            Gore&Ash engine extension that implements actor style of programming+description:         Please see README.md+homepage:            https://github.com/Teaspot-Studio/gore-and-ash-actor+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha+maintainer:          ncrashed@gmail.com+copyright:           2016 Anton Gushcha+category:            Game+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Game.GoreAndAsh.Actor+                       Game.GoreAndAsh.Actor.API+                       Game.GoreAndAsh.Actor.Collection+                       Game.GoreAndAsh.Actor.Collection.Data+                       Game.GoreAndAsh.Actor.Indexed+                       Game.GoreAndAsh.Actor.Message+                       Game.GoreAndAsh.Actor.Module+                       Game.GoreAndAsh.Actor.State+                       Game.GoreAndAsh.Actor.TypeRep++  default-language:    Haskell2010++  build-depends:       base >= 4.7 && < 5+                     , containers >= 0.5.6.2+                     , deepseq >= 1.4+                     , exceptions >= 0.8.0.2 +                     , gore-and-ash >= 1.1.0.0+                     , hashable >= 1.2.3.3+                     , mtl >= 2.2+                     , unordered-containers >= 0.2.5.1+                     +  default-extensions:  +                       Arrows+                       BangPatterns+                       DeriveGeneric+                       FlexibleContexts+                       FlexibleInstances+                       GeneralizedNewtypeDeriving+                       MultiParamTypeClasses+                       RecordWildCards+                       ScopedTypeVariables+                       StandaloneDeriving+                       TupleSections+                       TypeFamilies+                       UndecidableInstances

@@ -0,0 +1,135 @@+{-|+Module      : Game.GoreAndAsh.Actor+Description : Module that contains actor API for Gore&Ash+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The core module contains API for actor based aproach of game development. +The module doesn't depends on others core modules and could be place in any place in +game monad stack.++The module is pure within first phase (see 'ModuleStack' docs) but requires 'MonadThrow'+instance of end monad, therefore currently only 'IO' end monad can handler the module.++Example of embedding:++@+-- | Application monad is monad stack build from given list of modules over base monad (IO)+type AppStack = ModuleStack [ActorT, ... other modules ... ] IO+newtype AppState = AppState (ModuleState AppStack)+  deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, ActorMonad, ... other modules monads ... )+  +instance GameModule AppMonad AppState where +  type ModuleState AppMonad = AppState+  runModule (AppMonad m) (AppState s) = do +    (a, s') <- runModule m s +    return (a, AppState s')+  newModuleState = AppState <$> newModuleState+  withModule _ = withModule (Proxy :: Proxy AppStack)+  cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b+-- | Action that makes indexed app wire+type AppActor i a b = GameActor AppMonad i a b+@++Actor ('GameActor') is wire with its unique id. For instance you want actor for your player:++@+data Player = Player {+  playerId :: !PlayerId+, playerPos :: !(Double, Double)+} deriving (Generic)++instance NFData Player ++newtype PlayerId = PlayerId { unPlayerId :: Int } deriving (Eq, Show, Generic) +instance NFData PlayerId +instance Hashable PlayerId +instance Serialize PlayerId++data PlayerMessage =+    -- | The player was shot by specified player+    PlayerShotMessage !PlayerId +  deriving (Typeable, Generic)++instance NFData PlayerMessage ++instance ActorMessage PlayerId where+  type ActorMessageType PlayerId = PlayerMessage+  toCounter = unPlayerId+  fromCounter = PlayerId+@++Now you can create statefull actor:++@+playerActor :: ActorMonad m => (PlayerId -> Player) -> AppActor m PlayerId Game Player +playerActor initialPlayer = makeActor $ \i -> stateWire (initialPlayer i) $ mainController i+  where+  mainController i = proc (g, p) -> do+    emsg <- actorMessages i isPlayerShotMessage -< ()+    -- do with emsg something+    returnA -< p+@++And you can have dynamic collection of actors:++@+processPlayers :: ActorMonad m => AppWire m Game [Player]+processPlayer = proc g -> do +  addEvent <- periodic 4 -< newPlayer+  remEvent <- never -< ()+  dynCollection [] -< (g, addEvent, remEvent)+@+-}+module Game.GoreAndAsh.Actor(+  -- * Low level+    ActorState+  , ActorT +  , ActorMonad(..)+  , ActorException(..)+  -- * Actor API+  , GameWireIndexed(..)+  , GameActor+  , ActorMessage(..)+  , postActorAction+  , preActorAction+  , makeActor+  , makeFixedActor+  , runActor+  , runActor'+  -- ** Helpers for libraries+  , getActorFingerprint+  , actorFingerprint+  -- * Message API+  , actorSend+  , actorSendMany+  , actorSendDyn+  , actorSendManyDyn+  , actorProcessMessages+  , actorProcessMessagesM+  , actorMessages+  -- * Dynamic collections+  , DynCollection(..)+  , ElementWithId(..)+  , dynCollection+  , dDynCollection+  ) where++import Game.GoreAndAsh.Actor.API as X+import Game.GoreAndAsh.Actor.Collection as X+import Game.GoreAndAsh.Actor.Indexed as X+import Game.GoreAndAsh.Actor.Message as X+import Game.GoreAndAsh.Actor.Module as X+import Game.GoreAndAsh.Actor.State as X

@@ -0,0 +1,305 @@+{-|+Module      : Game.GoreAndAsh.Actor.API+Description : Monadic and arrow API for actor core module+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++Module that contains monadic and arrow API of actor module.+-}+module Game.GoreAndAsh.Actor.API(+    ActorMonad(..)+  , ActorException(..)+  -- * Message API+  , actorSend+  , actorSendMany+  , actorSendDyn+  , actorSendManyDyn+  , actorProcessMessages+  , actorProcessMessagesM+  , actorMessages+  -- * Actor API+  , makeActor+  , makeFixedActor+  , runActor+  , runActor'+  -- * Helpers for libraries+  , getActorFingerprint+  ) where++import Control.Monad.Catch+import Control.Monad.State.Strict+import Control.Wire+import Control.Wire.Unsafe.Event+import Data.Dynamic+import Data.Maybe (isJust, fromJust)+import GHC.Generics +import Prelude hiding (id, (.))+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor.Indexed+import Game.GoreAndAsh.Actor.Message+import Game.GoreAndAsh.Actor.Module+import Game.GoreAndAsh.Actor.State+import Game.GoreAndAsh.Actor.TypeRep++-- | Exceptions thrown by ActorMonad+data ActorException = +  ActorIdConflict TypeRep Int -- ^ Tried to register already presented actor+  deriving (Show, Generic)++instance Exception ActorException++-- | Low level monadic API for module.+class MonadThrow m => ActorMonad m where +  -- | Registers new actor in message system+  actorRegisterM :: ActorMessage i => m i +  +  -- | Registers specific id, throws ActorException if there is id clash+  actorRegisterFixedM :: ActorMessage i => i -> m ()++  -- | Deletes actor with given id+  actorDeleteM :: ActorMessage i => i -> m ()++  -- | Checks if given id is already taken+  actorRegisteredM :: ActorMessage i => i -> m Bool++  -- | Sends typed message to actor with given id+  actorSendM :: (ActorMessage i, Typeable (ActorMessageType i)) +    => i -> ActorMessageType i -> m ()++  -- | Get all messages that were collected for given actor's id+  --+  -- Note: Doesn't clears the queue+  actorGetMessagesM :: (ActorMessage i, Typeable (ActorMessageType i))+    => i -> m (S.Seq (ActorMessageType i))++  -- | Find type representation of actor by it type name+  findActorTypeRepM :: String -> m (Maybe HashableTypeRep)++  -- | Register type representation for actor (sometimes this should be done before+  -- any actor is registered)+  registerActorTypeRepM :: forall proxy i . ActorMessage i => proxy i -> m ()++instance {-# OVERLAPPING #-} MonadThrow m => ActorMonad (ActorT s m) where+  actorRegisterM = do +    astate <- ActorT get +    let (fpt, i, astate') = pushActorNextId astate +    ActorT . put $! astate' {+        actorBoxes = H.insert (fpt, toCounter i) (S.empty, S.empty) $! actorBoxes astate'+      , actorNameMap = H.insert (show fpt) fpt $! actorNameMap astate'+      }+    return i ++  actorRegisterFixedM i = do +    astate <- ActorT get+    case regActorFixedId i astate of +      Nothing -> throwM $! ActorIdConflict tp (toCounter i)+        where tp = fromHashableTypeRep $ getActorFingerprint i+      Just astate' -> ActorT . put $! astate'++  actorDeleteM i = do +    astate <- ActorT get +    ActorT . put $! deleteActorId i astate+  +  actorRegisteredM i = do +    astate <- ActorT get +    return . isActorIdRegistered i $! astate++  actorSendM i msg = do +    astate <- ActorT get +    ActorT . put $! putActorMessage i (toDyn msg) astate++  actorGetMessagesM i = do +    astate <- ActorT get +    let msgs = getActorMessages i astate +    return . catMaybesSeq . fmap fromDynamic $! msgs++  findActorTypeRepM n = do +    astate <- ActorT get +    return . H.lookup n . actorNameMap $! astate++  registerActorTypeRepM p = do +    astate <- ActorT get +    let fp = actorFingerprint p+    ActorT . put $! astate {+        actorNameMap = H.insert (show fp) fp . actorNameMap $! astate+      }++instance {-# OVERLAPPABLE #-} (MonadThrow (mt m), ActorMonad m, MonadTrans mt) => ActorMonad (mt m) where +  actorRegisterM = lift actorRegisterM+  actorRegisterFixedM = lift . actorRegisterFixedM+  actorDeleteM = lift . actorDeleteM+  actorRegisteredM = lift . actorRegisteredM+  actorSendM a b = lift $ actorSendM a b+  actorGetMessagesM = lift . actorGetMessagesM+  findActorTypeRepM = lift . findActorTypeRepM+  registerActorTypeRepM = lift . registerActorTypeRepM++-- | Leaves only Just values  +catMaybesSeq :: S.Seq (Maybe a) -> S.Seq a +catMaybesSeq = fmap fromJust . S.filter isJust++-- | Helper to get actor fingerprint from id value+getActorFingerprint :: forall i . ActorMessage i => i -> HashableTypeRep+getActorFingerprint _ = actorFingerprint (Proxy :: Proxy i)++-- | Returns next unregistered id of actor and updates internal state+pushActorNextId :: forall i s . ActorMessage i => ActorState s -> (HashableTypeRep, i, ActorState s)+pushActorNextId !s = case H.lookup k (actorBoxes s) of+  Just _ -> pushActorNextId nextState+  Nothing -> (fingerprint, nextId, nextState)+  where +    fingerprint = actorFingerprint (Proxy :: Proxy i)+    (nextId, nextState) = rawGet s +    k = (fingerprint, toCounter nextId)++    -- | Update @actorNextId@ map+    rawGet :: ActorState s -> (i, ActorState s)+    rawGet s' = case H.lookup fingerprint (actorNextId s') of +      Nothing -> (fromCounter 0, s' {+        actorNextId = H.insert fingerprint 1 (actorNextId s')+        })+      Just i -> (fromCounter i, s' {+        actorNextId = H.insert fingerprint (i+1) (actorNextId s')+        })+ +-- | Try to register given id in the mailbox map+regActorFixedId :: forall i s . ActorMessage i => i -> ActorState s -> Maybe (ActorState s)+regActorFixedId !i !s = case H.lookup k (actorBoxes s) of +  Just _ -> Nothing+  Nothing -> Just $! s {+      actorBoxes = H.insert k (S.empty, S.empty) . actorBoxes $! s+    , actorNameMap = H.insert (show fingerprint) fingerprint . actorNameMap $! s+    }+  where+    fingerprint = actorFingerprint (Proxy :: Proxy i)+    k = (fingerprint, toCounter i)++-- | Remove actor id from mailbox map+deleteActorId :: forall i s . ActorMessage i => i -> ActorState s -> ActorState s +deleteActorId !i !s = s {+    actorBoxes = H.delete k . actorBoxes $! s +  , actorNameMap = H.delete (show fingerprint) . actorNameMap $! s+  }+  where+    fingerprint = actorFingerprint (Proxy :: Proxy i)+    k = (fingerprint, toCounter i)++-- | Returns True if given ID is registered+isActorIdRegistered :: forall i s . ActorMessage i => i -> ActorState s -> Bool+isActorIdRegistered !i !s = case H.lookup k . actorBoxes $! s of +  Nothing -> False +  Just _ -> True +  where+    fingerprint = actorFingerprint (Proxy :: Proxy i)+    k = (fingerprint, toCounter i)++-- | Appends given message in corresponding message queue+putActorMessage :: forall i s . ActorMessage i => i -> Dynamic -> ActorState s -> ActorState s+putActorMessage !i !msg !s = case H.lookup k . actorBoxes $! s of +  Nothing -> s+  Just (msgsR, msgsS) -> s {+      actorBoxes = H.insert k (msgsR, msgsS S.|> msg) . actorBoxes $! s+    }+  where+    fingerprint = actorFingerprint (Proxy :: Proxy i)+    k = (fingerprint, toCounter i)++-- | Return all messages in corresponding mailbox+getActorMessages :: forall i s . ActorMessage i => i -> ActorState s -> S.Seq Dynamic+getActorMessages !i !s = case H.lookup k . actorBoxes $! s of +  Nothing -> S.empty+  Just (msgs, _) -> msgs+  where+    fingerprint = actorFingerprint (Proxy :: Proxy i)+    k = (fingerprint, toCounter i)++-- | Sends message to statically known actor+actorSend :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i)) +  => i -> GameWire m (Event (ActorMessageType i)) (Event ())+actorSend i = liftGameMonadEvent1 $ actorSendM i++-- | Sends many messages to statically known actor+actorSendMany :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i), F.Foldable t)+  => i -> GameWire m (Event (t (ActorMessageType i))) (Event ())+actorSendMany i = liftGameMonadEvent1 $ F.mapM_ (actorSendM i)++-- | Sends message to actor with incoming id+actorSendDyn :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i)) +  => GameWire m (Event (i, ActorMessageType i)) (Event ())+actorSendDyn = liftGameMonadEvent1 $ \(i, m) -> actorSendM i m++-- | Sends many messages, dynamic version of actorSendMany which takes actor id as arrow input+actorSendManyDyn :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i), F.Foldable t)+  => GameWire m (Event (t (i, ActorMessageType i))) (Event ())+actorSendManyDyn = liftGameMonadEvent1 $ F.mapM_ (uncurry actorSendM)++-- | Helper to process all messages from message queue and update a state+actorProcessMessages :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i))+  => i -- ^ Actor id known statically+  -> (a -> ActorMessageType i -> a) -- ^ Action that modifies accumulator+  -> GameWire m a a -- ^ Wire that updates input value using supplied function+actorProcessMessages i f = liftGameMonad1 $ \a -> do +  msgs <- actorGetMessagesM i+  return . F.foldl' f a $! msgs++-- | Helper to process all messages from message queue and update a state (monadic version)+actorProcessMessagesM :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i))+  => i -- ^ Actor id known statically+  -> (a -> ActorMessageType i -> GameMonadT m a) -- ^ Monadic action that modifies accumulator+  -> GameWire m a a -- ^ Wire that updates input value using supplied function+actorProcessMessagesM i f = liftGameMonad1 $ \a -> do +  msgs <- actorGetMessagesM i +  foldM f a msgs++-- | Registers new index for wire and makes an actor wire+makeActor :: (ActorMonad m, ActorMessage i) +  => (i -> GameWire m a b) -- ^ Body wire+  -> GameActor m i a b -- ^ Operation that makes actual actor+makeActor wbody = do +  i <- actorRegisterM+  return $! GameWireIndexed i (wbody i)++-- | Registers new actor with fixed id, can fail with ActorException if there is already +-- registered actor for that id+makeFixedActor :: (ActorMonad m, ActorMessage i) +  => i -- ^ Manual id of actor+  -> GameWire m a b -- ^ Body wire+  -> GameActor m i a b -- ^ Operation that makes actual actor+makeFixedActor i wbody = do +  actorRegisterFixedM i+  return $! GameWireIndexed i wbody++-- | If need no dynamic switching, you can use the function to embed index wire just at time+runActor :: ActorMonad m +  => GameActor m i a b -- ^ Actor creator+  -> GameWire m a (b, i) -- ^ Usual wire that also returns id of inner indexed wire+runActor actor = switch makeWire+  where+  -- | Switches immidieatly to created wire, thats why error is used for+  -- value that should be returned in case where there is no event.+  makeWire = proc _ -> do +    e <- mapE (\iw -> arr (, indexedId iw) . indexedWire iw) . now . liftGameMonadOnce actor -< ()+    returnA -< (error "runActor: impossible", e)++-- | Same as runActor, but doesn't return id of actor+runActor' :: ActorMonad m +  => GameActor m i a b -- ^ Actor creator+  -> GameWire m a b -- ^ Usual wire+runActor' actor = arr fst . runActor actor++-- | Non-centric style of subscribing to messages+actorMessages :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i))+  => i -- ^ Actor id which messages we look for+  -> (ActorMessageType i -> Bool) -- ^ Filter function, leaves only with True return value+  -> GameWire m a (Event (S.Seq (ActorMessageType i)))+actorMessages i f = liftGameMonad $ do +  msgs <- S.filter f <$> actorGetMessagesM i +  return $! if S.null msgs then NoEvent+    else Event msgs

@@ -0,0 +1,115 @@+{-|+Module      : Game.GoreAndAsh.Actor.Collection+Description : Handling dynamic collections of actors+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Actor.Collection(+    dynCollection+  , dDynCollection+  , DynCollection(..)+  , module ReExport+  ) where++import Control.Monad +import Control.Wire+import Control.Wire.Unsafe.Event +import Data.Filterable +import Prelude hiding ((.), id)+import qualified Data.Foldable as F ++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor.API+import Game.GoreAndAsh.Actor.Indexed++import Game.GoreAndAsh.Actor.Collection.Data as ReExport++-- | Helper that performs monadic action over value of event or returns default value+--+-- Note: the function is isomorphic to @Data.Maybe.maybe@+onEvent :: Monad m => b -> Event a -> (a -> m b) -> m b+onEvent def e f = case e of +  NoEvent -> return def +  Event a -> f a ++-- | Makes dynamic collection of wires.+--+-- * First input of wire is input for each inner wire.+--+-- * Second input is event for adding several wires to collection.+-- +-- * Third input is event for removing several wires from collection.+--+-- * Wire returns list of outputs of inner wires.+--+-- Note: if ihibits one of the wires, it is removed from output result during its inhibition+dynCollection :: forall m i a b c c2 . (ActorMonad m, Eq i, DynCollection c, FilterConstraint c (GameWireIndexed m i a b), FilterConstraint c (Either () b), F.Foldable c2) => +    (c (GameActor m i a b)) -- ^ Inital set of wires+    -> GameWire m (a, Event (c (GameActor m i a b)), Event (c2 i)) (c b)+dynCollection initialActors = mkGen $ \ds input -> do +  arrs <- sequence initialActors+  go arrs ds input+  where +  go :: c (GameWireIndexed m i a b)+    -> GameTime+    -> (a, Event (c (GameActor m i a b)), Event (c2 i))+    -> GameMonadT m (Either () (c b), GameWire m (a, Event (c (GameActor m i a b)), Event (c2 i)) (c b))+  go currentWires ds (a, addEvent, removeEvent) = do++    -- Adding new wires+    newAddedWires <- onEvent currentWires addEvent $ \newActors -> do +      addWires <- sequence newActors+      return $ currentWires `concatDynColl` addWires++    -- Removing wires+    newRemovedWires <- onEvent newAddedWires removeEvent $ \ids ->  +      return $ F.foldl' (\acc i -> fFilter ((/= i) . indexedId) acc) newAddedWires ids++    -- Calculating outputs+    (bs, newWiresCntrls) <- liftM unzipDynColl $ mapM (\w -> stepWire w ds (Right a)) $ indexedWire <$> newRemovedWires+    let newWires = uncurry updateIndexedWire <$> (fmap const newWiresCntrls `zipDynColl` newRemovedWires)++    return $ length newWires `seq` (Right (rightsDynColl bs), mkGen $ go newWires)++-- | Makes dynamic collection of wires.+--+-- * First input of wire is input for each inner wire.+--+-- * Second input is event for adding several wires to collection.+--+-- * Third input is event for removing several wires from collection.+--+-- * Wire returns list of outputs of inner wires.+--+-- Note: it is delayed version of dynCollection, removing and adding of agents performs on next step after current.+--+-- Note: if ihibits one of the wires, it is removed from output result while it inhibits.+dDynCollection :: forall m i a b c c2 . (ActorMonad m, Eq i, DynCollection c, FilterConstraint c (GameWireIndexed m i a b), FilterConstraint c (Either () b), F.Foldable c2) =>+    (c (GameActor m i a b)) -- ^ Inital set of wires+    -> GameWire m (a, Event (c (GameActor m i a b)), Event (c2 i)) (c b)+dDynCollection initialActors = mkGen $ \ds input -> do +  arrs <- sequence initialActors+  go arrs ds input+  where +  go :: c (GameWireIndexed m i a b)+    -> GameTime+    -> (a, Event (c (GameActor m i a b)), Event (c2 i))+    -> GameMonadT m (Either () (c b), GameWire m (a, Event (c (GameActor m i a b)), Event (c2 i)) (c b))+  go currentWires ds (a, addEvent, removeEvent) = do+    -- Calculating outputs+    (bs, newWiresCntrls) <- liftM unzipDynColl $ mapM (\w -> stepWire w ds (Right a)) $ indexedWire <$> currentWires+    let newWires = uncurry updateIndexedWire <$> (fmap const newWiresCntrls `zipDynColl` currentWires)++    -- Adding new wires+    newAddedWires <- onEvent newWires addEvent $ \newActors -> do +      addWires <- sequence newActors +      return $ newWires `concatDynColl` addWires++    -- Removing wires+    newRemovedWires <- onEvent newAddedWires removeEvent $ \ids ->  +      return $ F.foldl' (\acc i -> fFilter ((/= i) . indexedId) acc) newAddedWires ids++    return $ length newRemovedWires `seq` (Right (rightsDynColl bs), mkGen $ go newRemovedWires)

@@ -0,0 +1,87 @@+{-|+Module      : Game.GoreAndAsh.Actor.Collection.Data+Description : Handling dynamic collections of actors+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Actor.Collection.Data(+    DynCollection(..)+  , ElementWithId(..)+  , rightsDynColl+  ) where++import Control.Monad +import Control.Wire+import Data.Either (isRight)+import Data.Filterable +import Data.Hashable +import Data.List (nub)+import GHC.Exts+import Prelude hiding ((.), id)+import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++-- | Dynamic collection for control wire that automates handling collections of+-- FRP actors. The class defines minimum set of actions that collection should support+-- to be used as base for collection of actors.+class (Filterable c, F.Foldable c, Functor c, Traversable c) => DynCollection c where+  -- | Instance specific constraint for appending function+  type DynConsConstr c o :: Constraint +  type DynConsConstr c o = ()++  -- | Concat of two collections+  concatDynColl :: c a -> c a -> c a+  -- | Unzipping of collection+  unzipDynColl :: c (a , b) -> (c a, c b)+  -- | Ziping collection+  zipDynColl :: c a -> c b -> c (a, b)+  -- | Getting empty collection+  emptyDynColl :: c a +  -- | Adding element to the begining of collection+  consDynColl :: DynConsConstr c a => a -> c a -> c a ++instance DynCollection [] where+  concatDynColl = (++)+  unzipDynColl = unzip +  zipDynColl = zip +  emptyDynColl = []+  consDynColl = (:)++instance DynCollection S.Seq where +  concatDynColl = (S.><)+  unzipDynColl = F.foldl' (\(as, bs) (a, b) -> (as S.|> a, bs S.|> b)) (S.empty, S.empty)+  zipDynColl = S.zip +  emptyDynColl = S.empty+  consDynColl = (S.<|)++-- | Elements that contains id +class (Hashable i, Eq i) => ElementWithId a i where+  elementId :: a -> i ++-- | Order of elements is not preserved+instance (Eq k, Hashable k) => DynCollection (H.HashMap k) where+  type DynConsConstr (H.HashMap k) o = ElementWithId o k++  concatDynColl = H.union+  unzipDynColl = H.foldlWithKey' (\(as, bs) k (a, b) -> (H.insert k a as, H.insert k b bs)) (H.empty, H.empty) +  zipDynColl as bs = F.foldl' mrg H.empty $ nub $ H.keys as ++ H.keys bs+    where +    mrg acc k = case (H.lookup k as, H.lookup k bs) of +      (Just a, Just b) -> H.insert k (a, b) acc+      _ -> acc++  emptyDynColl = H.empty+  consDynColl a = H.insert (elementId a) a++-- | Helper to filter out lefts+rightsDynColl :: (FilterConstraint c (Either e a), DynCollection c) +  => c (Either e a) -> c a +rightsDynColl = fmap fromRight . fFilter isRight+  where+  fromRight e = case e of +    Left _ -> error "rightsDynColl: left (impossible)"+    Right a -> a

@@ -0,0 +1,59 @@+{-|+Module      : Game.GoreAndAsh.Actor+Description : Module that contains actor API for Gore&Ash+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Actor.Indexed(+    GameWireIndexed(..)+  , GameActor+  , updateIndexedWire+  , postActorAction+  , preActorAction+  ) where++import Control.Wire +import Prelude hiding (id, (.))++import Game.GoreAndAsh.Core.Arrow+import Game.GoreAndAsh.Core.Monad ++-- | Game wire that has its own id+data GameWireIndexed m i a b = GameWireIndexed {+  indexedId :: i +, indexedWire :: GameWire m a b+}++-- | Equality by equality of ids+instance Eq i => Eq (GameWireIndexed m i a b) where+  gw1 == gw2 = indexedId gw1 == indexedId gw2++-- | Replaces controlling wire in indexed wire+updateIndexedWire :: (GameWire m a b -> GameWire m a b) -> GameWireIndexed m i a b -> GameWireIndexed m i a b +updateIndexedWire f wi = wi { indexedWire = f $ indexedWire wi }++-- | Common pattern in game for creating incapsulated objects+--+-- Usually wires that are actors need context to register themselfes in core.+-- Major part of wire functions operates with such wrapped indexed arrows thats+-- why the convinient type synonym is exists.+type GameActor m i a b = GameMonadT m (GameWireIndexed m i a b)++-- | Compose actor and wire, the wire is added at the end of actor controller+postActorAction :: Monad m => GameActor m i a b -> (i -> GameWire m b c) -> GameActor m i a c+postActorAction mindexed wi = do +  indexed <- mindexed+  return $ indexed {+      indexedWire = wi (indexedId indexed) . indexedWire indexed+    }++-- | Compose actor and wire, the wire is added at the beginning of actor controller+preActorAction :: Monad m => (i -> GameWire m c a) -> GameActor m i a b -> GameActor m i c b+preActorAction wi mindexed = do +  indexed <- mindexed+  return $ indexed {+      indexedWire = indexedWire indexed . wi (indexedId indexed)+    }

@@ -0,0 +1,37 @@+{-|+Module      : Game.GoreAndAsh.Actor+Description : Typeclass for type of actor message+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.Actor.Message(+    ActorMessage(..)+  , actorFingerprint+  ) where++import Data.Typeable++import Game.GoreAndAsh.Actor.TypeRep++-- | The typeclass separates message API's of different type of actors+--  +-- In general you don't want to have one global type to handle all possible types of messages,+-- it will break modularity. Thats why you creates (with newtype) separate types of ids for+-- each actor and statically binds message type (usually algebraic type) to the id.+--+-- The class implies that your id is some integer type, but it could be not. Just provide way+-- to stable convertion of you id to integer and vice-versa.+class Typeable objectId => ActorMessage objectId where +  -- | Binded message type, mailbox with id type of objectId would accept only this message type+  type ActorMessageType objectId :: *+  -- | Convertion from global counter. Don't use it in client code as it could break type safety.+  fromCounter :: Int -> objectId+  -- | Convertion to global counter. Don't use it in client code as it could break type safety.+  toCounter :: objectId -> Int++-- | Returns hashable fingerprint of actor that is stable across applications (unique by type name)+actorFingerprint :: forall proxy a . ActorMessage a => proxy a -> HashableTypeRep+actorFingerprint = hashableTypeRep

@@ -0,0 +1,59 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.Actor.Module+Description : Monad transformer for actor core module+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The module contains monad transformer for actor core module and +instance of 'GameModule' for it.+-}+module Game.GoreAndAsh.Actor.Module(+    ActorT(..)+  ) where++import Control.Monad.Catch+import Control.Monad.Fix +import Control.Monad.State.Strict++import Game.GoreAndAsh+import Game.GoreAndAsh.Actor.State++-- | Monad transformer of actor core module.+--+-- [@s@] - State of next core module in modules chain;+--+-- [@m@] - Next monad in modules monad stack;+--+-- [@a@] - Type of result value;+--+-- How to embed module:+-- +-- @+-- type AppStack = ModuleStack [ActorT, ... other modules ... ] IO+--+-- newtype AppMonad a = AppMonad (AppStack a)+--   deriving (Functor, Applicative, Monad, MonadFix, MonadIO, ActorMonad)+-- @+--+-- The module is pure within first phase (see 'ModuleStack' docs) but requires 'MonadThrow'+-- instance of end monad, therefore currently only 'IO' end monad can handler the module.+newtype ActorT s m a = ActorT { runActorT :: StateT (ActorState s) m a }+  deriving (Functor, Applicative, Monad, MonadState (ActorState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask)++instance GameModule m s => GameModule (ActorT s m) (ActorState s) where +  type ModuleState (ActorT s m) = ActorState s+  runModule (ActorT m) s = do+    ((a, s'), nextState) <- runModule (runStateT m s) (actorNextState s)+    let s'' = moveSendedMessages s'+    return (a, s'' { +       actorNextState = nextState +      })++  newModuleState = emptyActorState <$> newModuleState++  withModule _ = id+  cleanupModule _ = return ()

@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.Actor.State+Description : State of actor core module+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++Internal state of actor core module.+-}+module Game.GoreAndAsh.Actor.State(+    ActorState(..)+  , emptyActorState+  , moveSendedMessages+  ) where++import Control.DeepSeq +import Data.Dynamic+import GHC.Generics (Generic)+import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++import Game.GoreAndAsh.Actor.TypeRep++-- | Inner state of actor module.+--+-- [@s@] - State of next module, the states are chained via nesting.+data ActorState s = ActorState {+  -- | Stores messages for actor with specified id+  --+  -- Message has type of Dynamic as message manager doesn't know anything about message types.+  -- We don't need to serialization protocol due passing via memory. Type safety is forced +  -- with Messagable type class with type family (see Actor.Message module). Id space is separate for each actor type+  --+  -- There are two sequences of messages, one for recieved messages from previous frame, and+  -- the second one for messages recieved at current frame. At the end of each frame first+  -- sequence is purged and filled with contents of first and the second one is replaced with+  -- empty sequence.+  actorBoxes :: !(H.HashMap (HashableTypeRep, Int) (S.Seq Dynamic, S.Seq Dynamic))+  -- | Next empty id of actor, id space is separate for each actor type+, actorNextId :: !(H.HashMap HashableTypeRep Int)+  -- | Search table for actor names+, actorNameMap :: !(H.HashMap String HashableTypeRep)+  -- | Next state in state chain of modules+, actorNextState :: !s+} deriving (Generic)++instance NFData Dynamic where +  rnf = (`seq` ())++instance NFData s => NFData (ActorState s)++-- | Create empty actor state+emptyActorState :: s -> ActorState s +emptyActorState s = ActorState {+    actorBoxes = H.empty+  , actorNextId = H.empty+  , actorNameMap = H.empty+  , actorNextState = s+  }++-- | Perform rotation between sended messages and recieved ones+moveSendedMessages :: ActorState s -> ActorState s +moveSendedMessages s = s {+    actorBoxes = fmap (\(_, b) -> (b, S.empty)) . actorBoxes $! s+  }

@@ -0,0 +1,50 @@+{-|+Module      : Game.GoreAndAsh.Actor.TypeRep+Description : Hashable type representation+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++-}+module Game.GoreAndAsh.Actor.TypeRep(+    HashableTypeRep+  , toHashableTypeRep+  , fromHashableTypeRep+  , hashableTypeRep+  ) where++import Control.DeepSeq+import Data.Hashable +import Data.Typeable+import GHC.Generics ++-- | Wrapper around TypeRep that supports Hashable and Eq, that are performed over type name+-- Note: the implentation is choosen to support equality of actors between several applications+newtype HashableTypeRep = HashableTypeRep { unHashableTypeRep :: TypeRep }+  deriving (Generic, Typeable)++instance Eq HashableTypeRep where +  (HashableTypeRep a) == (HashableTypeRep b) = show a == show b++instance Show HashableTypeRep where +  showsPrec i = showsPrec i . unHashableTypeRep++instance Hashable HashableTypeRep where+  hashWithSalt salt (HashableTypeRep tr) = salt `hashWithSalt` show tr++-- | Helper to transform usual 'TypeRep' to hashable one.+toHashableTypeRep :: TypeRep -> HashableTypeRep+toHashableTypeRep = HashableTypeRep++-- | Helper to transform hashable type rep to usual 'TypeRep'.+fromHashableTypeRep :: HashableTypeRep -> TypeRep +fromHashableTypeRep = unHashableTypeRep++-- | Helper to get hashable type rep from type+hashableTypeRep :: forall proxy a . Typeable a => proxy a -> HashableTypeRep+hashableTypeRep = HashableTypeRep . typeRep++instance NFData HashableTypeRep where+  rnf (HashableTypeRep tr) = rnfTypeRep tr