creatur 4.3.3 → 5.0.1

raw patch · 14 files changed

+516/−314 lines, 14 filesdep +conddep +filepath

Dependencies added: cond, filepath

Files

• creatur.cabal +15/−2
• src/ALife/Creatur.hs +5/−5
• src/ALife/Creatur/Checklist.hs +97/−0
• src/ALife/Creatur/Clock.hs +0/−1
• src/ALife/Creatur/Counter.hs +7/−3
• src/ALife/Creatur/Daemon.hs +1/−1
• src/ALife/Creatur/Database.hs +2/−0
• src/ALife/Creatur/Database/FileSystem.hs +9/−3
• src/ALife/Creatur/Genetics/Diploid.hs +1/−2
• src/ALife/Creatur/Task.hs +115/−0
• src/ALife/Creatur/Universe.hs +257/−111
• src/ALife/Creatur/Universe/Task.hs +0/−184
• test/ALife/Creatur/CounterQC.hs +5/−2
• test/Main.hs +2/−0

@@ -1,5 +1,5 @@ Name:              creatur-Version:           4.3.3+Version:           5.0.1 Stability:         experimental Synopsis:          Framework for artificial life experiments. Description:       A software framework for automating experiments@@ -28,11 +28,21 @@ Build-Type:        Simple Cabal-Version:     >=1.8 +source-repository head+  type:     git+  location: https://github.com/mhwombat/creatur.git++source-repository this+  type:     git+  location: https://github.com/mhwombat/creatur.git+  tag:      5.0.1+ library   GHC-Options:      -Wall -fno-warn-orphans   Hs-source-dirs:   src   exposed-modules:  ALife.Creatur,                     ALife.Creatur.AgentNamer,+                    ALife.Creatur.Checklist,                     ALife.Creatur.Clock,                     ALife.Creatur.Counter,                     ALife.Creatur.Daemon,@@ -48,14 +58,16 @@                     ALife.Creatur.Genetics.Reproduction.Sexual,                     ALife.Creatur.Logger,                     ALife.Creatur.Universe,-                    ALife.Creatur.Universe.Task,+                    ALife.Creatur.Task,                     ALife.Creatur.Util   Build-Depends:                         array ==0.4.* || ==0.5.*,                     base ==4.*,                     bytestring ==0.10.*,+                    cond ==0.4.*,                     cereal ==0.3.* || ==0.4.*,                     directory ==1.2.*,+                    filepath ==1.3.*,                     gray-extended ==1.*,                     hdaemonize ==0.4.*,                     hmatrix ==0.14.* || ==0.15.*,@@ -83,6 +95,7 @@                     cereal ==0.3.* || ==0.4.*,                     creatur,                     directory ==1.2.*,+                    filepath ==1.3.*,                     hmatrix ==0.14.* || ==0.15.*,                     HUnit ==1.2.*,                     MonadRandom ==0.1.*,

@@ -10,7 +10,7 @@ -- Definitions used throughout the Créatúr framework. -- -------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts #-}  module ALife.Creatur  (@@ -19,6 +19,8 @@     Time  ) where +import ALife.Creatur.Database (Record, key)+ -- | The internal clock used by Créatúr is a simple counter. type Time = Int @@ -27,11 +29,9 @@  -- | An artificial life species. --   All species used in Créatúr must be an instance of this class.-class Agent a where-+class (Record a) => Agent a where   -- | Returns the agent ID.   agentId :: a -> AgentId-+  agentId = key   -- | Returns True if the agent is alive, false otherwise.   isAlive :: a -> Bool-

