module ALife.Creatur.Universe.Task
(
AgentProgram,
AgentsProgram,
SummaryProgram,
noSummary,
withAgent,
withAgents,
runNoninteractingAgents,
runInteractingAgents,
simpleDaemon,
startupHandler,
shutdownHandler,
exceptionHandler
) where
import ALife.Creatur (Agent, AgentId)
import ALife.Creatur.Clock (Clock, incTime)
import ALife.Creatur.Daemon (Daemon(..))
import ALife.Creatur.Database as D (Database, DBRecord, Record,
lookup)
import ALife.Creatur.Logger (Logger, writeToLog)
import ALife.Creatur.Util (rotate, shuffle)
import ALife.Creatur.Universe (Universe, agentDB, clock, multiLookup,
agentIds, storeOrArchive)
import Control.Exception (SomeException)
import Control.Lens (zoom)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Random (evalRandIO)
import Control.Monad.State (StateT, execStateT)
import Data.List (unfoldr)
import Data.Maybe (catMaybes)
import Data.Serialize (Serialize)
simpleDaemon :: Logger u => String -> Daemon u
simpleDaemon version = Daemon
{
onStartup = startupHandler version,
onShutdown = shutdownHandler,
onException = exceptionHandler,
task = undefined,
username = "",
sleepTime = 100000
}
startupHandler :: Logger u => String -> u -> IO u
startupHandler version = execStateT (writeToLog $ "Starting " ++ version)
shutdownHandler :: Logger u => u -> IO ()
shutdownHandler u = do
_ <- execStateT (writeToLog "Shutdown requested") u
return ()
exceptionHandler :: Logger u => u -> SomeException -> IO u
exceptionHandler u x = execStateT (writeToLog ("WARNING: " ++ show x)) u
type AgentProgram c l d n x a s
= a -> StateT (Universe c l d n x a) IO (a, Maybe s)
type SummaryProgram c l d n x a s
= [s] -> StateT (Universe c l d n x a) IO ()
noSummary :: SummaryProgram c l d n x a s
noSummary _ = return ()
withAgent :: (Clock c, Logger l, Database d, Agent a, Serialize a,
Record a, a ~ DBRecord d) =>
AgentProgram c l d n x a s -> AgentId ->
StateT (Universe c l d n x a) IO (Maybe s)
withAgent program name =
(zoom agentDB . D.lookup) name >>= withAgent' program name
withAgent' :: (Clock c, Logger l, Database d, Agent a, Serialize a,
Record a, a ~ DBRecord d) =>
AgentProgram c l d n x a s -> AgentId -> Either String a ->
StateT (Universe c l d n x a) IO (Maybe s)
withAgent' _ name (Left msg) = do
writeToLog $ "Unable to read '" ++ name ++ "': " ++ msg
return Nothing
withAgent' program _ (Right a) = do
(a', s) <- program a
zoom agentDB $ storeOrArchive a'
return s
runNoninteractingAgents
:: (Clock c, Logger l, Database d, Agent a, Serialize a, Record a,
a ~ DBRecord d)
=> AgentProgram c l d n x a s -> SummaryProgram c l d n x a s
-> StateT (Universe c l d n x a) IO ()
runNoninteractingAgents agentProgram summaryProgram = do
writeToLog "Beginning of round"
xs <- agentIds
xs' <- liftIO $ evalRandIO $ shuffle xs
writeToLog $ "Lineup: " ++ show xs'
ys <- mapM (withAgent agentProgram) xs'
summaryProgram $ catMaybes ys
zoom clock incTime
writeToLog "End of round"
type AgentsProgram c l d n x a s =
[a] -> StateT (Universe c l d n x a) IO ([a], Maybe s)
withAgents
:: (Clock c, Logger l, Database d, Agent a, Serialize a, Record a,
a ~ DBRecord d)
=> AgentsProgram c l d n x a s -> [AgentId]
-> StateT (Universe c l d n x a) IO (Maybe s)
withAgents program names =
(zoom agentDB . multiLookup) names >>= withAgents' program
withAgents'
:: (Clock c, Logger l, Database d, Agent a, Serialize a,
Record a, a ~ DBRecord d)
=> AgentsProgram c l d n x a s -> Either String [a]
-> StateT (Universe c l d n x a) IO (Maybe s)
withAgents' _ (Left msg) = do
writeToLog $ "Database error: " ++ msg
return Nothing
withAgents' program (Right as) = do
(as', s) <- program as
mapM_ (zoom agentDB . storeOrArchive) as'
return s
runInteractingAgents
:: (Clock c, Logger l, Database d, Agent a, Serialize a, Record a,
a ~ DBRecord d)
=> AgentsProgram c l d n x a s -> SummaryProgram c l d n x a s
-> StateT (Universe c l d n x a) IO ()
runInteractingAgents agentsProgram summaryProgram = do
writeToLog "Beginning of round"
xs <- agentIds
xs' <- liftIO $ evalRandIO $ shuffle xs
writeToLog $ "Lineup: " ++ show xs'
ys <- mapM (withAgents agentsProgram) $ makeViews xs'
summaryProgram $ catMaybes ys
zoom clock incTime
writeToLog "End of round"
makeViews :: [a] -> [[a]]
makeViews as = unfoldr f (0,as)
where f (n,xs) = if n == length xs then Nothing else Just (rotate xs,(n+1,rotate xs))