module Simulation.Aivika.Dynamics.Agent
(Agent,
AgentState,
newAgent,
newState,
newSubstate,
agentQueue,
agentState,
activateState,
initState,
stateAgent,
stateParent,
addTimeout,
addTimer,
stateActivation,
stateDeactivation) where
import Data.IORef
import Control.Monad
import Simulation.Aivika.Dynamics.Internal.Simulation
import Simulation.Aivika.Dynamics.Internal.Dynamics
import Simulation.Aivika.Dynamics.EventQueue
data Agent = Agent { agentQueue :: EventQueue,
agentModeRef :: IORef AgentMode,
agentStateRef :: IORef (Maybe AgentState) }
data AgentState = AgentState { stateAgent :: Agent,
stateParent :: Maybe AgentState,
stateActivateRef :: IORef (Dynamics ()),
stateDeactivateRef :: IORef (Dynamics ()),
stateVersionRef :: IORef Int }
data AgentMode = CreationMode
| InitialMode
| TransientMode
| ProcessingMode
instance Eq Agent where
x == y = agentStateRef x == agentStateRef y
instance Eq AgentState where
x == y = stateVersionRef x == stateVersionRef y
findPath :: AgentState -> AgentState -> ([AgentState], [AgentState])
findPath source target =
if stateAgent source == stateAgent target
then
partitionPath path1 path2
else
error "Different agents: findPath."
where
path1 = fullPath source []
path2 = fullPath target []
fullPath st acc =
case stateParent st of
Nothing -> st : acc
Just st' -> fullPath st' (st : acc)
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)
traversePath :: AgentState -> AgentState -> Dynamics ()
traversePath source target =
let (path1, path2) = findPath source target
agent = stateAgent source
activate st p =
do Dynamics m <- readIORef (stateActivateRef st)
m p
deactivate st p =
do Dynamics m <- readIORef (stateDeactivateRef st)
m p
in Dynamics $ \p ->
do writeIORef (agentModeRef agent) TransientMode
forM_ path1 $ \st ->
do writeIORef (agentStateRef agent) (Just st)
deactivate st p
modifyIORef (stateVersionRef st) (1 +)
forM_ path2 $ \st ->
do when (st == target) $
writeIORef (agentModeRef agent) InitialMode
writeIORef (agentStateRef agent) (Just st)
activate st p
when (st == target) $
writeIORef (agentModeRef agent) ProcessingMode
addTimeout :: AgentState -> Double -> Dynamics () -> Dynamics ()
addTimeout st dt (Dynamics action) =
Dynamics $ \p ->
do let q = agentQueue (stateAgent st)
Dynamics m0 = queueRun q
m0 p
v <- readIORef (stateVersionRef st)
let m1 = Dynamics $ \p ->
do v' <- readIORef (stateVersionRef st)
when (v == v') $ action p
Dynamics m2 = enqueue q (pointTime p + dt) m1
m2 p
addTimer :: AgentState -> Dynamics Double -> Dynamics () -> Dynamics ()
addTimer st (Dynamics dt) (Dynamics action) =
Dynamics $ \p ->
do let q = agentQueue (stateAgent st)
Dynamics m0 = queueRun q
m0 p
v <- readIORef (stateVersionRef st)
let m1 = Dynamics $ \p ->
do 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
newState :: Agent -> Simulation AgentState
newState agent =
Simulation $ \r ->
do aref <- newIORef $ return ()
dref <- newIORef $ return ()
vref <- newIORef 0
return AgentState { stateAgent = agent,
stateParent = Nothing,
stateActivateRef = aref,
stateDeactivateRef = dref,
stateVersionRef = vref }
newSubstate :: AgentState -> Simulation AgentState
newSubstate parent =
Simulation $ \r ->
do let agent = stateAgent parent
aref <- newIORef $ return ()
dref <- newIORef $ return ()
vref <- newIORef 0
return AgentState { stateAgent = agent,
stateParent = Just parent,
stateActivateRef= aref,
stateDeactivateRef = dref,
stateVersionRef = vref }
newAgent :: EventQueue -> Simulation Agent
newAgent queue =
Simulation $ \r ->
do modeRef <- newIORef CreationMode
stateRef <- newIORef Nothing
return Agent { agentQueue = queue,
agentModeRef = modeRef,
agentStateRef = stateRef }
agentState :: Agent -> Dynamics (Maybe AgentState)
agentState agent =
Dynamics $ \p ->
do let Dynamics m = queueRun $ agentQueue agent
m p
readIORef (agentStateRef agent)
activateState :: AgentState -> Dynamics ()
activateState st =
Dynamics $ \p ->
do let agent = stateAgent st
Dynamics m = queueRun $ agentQueue agent
m p
mode <- readIORef (agentModeRef agent)
case mode of
CreationMode ->
case stateParent st of
Just _ ->
error $
"To run the agent for the first time, an initial state " ++
"must be top-level: activateState."
Nothing ->
do writeIORef (agentModeRef agent) InitialMode
writeIORef (agentStateRef agent) (Just st)
Dynamics m <- readIORef (stateActivateRef st)
m p
writeIORef (agentModeRef agent) ProcessingMode
InitialMode ->
error $
"Use the initState function during " ++
"the state activation: activateState."
TransientMode ->
error $
"Use the initState function during " ++
"the state activation: activateState."
ProcessingMode ->
do Just st0 <- readIORef (agentStateRef agent)
let Dynamics m = traversePath st0 st
m p
initState :: AgentState -> Dynamics ()
initState st =
Dynamics $ \p ->
do let agent = stateAgent st
Dynamics m = queueRun $ agentQueue agent
m p
mode <- readIORef (agentModeRef agent)
case mode of
CreationMode ->
error $
"To run the agent for the fist time, use " ++
"the activateState function: initState."
InitialMode ->
do Just st0 <- readIORef (agentStateRef agent)
let Dynamics m = traversePath st0 st
m p
TransientMode ->
return ()
ProcessingMode ->
error $
"Use the activateState function everywhere outside " ++
"the state activation: initState."
stateActivation :: AgentState -> Dynamics () -> Simulation ()
stateActivation st action =
Simulation $ \r ->
writeIORef (stateActivateRef st) action
stateDeactivation :: AgentState -> Dynamics () -> Simulation ()
stateDeactivation st action =
Simulation $ \r ->
writeIORef (stateDeactivateRef st) action