@@ -0,0 +1,97 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Checklist+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A simple task list which persists between runs.+--+------------------------------------------------------------------------+module ALife.Creatur.Checklist+  (+    Checklist(..),+    PersistentChecklist,+    mkPersistentChecklist+  ) where++import ALife.Creatur.Util (modifyLift)+import Control.Monad (when, unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State (StateT, get, gets, put)+import qualified Data.List as L+import System.Directory (doesFileExist)+import System.IO (hGetContents, withFile, Handle, IOMode(ReadMode))+import Text.Read (readEither)++type Status = ([String], [String]) -- (toDo, done)++class Checklist t where+  status :: StateT t IO Status+  markDone :: String -> StateT t IO ()+  done :: StateT t IO Bool+  setItems :: [String] -> StateT t IO ()+  delete :: String -> StateT t IO ()++data PersistentChecklist = PersistentChecklist {+    tInitialised :: Bool,+    tStatus :: Status,+    tFilename :: FilePath+  } deriving Show++-- | Creates a counter that will store its value in the specified file.+mkPersistentChecklist :: FilePath -> PersistentChecklist+mkPersistentChecklist f = PersistentChecklist False ([],[]) f++instance Checklist PersistentChecklist where+  status = initIfNeeded >> gets tStatus+  markDone x = do+    t <- get+    let (ys,zs) = tStatus t+    when (x `elem` ys) $ do+      let t' = t { tStatus=(L.delete x ys,zs ++ [x]) }+      put t'+      liftIO $ store t'+  done = gets (null . fst . tStatus)+  setItems ts = do+    t <- get+    let t' = t { tStatus=(ts,[]) }+    put t'+    liftIO $ store t'+  delete tOld = do+    t <- get+    let (xs,ys) = tStatus t+    let t' = t { tStatus=(L.delete tOld xs,L.delete tOld ys) } +    put t'+    liftIO $ store t'++initIfNeeded :: StateT PersistentChecklist IO ()+initIfNeeded = do+  isInitialised <- gets tInitialised+  unless isInitialised $ modifyLift initialise++initialise :: PersistentChecklist -> IO PersistentChecklist+initialise t = do+  let f = tFilename t+  fExists <- doesFileExist f+  if fExists+    then do+      s <- withFile f ReadMode readChecklist -- closes file ASAP+      case s of+        Left msg ->+          error $ "Unable to read checklist from " ++ f ++ ": " ++ msg+        Right s'  -> return $ t { tInitialised=True, tStatus=s' }+    else return $ t { tInitialised=True }++readChecklist :: Handle -> IO (Either String Status)+readChecklist h = do+  x <- hGetContents h+  let s = readEither x+  case s of+    Left msg -> return $ Left (msg ++ "\"" ++ x ++ "\"")+    Right c  -> return $ Right c++store :: PersistentChecklist -> IO ()+store t = writeFile (tFilename t) $ show (tStatus t)

@@ -37,4 +37,3 @@   currentTime :: StateT c IO Time   -- | Advance the clock to the next "tick".   incTime :: StateT c IO ()-

@@ -22,7 +22,8 @@ import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.State (StateT, get, gets, modify)-import System.Directory (doesFileExist)+import System.Directory (doesFileExist, createDirectoryIfMissing)+import System.FilePath (dropFileName) import System.IO (hGetContents, withFile, Handle, IOMode(ReadMode)) import Text.Read (readEither) @@ -49,7 +50,10 @@     liftIO $ store k  store :: PersistentCounter -> IO ()-store counter = writeFile (cFilename counter) $ show (cValue counter)+store counter = do+  let f = cFilename counter+  createDirectoryIfMissing True $ dropFileName f+  writeFile f $ show (cValue counter)    initIfNeeded :: StateT PersistentCounter IO () initIfNeeded = do@@ -77,7 +81,7 @@ readCounter :: Handle -> IO (Either String Int) readCounter h = do   s <- hGetContents h-  let x = readEither s :: Either String Int+  let x = readEither s   case x of     Left msg -> return $ Left (msg ++ "\"" ++ s ++ "\"")     Right c  -> return $ Right c

@@ -87,7 +87,7 @@ wrap t = catch t   (\e -> do      let err = show (e :: SomeException)-     hPutStr stderr ("Warning: " ++ err)+     hPutStr stderr ("Unhandled exception: " ++ err)      return ())  handleTERM :: IO ()

@@ -29,6 +29,8 @@   type DBRecord d   -- | Get a list of all active keys in the database.   keys :: StateT d IO [String]+  -- | Return the number of records stored in the database.+  numRecords :: StateT d IO Int   -- | Get a list of all archived keys in the database. If the database   --   does not implement archiving, it may return an empty list.   archivedKeys :: StateT d IO [String]

@@ -30,7 +30,7 @@ import qualified Data.Serialize as DS    (Serialize, decode, encode) import System.Directory (createDirectoryIfMissing, doesFileExist, -  getDirectoryContents, removeFile)+  getDirectoryContents, renameFile)  -- | A simple database where each record is stored in a separate file,  --   and the name of the file is the record's key.@@ -46,6 +46,8 @@    keys = keysIn mainDir +  numRecords = fmap length keys+     archivedKeys = keysIn archiveDir    lookup k = k `lookupIn` mainDir@@ -58,8 +60,12 @@    delete name = do     initIfNeeded-    fileExists <- liftIO $ doesFileExist name-    when fileExists $ liftIO $ removeFile name+    d1 <-  gets mainDir+    d2 <- gets archiveDir+    let f1 = d1 ++ '/':name+    let f2 = d2 ++ '/':name+    fileExists <- liftIO $ doesFileExist f1+    when fileExists $ liftIO $ renameFile f1 f2  keysIn   :: (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [String]

@@ -11,8 +11,7 @@ -- ------------------------------------------------------------------------ {-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,-    DefaultSignatures, DeriveGeneric, TypeOperators,-    UndecidableInstances #-}+    DefaultSignatures, DeriveGeneric, TypeOperators #-} module ALife.Creatur.Genetics.Diploid   (     Diploid(..),

@@ -0,0 +1,115 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Task+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Provides tasks that you can use with a daemon. These tasks handle+-- reading and writing agents, which reduces the amount of code you+-- need to write. +--+-- It’s also easy to write your own tasks, using these as a guide.)+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}++module ALife.Creatur.Task+ (+    AgentProgram,+    AgentsProgram,+    withAgent,+    withAgents,+    runNoninteractingAgents,+    runInteractingAgents,+    simpleDaemon,+    startupHandler,+    shutdownHandler,+    exceptionHandler,+    noSummary+ ) where++import ALife.Creatur.Daemon (Daemon(..))+import ALife.Creatur.Universe (Universe, Agent, AgentProgram,+  AgentsProgram, writeToLog, lineup, refresh, markDone, endOfRound,+  withAgent, withAgents, incTime)+import Control.Conditional (whenM)+import Control.Exception (SomeException)+import Control.Monad (when)+import Control.Monad.State (StateT, execStateT)+import Data.Serialize (Serialize)++simpleDaemon :: Universe u => Daemon u+simpleDaemon = Daemon+  {+    onStartup = startupHandler,+    onShutdown = shutdownHandler,+    onException = exceptionHandler,+    task = undefined,+    username = "",+    sleepTime = 100+  }++startupHandler :: Universe u => u -> IO u+startupHandler = execStateT (writeToLog $ "Starting")++shutdownHandler :: Universe u => u -> IO ()+shutdownHandler u = do+  _ <- execStateT (writeToLog "Shutdown requested") u+  return ()++exceptionHandler :: Universe u => u -> SomeException -> IO u+exceptionHandler u x = execStateT (writeToLog ("WARNING: " ++ show x)) u++runNoninteractingAgents+  :: (Universe u, Serialize (Agent u))+    => AgentProgram u -> SummaryProgram u -> StateT u IO ()+runNoninteractingAgents agentProgram summaryProgram = do+  atEndOfRound summaryProgram+  (a:_) <- lineup+  withAgent agentProgram a+  markDone a++--   The input parameter is a list of agents. The first agent in the+--   list is the agent whose turn it is to use the CPU. The rest of+--   the list contains agents it could interact with. For example, if+--   agents reproduce sexually, the program might check if the first+--   agent in the list is female, and the second one is male, and if so,+--   mate them to produce offspring. The input list is generated in a+--   way that guarantees that every possible sequence of agents has an+--   equal chance of occurring.++runInteractingAgents+  :: (Universe u, Serialize (Agent u))+    => AgentsProgram u -> SummaryProgram u -> StateT u IO ()+runInteractingAgents agentsProgram summaryProgram = do+  atEndOfRound summaryProgram+  as <- lineup+  withAgents agentsProgram as+  when (not $ null as) $ markDone (head as)++atEndOfRound+  :: Universe u +    => SummaryProgram u -> StateT u IO ()+atEndOfRound summaryProgram = do+  whenM endOfRound $ do+    writeToLog "End of round"+    summaryProgram+    refresh+    incTime+    writeToLog "Beginning of round"++-- | A program that processes the outputs from all the agent programs.+--   For example, this program might aggregate the statistics and+--   record the result.+type SummaryProgram u = StateT u IO ()++noSummary :: SummaryProgram u+noSummary = return ()++-- Note: There's no reason for the checklist type to be a parameter of+-- the Universe type. Users don't interact directly with it, so they+-- won't have any reason to want to use a different checklist+-- implementation.

