creatur 5.5.1 → 5.6.0
raw patch · 9 files changed
+309/−160 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- ALife.Creatur.Checklist: data PersistentChecklist
- ALife.Creatur.Checklist: instance Eq PersistentChecklist
- ALife.Creatur.Checklist: instance Show PersistentChecklist
- ALife.Creatur.Counter: data PersistentCounter
- ALife.Creatur.Counter: instance Eq PersistentCounter
- ALife.Creatur.Counter: instance Show PersistentCounter
- ALife.Creatur.Task: noSummary :: SummaryProgram u
- ALife.Creatur.Universe: refresh :: Universe u => StateT u IO ()
+ ALife.Creatur.Checklist: notStarted :: Checklist t => StateT t IO Bool
+ ALife.Creatur.Checklist: type PersistentChecklist = Persistent Status
+ ALife.Creatur.Counter: type PersistentCounter = Persistent Int
+ ALife.Creatur.EnergyPool: available :: EnergyPool e => StateT e IO Double
+ ALife.Creatur.EnergyPool: class EnergyPool e
+ ALife.Creatur.EnergyPool: instance EnergyPool PersistentEnergyPool
+ ALife.Creatur.EnergyPool: mkPersistentEnergyPool :: FilePath -> PersistentEnergyPool
+ ALife.Creatur.EnergyPool: replenish :: EnergyPool e => Double -> StateT e IO ()
+ ALife.Creatur.EnergyPool: type PersistentEnergyPool = Persistent Double
+ ALife.Creatur.EnergyPool: withdraw :: EnergyPool e => Double -> StateT e IO Double
+ ALife.Creatur.Persistent: data Persistent a
+ ALife.Creatur.Persistent: getPS :: Read a => StateT (Persistent a) IO a
+ ALife.Creatur.Persistent: instance Eq a => Eq (Persistent a)
+ ALife.Creatur.Persistent: instance Show a => Show (Persistent a)
+ ALife.Creatur.Persistent: mkPersistent :: a -> FilePath -> Persistent a
+ ALife.Creatur.Persistent: putPS :: (Show a, Read a) => a -> StateT (Persistent a) IO ()
+ ALife.Creatur.Task: nothing :: StateT u IO ()
+ ALife.Creatur.Universe: energyPool :: Universe u => u -> EnergyPool u
+ ALife.Creatur.Universe: refreshLineup :: Universe u => StateT u IO ()
+ ALife.Creatur.Universe: replenishEnergyPool :: Universe u => Double -> StateT u IO ()
+ ALife.Creatur.Universe: setEnergyPool :: Universe u => u -> EnergyPool u -> u
+ ALife.Creatur.Universe: startOfRound :: Universe u => StateT u IO Bool
+ ALife.Creatur.Universe: withdrawEnergy :: Universe u => Double -> StateT u IO Double
- ALife.Creatur.Task: runInteractingAgents :: (Universe u, Serialize (Agent u)) => AgentsProgram u -> (Int, Int) -> SummaryProgram u -> StateT u IO Bool
+ ALife.Creatur.Task: runInteractingAgents :: (Universe u, Serialize (Agent u)) => AgentsProgram u -> (Int, Int) -> StateT u IO () -> StateT u IO () -> StateT u IO Bool
- ALife.Creatur.Task: runNoninteractingAgents :: (Universe u, Serialize (Agent u)) => AgentProgram u -> SummaryProgram u -> StateT u IO Bool
+ ALife.Creatur.Task: runNoninteractingAgents :: (Universe u, Serialize (Agent u)) => AgentProgram u -> (Int, Int) -> StateT u IO () -> StateT u IO () -> StateT u IO Bool
- ALife.Creatur.Universe: class (Clock (Clock u), Logger (Logger u), Database (AgentDB u), Namer (Namer u), Checklist (Checklist u), Agent (Agent u), Record (Agent u), Agent u ~ DBRecord (AgentDB u)) => Universe u where type family Agent u type family Clock u type family Logger u type family AgentDB u type family Namer u type family Checklist u
+ ALife.Creatur.Universe: class (Clock (Clock u), Logger (Logger u), Database (AgentDB u), Namer (Namer u), Checklist (Checklist u), EnergyPool (EnergyPool u), Agent (Agent u), Record (Agent u), Agent u ~ DBRecord (AgentDB u)) => Universe u where type family Agent u type family Clock u type family Logger u type family AgentDB u type family Namer u type family Checklist u type family EnergyPool u
Files
- creatur.cabal +5/−2
- src/ALife/Creatur/Checklist.hs +15/−59
- src/ALife/Creatur/Counter.hs +8/−52
- src/ALife/Creatur/EnergyPool.hs +42/−0
- src/ALife/Creatur/Persistent.hs +81/−0
- src/ALife/Creatur/Task.hs +36/−34
- src/ALife/Creatur/Universe.hs +56/−11
- test/ALife/Creatur/PersistentQC.hs +61/−0
- test/TestAll.hs +5/−2
creatur.cabal view
@@ -1,5 +1,5 @@ Name: creatur-Version: 5.5.1+Version: 5.6.0 Stability: experimental Synopsis: Framework for artificial life experiments. Description: A software framework for automating experiments@@ -36,7 +36,7 @@ source-repository this type: git location: https://github.com/mhwombat/creatur.git- tag: 5.5.1+ tag: 5.6.0 library GHC-Options: -Wall -fno-warn-orphans@@ -51,6 +51,7 @@ ALife.Creatur.Database.CachedFileSystem, ALife.Creatur.Database.CachedFileSystemInternal, ALife.Creatur.Database.FileSystem,+ ALife.Creatur.EnergyPool, ALife.Creatur.Genetics.Analysis, ALife.Creatur.Genetics.BRGCBool, ALife.Creatur.Genetics.BRGCWord8,@@ -63,6 +64,7 @@ ALife.Creatur.Logger.SimpleLogger, ALife.Creatur.Logger.SimpleRotatingLogger, ALife.Creatur.Namer,+ ALife.Creatur.Persistent, ALife.Creatur.Universe, ALife.Creatur.Task, ALife.Creatur.Util@@ -120,6 +122,7 @@ ALife.Creatur.Genetics.BRGCWord8QC ALife.Creatur.Genetics.BRGCWord16QC ALife.Creatur.Genetics.RecombinationQC+ ALife.Creatur.PersistentQC -- Benchmark creatur-bench -- Type: exitcode-stdio-1.0
src/ALife/Creatur/Checklist.hs view
@@ -10,6 +10,7 @@ -- A simple task list which persists between runs. -- ------------------------------------------------------------------------+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module ALife.Creatur.Checklist ( Checklist(..),@@ -17,81 +18,36 @@ 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 ALife.Creatur.Persistent (Persistent, mkPersistent, getPS, putPS)+import Control.Monad (when)+import Control.Monad.State (StateT) 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 ()+ notStarted :: StateT t IO Bool 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, Eq)+type PersistentChecklist = Persistent Status -- | Creates a counter that will store its value in the specified file. mkPersistentChecklist :: FilePath -> PersistentChecklist-mkPersistentChecklist f = PersistentChecklist False ([],[]) f+mkPersistentChecklist = mkPersistent ([],[]) instance Checklist PersistentChecklist where- status = initIfNeeded >> gets tStatus+ status = getPS markDone x = do- t <- get- let (ys,zs) = tStatus t+ (ys,zs) <- getPS 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'+ putPS (L.delete x ys, zs ++ [x])+ notStarted = fmap (null . snd) getPS+ done = fmap (null . fst) getPS+ setItems ts = putPS (ts,[]) 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)+ (xs,ys) <- getPS+ putPS (L.delete tOld xs, L.delete tOld ys)
src/ALife/Creatur/Counter.hs view
@@ -10,6 +10,7 @@ -- A simple counter which persists between runs. -- ------------------------------------------------------------------------+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module ALife.Creatur.Counter ( Counter(..),@@ -18,70 +19,25 @@ ) where import ALife.Creatur.Clock (Clock, currentTime, incTime)-import ALife.Creatur.Util (modifyLift)-import Control.Monad (unless)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State (StateT, get, gets, modify)-import System.Directory (doesFileExist, createDirectoryIfMissing)-import System.FilePath (dropFileName)-import System.IO (hGetContents, withFile, Handle, IOMode(ReadMode))-import Text.Read (readEither)+import ALife.Creatur.Persistent (Persistent, mkPersistent, getPS, putPS)+import Control.Monad.State (StateT) class Counter c where current :: StateT c IO Int increment :: StateT c IO () -data PersistentCounter = PersistentCounter {- cInitialised :: Bool,- cValue :: Int,- cFilename :: FilePath- } deriving (Show, Eq)+type PersistentCounter = Persistent Int -- | Creates a counter that will store its value in the specified file. mkPersistentCounter :: FilePath -> PersistentCounter-mkPersistentCounter = PersistentCounter False (-1)+mkPersistentCounter = mkPersistent 0 instance Counter PersistentCounter where- current = initIfNeeded >> gets cValue+ current = getPS increment = do- initIfNeeded- modify (\c -> c { cValue=1 + cValue c })- k <- get- liftIO $ store k--store :: PersistentCounter -> IO ()-store counter = do- let f = cFilename counter- createDirectoryIfMissing True $ dropFileName f- writeFile f $ show (cValue counter)- -initIfNeeded :: StateT PersistentCounter IO ()-initIfNeeded = do- isInitialised <- gets cInitialised- unless isInitialised $ modifyLift initialise--initialise :: PersistentCounter -> IO PersistentCounter-initialise counter = do- let f = cFilename counter- fExists <- doesFileExist f- if fExists- then do- x <- withFile f ReadMode readCounter -- closes file ASAP- case x of- Left msg -> error $ "Unable to read counter from " ++ f ++ ": " ++ msg- Right c -> return $ counter { cInitialised=True, cValue=c }- else do- let k = counter { cInitialised=True, cValue=0 }- return k+ k <- getPS+ putPS (k+1) instance Clock PersistentCounter where currentTime = current incTime = increment--readCounter :: Handle -> IO (Either String Int)-readCounter h = do- s <- hGetContents h- let x = readEither s- case x of- Left msg -> return $ Left (msg ++ "\"" ++ s ++ "\"")- Right c -> return $ Right c
+ src/ALife/Creatur/EnergyPool.hs view
@@ -0,0 +1,42 @@+------------------------------------------------------------------------+-- |+-- Module : ALife.Creatur.EnergyPool+-- Copyright : (c) Amy de Buitléir 2012-2013+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- An exhaustible resource which persists between runs.+--+------------------------------------------------------------------------+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module ALife.Creatur.EnergyPool+ (+ EnergyPool(..),+ PersistentEnergyPool,+ mkPersistentEnergyPool+ ) where++import ALife.Creatur.Persistent (Persistent, mkPersistent, getPS, putPS)+import Control.Monad.State (StateT)++class EnergyPool e where+ replenish :: Double -> StateT e IO ()+ withdraw :: Double -> StateT e IO Double+ available :: StateT e IO Double++type PersistentEnergyPool = Persistent Double++-- | Creates a resource that will store its value in the specified file.+mkPersistentEnergyPool :: FilePath -> PersistentEnergyPool+mkPersistentEnergyPool = mkPersistent 0++instance EnergyPool PersistentEnergyPool where+ replenish = putPS+ withdraw xWanted = do+ xTotal <- getPS+ let x = min xWanted xTotal+ putPS (xTotal - x)+ return x+ available = getPS
+ src/ALife/Creatur/Persistent.hs view
@@ -0,0 +1,81 @@+------------------------------------------------------------------------+-- |+-- Module : ALife.Creatur.Persistent+-- Copyright : (c) Amy de Buitléir 2012-2013+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- A state which persists between runs.+--+------------------------------------------------------------------------+module ALife.Creatur.Persistent+ (+ Persistent,+ mkPersistent,+ getPS,+ putPS+ ) where++import ALife.Creatur.Util (modifyLift)+import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State (StateT, get, gets, modify)+import System.Directory (doesFileExist, createDirectoryIfMissing)+import System.FilePath (dropFileName)+import System.IO (hGetContents, withFile, Handle, IOMode(ReadMode))+import Text.Read (readEither)++data Persistent a = Persistent {+ psInitialised :: Bool,+ psValue :: a,+ psDefaultValue :: a,+ psFilename :: FilePath+ } deriving (Show, Eq)++-- | Creates a counter that will store its value in the specified file.+mkPersistent :: a -> FilePath -> Persistent a+mkPersistent s = Persistent False s s++getPS :: Read a => StateT (Persistent a) IO a+getPS = initIfNeeded >> gets psValue++putPS :: (Show a, Read a) => a -> StateT (Persistent a) IO ()+putPS s = do+ initIfNeeded+ modify (\p -> p { psValue=s })+ p' <- get+ liftIO $ store p'++store :: Show a => Persistent a -> IO ()+store p = do+ let f = psFilename p+ createDirectoryIfMissing True $ dropFileName f+ writeFile f $ show (psValue p)++initIfNeeded :: Read a => StateT (Persistent a) IO ()+initIfNeeded = do+ isInitialised <- gets psInitialised+ unless isInitialised $ modifyLift initialise++initialise :: Read a => Persistent a -> IO (Persistent a)+initialise p = do+ let f = psFilename p+ fExists <- doesFileExist f+ if fExists+ then do+ x <- withFile f ReadMode readValue -- closes file ASAP+ case x of+ Left msg -> error $ "Unable to read value from " ++ f ++ ": " ++ msg+ Right c -> return $ p { psInitialised=True, psValue=c }+ else do+ return $ p { psInitialised=True, psValue=psDefaultValue p }++readValue :: Read a => Handle -> IO (Either String a)+readValue h = do+ s <- hGetContents h+ let x = readEither s+ case x of+ Left msg -> return $ Left (msg ++ "\"" ++ s ++ "\"")+ Right c -> return $ Right c
src/ALife/Creatur/Task.hs view
@@ -28,13 +28,13 @@ startupHandler, shutdownHandler, exceptionHandler,- noSummary+ nothing ) where import ALife.Creatur.Daemon (Daemon(..)) import ALife.Creatur.Universe (Universe, Agent, AgentProgram,- AgentsProgram, writeToLog, lineup, refresh, markDone, endOfRound,- withAgent, withAgents, incTime)+ AgentsProgram, writeToLog, lineup, refreshLineup, markDone, endOfRound,+ withAgent, withAgents, incTime, popSize) import Control.Conditional (whenM) import Control.Exception (SomeException) import Control.Monad.State (StateT, execStateT)@@ -66,9 +66,11 @@ runNoninteractingAgents :: (Universe u, Serialize (Agent u))- => AgentProgram u -> SummaryProgram u -> StateT u IO Bool-runNoninteractingAgents agentProgram summaryProgram = do- atEndOfRound summaryProgram+ => AgentProgram u -> (Int, Int) -> StateT u IO () -> StateT u IO ()+ -> StateT u IO Bool+runNoninteractingAgents agentProgram popRange startRoundProgram+ endRoundProgram = do+ atStartOfRound startRoundProgram as <- lineup if null as then return False@@ -77,7 +79,8 @@ markDone a -- do that first in case the next line triggers an exception withAgent agentProgram a- return True+ atEndOfRound endRoundProgram+ popSizeInBounds popRange -- 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@@ -90,49 +93,48 @@ runInteractingAgents :: (Universe u, Serialize (Agent u))- => AgentsProgram u -> (Int, Int) -> SummaryProgram u -> StateT u IO Bool-runInteractingAgents agentsProgram (minAgents, maxAgents) summaryProgram = do- atEndOfRound summaryProgram+ => AgentsProgram u -> (Int, Int) -> StateT u IO () -> StateT u IO ()+ -> StateT u IO Bool+runInteractingAgents agentsProgram popRange startRoundProgram+ endRoundProgram = do+ atStartOfRound startRoundProgram as <- lineup- let n = length as- writeToLog $ "Pop. size=" ++ show n+ markDone (head as)+ -- do that first in case the next line triggers an exception+ withAgents agentsProgram as+ atEndOfRound endRoundProgram+ popSizeInBounds popRange++popSizeInBounds :: Universe u => (Int, Int) -> StateT u IO Bool+popSizeInBounds (minAgents, maxAgents) = do+ n <- popSize if n < minAgents then do- writeToLog "Population too small"- summaryProgram writeToLog "Requesting shutdown (population too small)" return False else if n > maxAgents then do- writeToLog "Population too big"- summaryProgram writeToLog "Requesting shutdown (population too big)" return False- else do- markDone (head as)- -- do that first in case the next line triggers an exception- withAgents agentsProgram as- return True+ else return True -atEndOfRound- :: Universe u - => SummaryProgram u -> StateT u IO ()-atEndOfRound summaryProgram = do+atStartOfRound :: Universe u => StateT u IO () -> StateT u IO ()+atStartOfRound program = do whenM endOfRound $ do- writeToLog "End of round"- summaryProgram- refresh+ refreshLineup incTime writeToLog "Beginning of round"+ program --- | 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 ()+atEndOfRound :: Universe u => StateT u IO () -> StateT u IO ()+atEndOfRound program = do+ whenM endOfRound $ do+ writeToLog "End of round"+ program -noSummary :: SummaryProgram u-noSummary = return ()+nothing :: StateT u IO ()+nothing = 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
src/ALife/Creatur/Universe.hs view
@@ -43,9 +43,12 @@ isNew, -- exported for testing only -- * Agent rotation lineup,+ startOfRound, endOfRound,- refresh,- markDone+ refreshLineup,+ markDone,+ replenishEnergyPool,+ withdrawEnergy ) where import Prelude hiding (lookup)@@ -60,6 +63,7 @@ import qualified ALife.Creatur.Database.CachedFileSystem as CFS import qualified ALife.Creatur.Logger as L import qualified ALife.Creatur.Logger.SimpleLogger as SL+import qualified ALife.Creatur.EnergyPool as E import ALife.Creatur.Util (stateMap, shuffle) import Control.Monad.IO.Class (liftIO) import Control.Monad.Random (evalRandIO)@@ -70,7 +74,7 @@ -- | A habitat containing artificial life. class (C.Clock (Clock u), L.Logger (Logger u), D.Database (AgentDB u), N.Namer (Namer u), CL.Checklist (Checklist u),- A.Agent (Agent u), D.Record (Agent u),+ E.EnergyPool (EnergyPool u), A.Agent (Agent u), D.Record (Agent u), Agent u ~ D.DBRecord (AgentDB u)) => Universe u where type Agent u@@ -89,6 +93,9 @@ type Checklist u checklist :: u -> Checklist u setChecklist :: u -> Checklist u -> u+ type EnergyPool u+ energyPool :: u -> EnergyPool u+ setEnergyPool :: u -> EnergyPool u -> u withClock :: (Universe u, Monad m) => StateT (Clock u) m a -> StateT u m a withClock program = do@@ -123,6 +130,13 @@ u <- get stateMap (setChecklist u) checklist program +withEnergyPool+ :: (Universe u, Monad m)+ => StateT (EnergyPool u) m a -> StateT u m a+withEnergyPool program = do+ u <- get+ stateMap (setEnergyPool u) energyPool program+ -- | The current "time" (counter) in this universe currentTime :: Universe u => StateT u IO A.Time currentTime = withClock C.currentTime@@ -243,22 +257,27 @@ program as >>= mapM_ store -- | Returns the current lineup of (living) agents in the universe.--- Note: Check for @'endOfRound'@ and call @'refresh'@ if needed+-- Note: Check for @'endOfRound'@ and call @'refreshLineup'@ 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 no agents have yet their turn at the CPU for this+-- round.+startOfRound :: Universe u => StateT u IO Bool+startOfRound = withChecklist CL.notStarted+ -- | Returns true if the lineup is empty or if all of the agents in the--- lineup have had their turn at the CPU.+-- lineup have had their turn at the CPU for this round. 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+refreshLineup :: Universe u => StateT u IO ()+refreshLineup = do as <- shuffledAgentIds withChecklist (CL.setItems as) @@ -271,13 +290,30 @@ shuffledAgentIds = agentIds >>= liftIO . evalRandIO . shuffle +-- | Replenish the energy pool+replenishEnergyPool :: Universe u => Double -> StateT u IO ()+replenishEnergyPool e = do+ withEnergyPool (E.replenish e)+ y <- withEnergyPool E.available+ writeToLog $ "Replenished energy pool, " ++ show y ++ " available"++-- | Withdraw energy from the pool+withdrawEnergy :: Universe u => Double -> StateT u IO Double+withdrawEnergy e = do+ x <- withEnergyPool (E.withdraw e)+ y <- withEnergyPool E.available+ writeToLog $ "Withdrew " ++ show x ++ " from energy pool, "+ ++ show y ++ " available"+ return x+ data SimpleUniverse a = SimpleUniverse { suClock :: K.PersistentCounter, suLogger :: SL.SimpleLogger, suDB :: FS.FSDatabase a, suNamer :: N.SimpleNamer,- suChecklist :: CL.PersistentChecklist+ suChecklist :: CL.PersistentChecklist,+ suEnergyPool :: E.PersistentEnergyPool } deriving (Show, Eq) instance (A.Agent a, D.Record a) => Universe (SimpleUniverse a) where@@ -297,15 +333,19 @@ type Checklist (SimpleUniverse a) = CL.PersistentChecklist checklist = suChecklist setChecklist u cl = u { suChecklist=cl }+ type EnergyPool (SimpleUniverse a) = E.PersistentEnergyPool+ energyPool = suEnergyPool+ setEnergyPool u cl = u { suEnergyPool=cl } mkSimpleUniverse :: String -> FilePath -> SimpleUniverse a mkSimpleUniverse name dir- = SimpleUniverse c l d n cl+ = SimpleUniverse c l d n cl e where c = K.mkPersistentCounter (dir ++ "/clock") l = SL.mkSimpleLogger (dir ++ "/log/" ++ name ++ ".log") d = FS.mkFSDatabase (dir ++ "/db") n = N.mkSimpleNamer (name ++ "_") (dir ++ "/namer") cl = CL.mkPersistentChecklist (dir ++ "/todo")+ e = E.mkPersistentEnergyPool (dir ++ "/energy") data CachedUniverse a = CachedUniverse {@@ -313,7 +353,8 @@ cuLogger :: SL.SimpleLogger, cuDB :: CFS.CachedFSDatabase a, cuNamer :: N.SimpleNamer,- cuChecklist :: CL.PersistentChecklist+ cuChecklist :: CL.PersistentChecklist,+ cuEnergyPool :: E.PersistentEnergyPool } deriving (Show, Eq) instance (A.Agent a, D.SizedRecord a) => Universe (CachedUniverse a) where@@ -333,12 +374,16 @@ type Checklist (CachedUniverse a) = CL.PersistentChecklist checklist = cuChecklist setChecklist u cl = u { cuChecklist=cl }+ type EnergyPool (CachedUniverse a) = E.PersistentEnergyPool+ energyPool = cuEnergyPool+ setEnergyPool u cl = u { cuEnergyPool=cl } mkCachedUniverse :: String -> FilePath -> Int -> CachedUniverse a mkCachedUniverse name dir cacheSize- = CachedUniverse c l d n cl+ = CachedUniverse c l d n cl e where c = K.mkPersistentCounter (dir ++ "/clock") l = SL.mkSimpleLogger (dir ++ "/log/" ++ name ++ ".log") d = CFS.mkCachedFSDatabase (dir ++ "/db") cacheSize n = N.mkSimpleNamer (name ++ "_") (dir ++ "/namer") cl = CL.mkPersistentChecklist (dir ++ "/todo")+ e = E.mkPersistentEnergyPool (dir ++ "/energy")
+ test/ALife/Creatur/PersistentQC.hs view
@@ -0,0 +1,61 @@+------------------------------------------------------------------------+-- |+-- Module : ALife.Creatur.PersistentQC+-- Copyright : (c) Amy de Buitléir 2012-2014+-- License : BSD-style+-- Maintainer : amy@nualeargais.ie+-- Stability : experimental+-- Portability : portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------+{-# LANGUAGE DeriveGeneric #-}++module ALife.Creatur.PersistentQC+ (+ test+ ) where++import ALife.Creatur.Persistent+import Control.Monad.State (execStateT, evalStateT, runStateT)+import System.IO.Temp (withSystemTempDirectory)+import Test.Framework as TF (Test, testGroup)+import Test.HUnit as TH (assertEqual, assertBool)+import Test.Framework.Providers.HUnit (testCase)+import System.Directory (doesFileExist, doesDirectoryExist)+import System.FilePath (dropFileName)++tryPersistent :: FilePath -> IO ()+tryPersistent dir = do+ let filename = dir ++ "/wombat/counter"+ let defaultValue = 'z'+ let k = mkPersistent defaultValue filename+ (v0, k2) <- runStateT getPS k+ assertEqual "test1" defaultValue v0+ dirExists <- doesDirectoryExist $ dropFileName filename+ assertBool "directory created too early" (not dirExists)+ fileExists <- doesFileExist filename+ assertBool "file created too early" (not fileExists)++ let v1 = 'a'+ k3 <- execStateT (putPS v1) k2+ v1a <- evalStateT getPS k3+ assertEqual "test2" v1a v1++ -- Re-read the counter. Was it updated properly?+ let k4 = mkPersistent defaultValue filename+ v1b <- evalStateT getPS k4+ assertEqual "test3" v1b v1++testPersistent :: IO ()+testPersistent = withSystemTempDirectory "creaturTest.tmp" tryPersistent++test :: TF.Test+test = testGroup "HUnit ALife.Creatur.PersistentQC"+ [+ testCase "persistent"+ testPersistent+ ]++
test/TestAll.hs view
@@ -17,18 +17,21 @@ import ALife.Creatur.UniverseQC (test) import ALife.Creatur.Database.FileSystemQC (test) import ALife.Creatur.Database.CachedFileSystemQC (test)-import ALife.Creatur.UtilQC (test) import ALife.Creatur.Genetics.DiploidQC (test) import ALife.Creatur.Genetics.RecombinationQC (test) import ALife.Creatur.Genetics.BRGCBoolQC (test) import ALife.Creatur.Genetics.BRGCWord8QC (test) import ALife.Creatur.Genetics.BRGCWord16QC (test)+import ALife.Creatur.PersistentQC (test)+import ALife.Creatur.UtilQC (test) import Test.Framework as TF (defaultMain, Test) tests :: [TF.Test] tests = - [ + [+ -- Tests are in order of increasing complexity+ ALife.Creatur.PersistentQC.test, ALife.Creatur.CounterQC.test, ALife.Creatur.ChecklistQC.test, ALife.Creatur.UniverseQC.test,