aivika-0.6: Simulation/Aivika/Dynamics/Agent.hs
-- |
-- Module : Simulation.Aivika.Dynamics.Agent
-- Copyright : Copyright (c) 2009-2013, David Sorokin <david.sorokin@gmail.com>
-- License : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability : experimental
-- Tested with: GHC 7.6.3
--
-- This module introduces basic entities for the agent-based modeling.
--
-- WARNING: the module is not well tested. This caution is related mainly to
-- managing the nested states.
--
-- At the same time, the timer and timeout handlers seem to be well tested as
-- they are just light-weight wrappers creating the event handlers that are
-- already processed by the event queue.
--
module Simulation.Aivika.Dynamics.Agent
(Agent,
AgentState,
newAgent,
newState,
newSubstate,
agentQueue,
agentState,
agentStateChanged,
agentStateChanged_,
activateState,
initState,
stateAgent,
stateParent,
addTimeout,
addTimer,
stateActivation,
stateDeactivation,
setStateActivation,
setStateDeactivation,
setStateTransition) where
import Data.IORef
import Control.Monad
import Simulation.Aivika.Dynamics.Internal.Simulation
import Simulation.Aivika.Dynamics.Internal.Dynamics
import Simulation.Aivika.Dynamics.EventQueue
import Simulation.Aivika.Dynamics.Internal.Signal
--
-- Agent-based Modeling
--
-- | Represents an agent.
data Agent = Agent { agentQueue :: EventQueue,
-- ^ Return the bound event queue.
agentModeRef :: IORef AgentMode,
agentStateRef :: IORef (Maybe AgentState),
agentStateChangedSource :: SignalSource (Maybe AgentState),
agentStateUpdatedSource :: SignalSource (Maybe AgentState) }
-- | Represents the agent state.
data AgentState = AgentState { stateAgent :: Agent,
-- ^ Return the corresponded agent.
stateParent :: Maybe AgentState,
-- ^ Return the parent state or 'Nothing'.
stateActivateRef :: IORef (Dynamics ()),
stateDeactivateRef :: IORef (Dynamics ()),
stateTransitRef :: IORef (Dynamics (Maybe AgentState)),
stateVersionRef :: IORef Int }
data AgentMode = CreationMode
| InitialMode
| TransientMode
| ProcessingMode
instance Eq Agent where
x == y = agentStateRef x == agentStateRef y -- unique references
instance Eq AgentState where
x == y = stateVersionRef x == stateVersionRef y -- unique references
fullPath :: AgentState -> [AgentState] -> [AgentState]
fullPath st acc =
case stateParent st of
Nothing -> st : acc
Just st' -> fullPath st' (st : acc)
partitionPath :: [AgentState] -> [AgentState] -> ([AgentState], [AgentState])
partitionPath path1 path2 =
case (path1, path2) of
(h1 : t1, [h2]) | h1 == h2 ->
(reverse path1, path2)
(h1 : t1, h2 : t2) | h1 == h2 ->
partitionPath t1 t2
_ ->
(reverse path1, path2)
findPath :: Maybe AgentState -> AgentState -> ([AgentState], [AgentState])
findPath Nothing target = ([], fullPath target [])
findPath (Just source) target
| stateAgent source /= stateAgent target =
error "Different agents: findPath."
| otherwise =
partitionPath path1 path2
where
path1 = fullPath source []
path2 = fullPath target []
traversePath :: Maybe AgentState -> AgentState -> Dynamics ()
traversePath source target =
let (path1, path2) = findPath source target
agent = stateAgent target
activate st p =
do Dynamics m <- readIORef (stateActivateRef st)
m p
deactivate st p =
do Dynamics m <- readIORef (stateDeactivateRef st)
m p
transit st p =
do Dynamics m <- readIORef (stateTransitRef st)
m p
continue st p =
do let Dynamics m = traversePath (Just target) st
m p
in Dynamics $ \p ->
unless (null path1 && null path2) $
do writeIORef (agentModeRef agent) TransientMode
forM_ path1 $ \st ->
do writeIORef (agentStateRef agent) (Just st)
deactivate st p
-- it makes all timeout and timer handlers outdated
modifyIORef (stateVersionRef st) (1 +)
forM_ path2 $ \st ->
do when (st == target) $
writeIORef (agentModeRef agent) InitialMode
writeIORef (agentStateRef agent) (Just st)
activate st p
writeIORef (agentModeRef agent) TransientMode
st' <- transit target p
case st' of
Nothing ->
do writeIORef (agentModeRef agent) ProcessingMode
triggerAgentStateChanged p agent
Just st' ->
continue st' p
-- | Add to the state a timeout handler that will be actuated
-- in the specified time period, while the state remains active.
addTimeout :: AgentState -> Double -> Dynamics () -> Dynamics ()
addTimeout st dt (Dynamics action) =
Dynamics $ \p ->
do let q = agentQueue (stateAgent st)
Dynamics m0 = runQueueSync q
m0 p -- ensure that the agent state is actual
v <- readIORef (stateVersionRef st)
let m1 = Dynamics $ \p ->
do -- checkTime p (stateAgent st) "addTimeout"
v' <- readIORef (stateVersionRef st)
when (v == v') $ action p
Dynamics m2 = enqueue q (pointTime p + dt) m1
m2 p
-- | Add to the state a timer handler that will be actuated
-- in the specified time period and then repeated again many times,
-- while the state remains active.
addTimer :: AgentState -> Dynamics Double -> Dynamics () -> Dynamics ()
addTimer st (Dynamics dt) (Dynamics action) =
Dynamics $ \p ->
do let q = agentQueue (stateAgent st)
Dynamics m0 = runQueueSync q
m0 p -- ensure that the agent state is actual
v <- readIORef (stateVersionRef st)
let m1 = Dynamics $ \p ->
do -- checkTime p (stateAgent st) "addTimer"
v' <- readIORef (stateVersionRef st)
when (v == v') $ do { m2 p; action p }
Dynamics m2 =
Dynamics $ \p ->
do dt' <- dt p
let Dynamics m3 = enqueue q (pointTime p + dt') m1
m3 p
m2 p
-- | Create a new state.
newState :: Agent -> Simulation AgentState
newState agent =
Simulation $ \r ->
do aref <- newIORef $ return ()
dref <- newIORef $ return ()
tref <- newIORef $ return Nothing
vref <- newIORef 0
return AgentState { stateAgent = agent,
stateParent = Nothing,
stateActivateRef = aref,
stateDeactivateRef = dref,
stateTransitRef = tref,
stateVersionRef = vref }
-- | Create a child state.
newSubstate :: AgentState -> Simulation AgentState
newSubstate parent =
Simulation $ \r ->
do let agent = stateAgent parent
aref <- newIORef $ return ()
dref <- newIORef $ return ()
tref <- newIORef $ return Nothing
vref <- newIORef 0
return AgentState { stateAgent = agent,
stateParent = Just parent,
stateActivateRef= aref,
stateDeactivateRef = dref,
stateTransitRef = tref,
stateVersionRef = vref }
-- | Create an agent bound with the specified event queue.
newAgent :: EventQueue -> Simulation Agent
newAgent queue =
Simulation $ \r ->
do modeRef <- newIORef CreationMode
stateRef <- newIORef Nothing
let Simulation m1 = newSignalSourceUnsafe
Simulation m2 = newSignalSourceWithUpdate $ runQueue queue
stateChangedSource <- m1 r
stateUpdatedSource <- m2 r
return Agent { agentQueue = queue,
agentModeRef = modeRef,
agentStateRef = stateRef,
agentStateChangedSource = stateChangedSource,
agentStateUpdatedSource = stateUpdatedSource }
-- | Return the selected downmost active state.
agentState :: Agent -> Dynamics (Maybe AgentState)
agentState agent =
Dynamics $ \p ->
do let Dynamics m = runQueueSync $ agentQueue agent
m p -- ensure that the agent state is actual
readIORef (agentStateRef agent)
-- | Select the next downmost active state. The activation is repeated while
-- there is the transition state defined by 'setStateTransition'.
activateState :: AgentState -> Dynamics ()
activateState st =
Dynamics $ \p ->
do let agent = stateAgent st
Dynamics m = runQueueSync $ agentQueue agent
m p -- ensure that the agent state is actual
mode <- readIORef (agentModeRef agent)
case mode of
CreationMode ->
do x0 <- readIORef (agentStateRef agent)
let Dynamics m = traversePath x0 st
m p
InitialMode ->
error $
"Use the setStateTransition function to define " ++
"the transition state: activateState."
TransientMode ->
error $
"Use the setStateTransition function to define " ++
"the transition state: activateState."
ProcessingMode ->
do x0 @ (Just st0) <- readIORef (agentStateRef agent)
let Dynamics m = traversePath x0 st
m p
{-# DEPRECATED initState "Rewrite using the setStateTransition function instead." #-}
-- | Activate the child state during the direct activation of
-- the parent state. This call is ignored in other cases.
initState :: AgentState -> Dynamics ()
initState st =
Dynamics $ \p ->
do let agent = stateAgent st
Dynamics m = runQueueSync $ agentQueue agent
m p -- ensure that the agent state is actual
mode <- readIORef (agentModeRef agent)
case mode of
CreationMode ->
error $
"To run the agent for the fist time, use " ++
"the activateState function: initState."
InitialMode ->
do x0 @ (Just st0) <- readIORef (agentStateRef agent)
let Dynamics m = traversePath x0 st
m p
TransientMode ->
return ()
ProcessingMode ->
error $
"Use the activateState function everywhere outside " ++
"the state activation: initState."
{-# DEPRECATED stateActivation "Use the setStateActivation function instead" #-}
{-# DEPRECATED stateDeactivation "Use the setStateDeactivation function instead" #-}
-- | Set the activation computation for the specified state.
stateActivation :: AgentState -> Dynamics () -> Simulation ()
stateActivation = setStateActivation
-- | Set the deactivation computation for the specified state.
stateDeactivation :: AgentState -> Dynamics () -> Simulation ()
stateDeactivation = setStateDeactivation
-- | Set the activation computation for the specified state.
setStateActivation :: AgentState -> Dynamics () -> Simulation ()
setStateActivation st action =
Simulation $ \r ->
writeIORef (stateActivateRef st) action
-- | Set the deactivation computation for the specified state.
setStateDeactivation :: AgentState -> Dynamics () -> Simulation ()
setStateDeactivation st action =
Simulation $ \r ->
writeIORef (stateDeactivateRef st) action
-- | Set the transition state which will be next and which is used only
-- when activating the state directly with help of 'activateState'.
-- If the state was activated intermediately, when activating directly
-- another state, then this computation is not used.
setStateTransition :: AgentState -> Dynamics (Maybe AgentState) -> Simulation ()
setStateTransition st action =
Simulation $ \r ->
writeIORef (stateTransitRef st) action
-- | Trigger the signal when the agent state changes.
triggerAgentStateChanged :: Point -> Agent -> IO ()
triggerAgentStateChanged p agent =
do st <- readIORef (agentStateRef agent)
let Dynamics m = triggerSignal (agentStateChangedSource agent) st
m p
-- | Return a signal that notifies about every change of the state.
agentStateChanged :: Agent -> Signal (Maybe AgentState)
agentStateChanged v = merge2Signals m1 m2 -- N.B. The order is important!
where m1 = publishSignal (agentStateUpdatedSource v)
m2 = publishSignal (agentStateChangedSource v)
-- | Return a signal that notifies about every change of the state.
agentStateChanged_ :: Agent -> Signal ()
agentStateChanged_ agent =
mapSignal (const ()) $ agentStateChanged agent