@@ -10,153 +10,299 @@ -- Provides a habitat for artificial life. -- -------------------------------------------------------------------------{-# LANGUAGE TemplateHaskell, TypeFamilies, FlexibleContexts,-    UndecidableInstances #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances #-} module ALife.Creatur.Universe- (+  (+    -- * Constructors     Universe(..),     SimpleUniverse,     mkSimpleUniverse,-    agentDB,-    clock,-    logger,-    multiLookup,-    extra,+    -- * Clock+    currentTime,+    incTime,+    -- * Logging+    writeToLog,+    -- * Database     agentIds,-    getAgent,     archivedAgentIds,+    popSize,+    getAgent,     getAgentFromArchive,-    addAgent,-    storeOrArchive,-    archiveAgent+    getAgents,+    -- addAgent,+    store,+    -- * Names+    genName,+    -- * Agent programs+    AgentProgram,+    withAgent,+    AgentsProgram,+    withAgents,+    isNew, -- exported for testing only+    -- * Agent rotation+    lineup,+    endOfRound,+    refresh,+    markDone  ) where  import Prelude hiding (lookup) -import ALife.Creatur (Agent, AgentId, agentId, isAlive)-import ALife.Creatur.AgentNamer (AgentNamer, SimpleAgentNamer, -  mkSimpleAgentNamer)-import qualified ALife.Creatur.AgentNamer as N (genName)-import ALife.Creatur.Clock (Clock, currentTime, incTime)-import ALife.Creatur.Counter (PersistentCounter, mkPersistentCounter)-import ALife.Creatur.Database as D (Database, DBRecord, Record,-  delete, key, keys, archivedKeys, lookup, lookupInArchive, store)-import ALife.Creatur.Database.FileSystem (FSDatabase, mkFSDatabase)-import ALife.Creatur.Logger (Logger, SimpleRotatingLogger, -  mkSimpleRotatingLogger, writeToLog)-import ALife.Creatur.Util (modifyLift)-import Control.Lens (makeLenses, zoom, view, set)-import Control.Monad (unless)-import Control.Monad.State (StateT, gets)+import qualified ALife.Creatur as A+import qualified ALife.Creatur.AgentNamer as N+import qualified ALife.Creatur.Checklist as CL+import qualified ALife.Creatur.Clock as C+import qualified ALife.Creatur.Counter as K+import qualified ALife.Creatur.Database as D+import qualified ALife.Creatur.Database.FileSystem as FS+import qualified ALife.Creatur.Logger as L+import ALife.Creatur.Util (stateMap, shuffle)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Random (evalRandIO)+import Control.Monad.State (StateT, get) import Data.Either (partitionEithers) import Data.Serialize (Serialize)-import System.Directory (doesDirectoryExist, createDirectory)  -- | A habitat containing artificial life.-data Universe c l d n x a = Universe {-    _initialised :: Bool,-    _dirName :: FilePath,-    _clock :: c,-    _logger :: l,-    _agentDB :: d,-    _namer :: n,-    _extra :: x-  }+class (C.Clock (Clock u), L.Logger (Logger u), D.Database (AgentDB u),+  N.AgentNamer (AgentNamer u), CL.Checklist (Checklist u),+  A.Agent (Agent u), D.Record (Agent u),+  Agent u ~ D.DBRecord (AgentDB u))+      => Universe u where+  type Agent u+  type Clock u+  clock :: u -> Clock u+  setClock :: u -> Clock u -> u+  type Logger u+  logger :: u -> Logger u+  setLogger :: u -> Logger u -> u+  type AgentDB u+  agentDB :: u -> AgentDB u+  setAgentDB :: u -> AgentDB u -> u+  type AgentNamer u+  agentNamer :: u -> AgentNamer u+  setAgentNamer :: u -> AgentNamer u -> u+  type Checklist u+  checklist :: u -> Checklist u+  setChecklist :: u -> Checklist u -> u -makeLenses ''Universe+withClock :: (Universe u, Monad m) => StateT (Clock u) m a -> StateT u m a+withClock program = do+  u <- get+  stateMap (setClock u) clock program -initIfNeeded :: StateT (Universe c l d n x a) IO ()-initIfNeeded = do-  isInitialised <- gets (view initialised)-  unless isInitialised $ modifyLift initialise+withLogger+  :: (Universe u, Monad m)+    => StateT (Logger u) m a -> StateT u m a+withLogger program = do+  u <- get+  stateMap (setLogger u) logger program -initialise :: Universe c l d n x a -> IO (Universe c l d n x a)-initialise u = do-  let d = view dirName u-  dExists <- doesDirectoryExist d-  unless dExists (createDirectory d)-  return $ set initialised True u+withAgentDB+  :: (Universe u, Monad m)+    => StateT (AgentDB u) m a -> StateT u m a+withAgentDB program = do+  u <- get+  stateMap (setAgentDB u) agentDB program -instance (Clock c, Logger l) => Logger (Universe c l d n x a) where-  writeToLog msg = do-    initIfNeeded-    t <- currentTime-    zoom logger $ writeToLog $ show t ++ "\t" ++ msg+withAgentNamer+  :: (Universe u, Monad m)+    => StateT (AgentNamer u) m a -> StateT u m a+withAgentNamer program = do+  u <- get+  stateMap (setAgentNamer u) agentNamer program -instance Clock c => Clock (Universe c l d n x a) where-  currentTime = initIfNeeded >> zoom clock currentTime-  incTime = initIfNeeded >> zoom clock incTime+withChecklist+  :: (Universe u, Monad m)+    => StateT (Checklist u) m a -> StateT u m a+withChecklist program = do+  u <- get+  stateMap (setChecklist u) checklist program --- instance (Database d, DBRecord d ~ DBRecord (Universe c l d n x a)) =>---     Database (Universe c l d n x a) where---   type DBRecord (Universe c l d n x a) = a---   keys = zoom agentDB keys---   archivedKeys = zoom agentDB archivedKeys---   lookup = zoom agentDB . lookup---   lookupInArchive = zoom agentDB . lookupInArchive---   store = zoom agentDB . store---   delete = zoom agentDB . delete+-- | The current "time" (counter) in this universe+currentTime :: Universe u => StateT u IO A.Time+currentTime = withClock C.currentTime -instance AgentNamer n => AgentNamer (Universe c l d n x a) where-  genName = initIfNeeded >> zoom namer N.genName+-- | Increment the current "time" (counter) in this universe.+incTime :: Universe u => StateT u IO ()+incTime = withClock C.incTime -agentIds :: Database d => StateT (Universe c l d n x a) IO [String]-agentIds = initIfNeeded >> zoom agentDB keys+-- | Write a message to the log file for this universe.+writeToLog :: Universe u => String -> StateT u IO ()+writeToLog msg = do+  t <- currentTime+  let logMsg = show t ++ "\t" ++ msg+  withLogger $ L.writeToLog logMsg -archivedAgentIds :: Database d => StateT (Universe c l d n x a) IO [String]-archivedAgentIds = initIfNeeded >> zoom agentDB archivedKeys+-- | Generate a unique name for a new agent.+genName :: Universe u => StateT u IO A.AgentId+genName = withAgentNamer N.genName +-- | Returns the list of agents in the population.+agentIds :: Universe u => StateT u IO [A.AgentId]+agentIds = withAgentDB D.keys++-- | Returns the list of (dead) agents in the archive.+archivedAgentIds :: Universe u => StateT u IO [A.AgentId]+archivedAgentIds = withAgentDB D.archivedKeys++-- | Returns the current size of the population.+popSize :: Universe u => StateT u IO Int+popSize = withAgentDB D.numRecords++-- | Fetches the agent with the specified ID from the population.+--   Note: Changes made to this agent will not "take" until+--   @'store'@ is called. getAgent-  :: (Serialize a, Database d, a ~ DBRecord d)-    => String -> StateT (Universe c l d n x a) IO (Either String a)-getAgent name = do-  initIfNeeded-  zoom agentDB $ lookup name+  :: (Universe u, Serialize (Agent u))+    => A.AgentId -> StateT u IO (Either String (Agent u))+getAgent name = withAgentDB (D.lookup name) +-- | Fetches the agent with the specified ID from the archive. getAgentFromArchive-  :: (Serialize a, Database d, a ~ DBRecord d)-    => String -> StateT (Universe c l d n x a) IO (Either String a)-getAgentFromArchive name = do-  initIfNeeded-  zoom agentDB $ lookupInArchive name+  :: (Universe u, Serialize (Agent u))+    => A.AgentId -> StateT u IO (Either String (Agent u))+getAgentFromArchive name = withAgentDB (D.lookupInArchive name) -multiLookup :: (Serialize a, Database d, Record a, a ~ DBRecord d) => -  [AgentId] -> StateT d IO (Either String [DBRecord d])-multiLookup names = do-  results <- mapM D.lookup names-  let (msgs, agents) = partitionEithers results+-- | Fetches the agents with the specified IDs from the population.+getAgents+  :: (Universe u, Serialize (Agent u))+    => [A.AgentId] -> StateT u IO (Either String [Agent u])+getAgents names = do+  selected <- mapM getAgent names+  let (msgs, agents) = partitionEithers selected   if null msgs     then return $ Right agents     else return . Left $ show msgs -storeOrArchive :: -  (Serialize a, Database d, Record a, Agent a, a ~ DBRecord d) =>-    a -> StateT d IO ()-storeOrArchive a = do-  store a -- Even dead agents should be stored (prior to archiving)-  unless (isAlive a) $ (delete . agentId) a+-- | If the agent is alive, adds it to the population (replacing the+--   the previous copy of that agent, if any). If the agent is dead,+--   places it in the archive.+store+  :: (Universe u, Serialize (Agent u))+    => Agent u -> StateT u IO ()+store a = do+  newAgent <- isNew (A.agentId a)+  -- agentList <- agentIds+  -- writeToLog $ "DEBUG agents:" ++ show agentList+  -- writeToLog $ "DEBUG " ++ A.agentId a ++ " new? " ++ show newAgent+  withAgentDB (D.store a) -- Even dead agents should be stored (prior to archiving)+  if A.isAlive a+    then+      if newAgent+         then writeToLog $ A.agentId a ++ " added to population"+         else writeToLog $ A.agentId a ++ " returned to population"+    else do+      withAgentDB (D.delete $ A.agentId a)+      withChecklist $ CL.delete (A.agentId a)+      writeToLog $ (A.agentId a) ++ " archived and removed from lineup" -addAgent :: (Serialize a, Database d, Record a, a ~ DBRecord d) =>-     DBRecord d -> StateT (Universe c l d n x a) IO ()-addAgent a = do-  initIfNeeded-  zoom agentDB $ store a+-- | EXPORTED FOR TESTING ONLY+isNew :: Universe u => A.AgentId -> StateT u IO Bool+isNew name = fmap (name `notElem`) agentIds -archiveAgent :: (Serialize a, Database d, Record a, a ~ DBRecord d) =>-     DBRecord d -> StateT (Universe c l d n x a) IO ()-archiveAgent a = do-  initIfNeeded-  zoom agentDB . delete $ D.key a+-- -- | Adds an agent to the universe.+-- addAgent+--   :: (Universe u, Serialize (Agent u))+--     => Agent u -> StateT u IO ()+-- addAgent a = withAgentDB $ D.store a -type SimpleUniverse a = -  Universe PersistentCounter SimpleRotatingLogger (FSDatabase a)-    SimpleAgentNamer () a+-- | A program involving one agent.+--   The input parameter is the agent.+--   The program must return the agent (which may have been modified).+type AgentProgram u = Agent u -> StateT u IO (Agent u) -mkSimpleUniverse :: String -> FilePath -> Int -> SimpleUniverse a-mkSimpleUniverse name dir rotateCount = Universe False dir c l d n ()-  where c = mkPersistentCounter (dir ++ "/clock")-        l = mkSimpleRotatingLogger (dir ++ "/log/") name rotateCount-        d = mkFSDatabase (dir ++ "/db")-        n = mkSimpleAgentNamer (name ++ "_") (dir ++ "/namer")+-- | Run a program involving one agent+withAgent+  :: (Universe u, Serialize (Agent u))+    => AgentProgram u -> A.AgentId -> StateT u IO ()+withAgent program name = do+  result <- getAgent name+  case result of+    Left msg ->+      writeToLog $ "Unable to read '" ++ name ++ "': " ++ msg+    Right a ->+      program a >>= store +-- | A program involving multiple agents.+--   The input parameter is a list of agents.+--   The program must return a list of agents that have been *modified*.+--   The order of the output list is not important.+type AgentsProgram u = [Agent u] -> StateT u IO [Agent u] +-- Run a program involving multiple agents.+withAgents+  :: (Universe u, Serialize (Agent u))+    => AgentsProgram u -> [A.AgentId] -> StateT u IO ()+withAgents program names = do+  result <- getAgents names+  case result of+    Left msg ->+      writeToLog $ "Unable to read '" ++ show names ++ "': " ++ msg+    Right as ->+      program as >>= mapM_ store++-- | Returns the current lineup of (living) agents in the universe.+--   Note: Check for @'endOfRound'@ and call @'refresh'@ if needed+--   before invoking this function.+lineup :: Universe u => StateT u IO [A.AgentId]+lineup = do+  (xs,ys) <- withChecklist CL.status+  return $ xs ++ ys++-- | Returns true if the lineup is empty or if all of the agents in the+--   lineup have had their turn at the CPU.+endOfRound :: Universe u => StateT u IO Bool+endOfRound = withChecklist CL.done++-- | Creates a fresh lineup containing all of the agents in the+--   population, in random order.+refresh :: Universe u => StateT u IO ()+refresh = do+  as <- shuffledAgentIds+  withChecklist (CL.setItems as)++-- | Mark the current agent done. If it is still alive, it will move+--   to the end of the lineup.+markDone :: Universe u => A.AgentId -> StateT u IO ()+markDone = withChecklist . CL.markDone++shuffledAgentIds :: Universe u => StateT u IO [String]+shuffledAgentIds+  = agentIds >>= liftIO . evalRandIO . shuffle++data SimpleUniverse a = SimpleUniverse+  {+    suClock :: K.PersistentCounter,+    suLogger :: L.SimpleRotatingLogger,+    suDB :: (FS.FSDatabase a),+    suNamer :: N.SimpleAgentNamer,+    suChecklist :: CL.PersistentChecklist+  }++instance (A.Agent a, Serialize a) => Universe (SimpleUniverse a) where+  type Agent (SimpleUniverse a) = a+  type Clock (SimpleUniverse a) = K.PersistentCounter+  clock = suClock+  setClock u c = u { suClock=c }+  type Logger (SimpleUniverse a) = L.SimpleRotatingLogger+  logger = suLogger+  setLogger u l = u { suLogger=l }+  type AgentDB (SimpleUniverse a) = FS.FSDatabase a+  agentDB = suDB+  setAgentDB u d = u { suDB=d }+  type AgentNamer (SimpleUniverse a) = N.SimpleAgentNamer+  agentNamer = suNamer+  setAgentNamer u n = u { suNamer=n }+  type Checklist (SimpleUniverse a) = CL.PersistentChecklist+  checklist = suChecklist+  setChecklist u cl = u { suChecklist=cl }++mkSimpleUniverse :: String -> FilePath -> Int -> SimpleUniverse a+mkSimpleUniverse name dir rotateCount+  = SimpleUniverse c l d n cl+  where c = K.mkPersistentCounter (dir ++ "/clock")+        l = L.mkSimpleRotatingLogger (dir ++ "/log/") name rotateCount+        d = FS.mkFSDatabase (dir ++ "/db")+        n = N.mkSimpleAgentNamer (name ++ "_") (dir ++ "/namer")+        cl = CL.mkPersistentChecklist (dir ++ "/todo")

@@ -1,184 +0,0 @@---------------------------------------------------------------------------- |--- Module      :  ALife.Creatur.Universe.Task--- Copyright   :  (c) Amy de Buitléir 2012-2013--- License     :  BSD-style--- Maintainer  :  amy@nualeargais.ie--- Stability   :  experimental--- Portability :  portable------ Provides tasks that you can use with a daemon. These tasks handle--- reading and writing agents, which reduces the amount of code you--- need to write. ------ It’s also easy to write your own tasks, using these as a guide.)-----------------------------------------------------------------------------{-# LANGUAGE TypeFamilies, FlexibleContexts #-}--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---- | A program for an agent which doesn't interact with other agents.---   The input parameter is the agent whose turn it is to use the CPU.---   The program must return the agent (which may have been modified),---   along with any data (e.g., statistics) to be used by the summary---   program.-type AgentProgram c l d n x a s-  = a -> StateT (Universe c l d n x a) IO (a, Maybe s)---- | A program that processes the outputs from all the agent programs.---   For example, this program might aggregate the statistics and---   record the result.-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"---- | A program which allows an agent to interact with one or more of---   its neighbours.------   The input parameter is a list of agents. The first agent in the---   list is the agent whose turn it is to use the CPU. The rest of---   the list contains agents it could interact with. For example, if---   agents reproduce sexually, the program might check if the first---   agent in the list is female, and the second one is male, and if so,---   mate them to produce offspring. The input list is generated in a---   way that guarantees that every possible sequence of agents has an---   equal chance of occurring.------   The program must return a list of agents that it has modified,---   along with any data (e.g., statistics) to be used by the summary---   program.---   The order of the output list is not important.-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))-

@@ -23,14 +23,17 @@ import Test.Framework as TF (Test, testGroup) import Test.HUnit as TH (assertEqual, assertBool) import Test.Framework.Providers.HUnit (testCase)-import System.Directory (doesFileExist)+import System.Directory (doesFileExist, doesDirectoryExist)+import System.FilePath (dropFileName)  tryCounter :: FilePath -> IO () tryCounter dir = do-  let filename = dir ++ "/counter"+  let filename = dir ++ "/wombat/counter"   let k = mkPersistentCounter filename   (initialCount, k2) <- runStateT current k   assertEqual "test1" initialCount 0+  dirExists <- doesDirectoryExist $ dropFileName filename+  assertBool "directory created too early" (not dirExists)   fileExists <- doesFileExist filename   assertBool "file created too early" (not fileExists) 

@@ -13,6 +13,7 @@ module Main where  import ALife.Creatur.CounterQC (test)+import ALife.Creatur.ChecklistQC (test) import ALife.Creatur.UniverseQC (test) import ALife.Creatur.Database.FileSystemQC (test) import ALife.Creatur.UtilQC (test)@@ -28,6 +29,7 @@ tests =    [      ALife.Creatur.CounterQC.test,+    ALife.Creatur.ChecklistQC.test,     ALife.Creatur.UniverseQC.test,     ALife.Creatur.Database.FileSystemQC.test,     ALife.Creatur.UtilQC.test,