creatur 4.2.0 → 4.3.2

raw patch · 12 files changed

+195/−68 lines, 12 filesdep ~QuickCheck

Dependency ranges changed: QuickCheck

Files

• creatur.cabal +4/−2
• src/ALife/Creatur/Counter.hs +3/−3
• src/ALife/Creatur/Daemon.hs +1/−1
• src/ALife/Creatur/Genetics/BRGCBool.hs +5/−5
• src/ALife/Creatur/Genetics/BRGCWord8.hs +2/−2
• src/ALife/Creatur/Genetics/Recombination.hs +2/−2
• src/ALife/Creatur/Logger.hs +1/−1
• src/ALife/Creatur/Universe.hs +38/−13
• src/ALife/Creatur/Universe/Task.hs +70/−37
• src/ALife/Creatur/Util.hs +2/−2
• test/ALife/Creatur/CounterQC.hs +65/−0
• test/Main.hs +2/−0

@@ -1,5 +1,5 @@ Name:              creatur-Version:           4.2.0+Version:           4.3.2 Stability:         experimental Synopsis:          Framework for artificial life experiments. Description:       A software framework for automating experiments@@ -82,6 +82,7 @@                     binary ==0.5.* || ==0.7.*,                     cereal ==0.3.* || ==0.4.*,                     creatur,+                    directory ==1.2.*,                     hmatrix ==0.14.* || ==0.15.*,                     HUnit ==1.2.*,                     MonadRandom ==0.1.*,@@ -90,8 +91,9 @@                     test-framework ==0.8.*,                     test-framework-hunit ==0.3.*,                     test-framework-quickcheck2 ==0.3.*,-                    QuickCheck ==2.5.* || ==2.6.*+                    QuickCheck ==2.6.*   Other-modules:    ALife.Creatur.UtilQC+                    ALife.Creatur.CounterQC                     ALife.Creatur.Database.FileSystemQC                     ALife.Creatur.Genetics.CodeQC                     ALife.Creatur.Genetics.DiploidQC,

@@ -18,7 +18,7 @@   ) where  import ALife.Creatur.Clock (Clock, currentTime, incTime)-import ALife.Creatur.Util (modifyLift, getLift)+import ALife.Creatur.Util (modifyLift) import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.State (StateT, get, gets, modify)@@ -43,6 +43,7 @@ instance Counter PersistentCounter where   current = initIfNeeded >> gets cValue   increment = do+    initIfNeeded     modify (\c -> c { cValue=1 + cValue c })     k <- get     liftIO $ store k@@ -53,7 +54,7 @@ initIfNeeded :: StateT PersistentCounter IO () initIfNeeded = do   isInitialised <- gets cInitialised-  unless isInitialised $ modifyLift initialise >> getLift store+  unless isInitialised $ modifyLift initialise  initialise :: PersistentCounter -> IO PersistentCounter initialise counter = do@@ -67,7 +68,6 @@         Right c  -> return $ counter { cInitialised=True, cValue=c }     else do       let k = counter { cInitialised=True, cValue=0 }-      store k       return k  instance Clock PersistentCounter where

@@ -74,7 +74,7 @@  daemonMainLoop :: Daemon s -> s -> IO () daemonMainLoop d s = do-  threadDelay . sleepTime $ d+  threadDelay $ sleepTime d   timeToStop <- readMVar termReceived   if timeToStop      then onShutdown d s

@@ -104,7 +104,7 @@   default get :: (Generic g, GGenetic (Rep g)) => Reader (Either [String] g)   get = do     a <- gget-    return . fmap to $ a+    return $ fmap to a    getWithDefault :: g -> Reader g   getWithDefault d = fmap (fromEither d) get@@ -147,7 +147,7 @@   gput (K1 x) = put x   gget = do     a <- get-    return . fmap K1 $ a+    return $ fmap K1 a  -- -- Instances@@ -171,7 +171,7 @@   put = putRawBoolArray . intToBools 8 . ord   get = do     bs <- getRawBoolArray 8-    return . fmap chr . fmap boolsToInt $ bs+    return . fmap chr $ fmap boolsToInt bs  instance Genetic Word8 where   put = putRawBoolArray . intToBools 8 . integralToGray@@ -201,11 +201,11 @@ getRawBoolArray :: Int -> Reader (Either [String] [Bool]) getRawBoolArray n = do   xs <- replicateM n get-  return . sequence $ xs+  return $ sequence xs  intToBools :: (Integral a, Show a) => Int -> a -> [Bool] intToBools nBits x =-  map (\b -> b == '1') . tail . showIntAtBase 2 intToDigit x' $ ""+  map (\b -> b == '1') . tail $ showIntAtBase 2 intToDigit x' ""   where x' = 2^nBits + fromIntegral x :: Int  boolsToInt :: Integral a => [Bool] -> a

@@ -106,7 +106,7 @@   default get :: (Generic g, GGenetic (Rep g)) => Reader (Either [String] g)   get = do     a <- gget-    return . fmap to $ a+    return $ fmap to a    getWithDefault :: g -> Reader g   getWithDefault d = fmap (fromEither d) get@@ -151,7 +151,7 @@   gput (K1 x) = put x   gget = do     a <- get-    return . fmap K1 $ a+    return $ fmap K1 a  -- -- Instances

@@ -143,8 +143,8 @@ randomOneOfPair pair = do   chooseFst <- weightedRandomBoolean 0.5   if chooseFst -    then return . fst $ pair-    else return . snd $ pair+    then return $ fst pair+    else return $ snd pair  randomOneOfList :: (RandomGen g) => [a] -> Rand g a randomOneOfList xs = do

@@ -91,5 +91,5 @@ rotateLog :: SimpleRotatingLogger -> IO () rotateLog logger = do   let f = logFilename logger-  renameFile f $ f ++ '.' : (show . recordCount $ logger)+  renameFile f $ f ++ '.' : (show $ recordCount logger) 

@@ -44,14 +44,18 @@ import ALife.Creatur.Database.FileSystem (FSDatabase, mkFSDatabase) import ALife.Creatur.Logger (Logger, SimpleRotatingLogger,    mkSimpleRotatingLogger, writeToLog)-import Control.Lens (makeLenses, zoom)+import ALife.Creatur.Util (modifyLift)+import Control.Lens (makeLenses, zoom, view, set) import Control.Monad (unless)-import Control.Monad.State (StateT)+import Control.Monad.State (StateT, gets) 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,@@ -61,14 +65,27 @@  makeLenses ''Universe +initIfNeeded :: StateT (Universe c l d n x a) IO ()+initIfNeeded = do+  isInitialised <- gets (view initialised)+  unless isInitialised $ modifyLift initialise++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+ 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  instance Clock c => Clock (Universe c l d n x a) where-  currentTime = zoom clock currentTime-  incTime = zoom clock incTime+  currentTime = initIfNeeded >> zoom clock currentTime+  incTime = initIfNeeded >> zoom clock incTime  -- instance (Database d, DBRecord d ~ DBRecord (Universe c l d n x a)) => --     Database (Universe c l d n x a) where@@ -81,23 +98,27 @@ --   delete = zoom agentDB . delete  instance AgentNamer n => AgentNamer (Universe c l d n x a) where-  genName = zoom namer N.genName+  genName = initIfNeeded >> zoom namer N.genName  agentIds :: Database d => StateT (Universe c l d n x a) IO [String]-agentIds = zoom agentDB keys+agentIds = initIfNeeded >> zoom agentDB keys  archivedAgentIds :: Database d => StateT (Universe c l d n x a) IO [String]-archivedAgentIds = zoom agentDB archivedKeys+archivedAgentIds = initIfNeeded >> zoom agentDB archivedKeys  getAgent   :: (Serialize a, Database d, a ~ DBRecord d)     => String -> StateT (Universe c l d n x a) IO (Either String a)-getAgent = zoom agentDB . lookup+getAgent name = do+  initIfNeeded+  zoom agentDB $ lookup name  getAgentFromArchive   :: (Serialize a, Database d, a ~ DBRecord d)     => String -> StateT (Universe c l d n x a) IO (Either String a)-getAgentFromArchive = zoom agentDB . lookupInArchive+getAgentFromArchive name = do+  initIfNeeded+  zoom agentDB $ lookupInArchive name  multiLookup :: (Serialize a, Database d, Record a, a ~ DBRecord d) =>    [AgentId] -> StateT d IO (Either String [DBRecord d])@@ -106,7 +127,7 @@   let (msgs, agents) = partitionEithers results   if null msgs     then return $ Right agents-    else return . Left . show $ msgs+    else return . Left $ show msgs  storeOrArchive ::    (Serialize a, Database d, Record a, Agent a, a ~ DBRecord d) =>@@ -117,18 +138,22 @@  addAgent :: (Serialize a, Database d, Record a, a ~ DBRecord d) =>      DBRecord d -> StateT (Universe c l d n x a) IO ()-addAgent = zoom agentDB . store+addAgent a = do+  initIfNeeded+  zoom agentDB $ store a  archiveAgent :: (Serialize a, Database d, Record a, a ~ DBRecord d) =>      DBRecord d -> StateT (Universe c l d n x a) IO ()-archiveAgent = zoom agentDB . delete . D.key+archiveAgent a = do+  initIfNeeded+  zoom agentDB . delete $ D.key a  type SimpleUniverse a =    Universe PersistentCounter SimpleRotatingLogger (FSDatabase a)     SimpleAgentNamer () a  mkSimpleUniverse :: String -> FilePath -> Int -> SimpleUniverse a-mkSimpleUniverse name dir rotateCount = Universe c l d n ()+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")

@@ -20,6 +20,8 @@  (     AgentProgram,     AgentsProgram,+    SummaryProgram,+    noSummary,     withAgent,     withAgents,     runNoninteractingAgents,@@ -45,6 +47,7 @@ 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 => Daemon u@@ -71,36 +74,54 @@  -- | 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).---   (The universe will then be updated with these changes.)-type AgentProgram c l d n x a = a -> StateT (Universe c l d n x a) IO a+--   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 -> AgentId -> -    StateT (Universe c l d n x a) IO ()+  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 -> AgentId -> Either String a -> -    StateT (Universe c l d n x a) IO ()-withAgent' _ name (Left msg) = +  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-withAgent' program _ (Right a) = -  program a >>= zoom agentDB . storeOrArchive+  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 -> StateT (Universe c l d n x a) IO ()-runNoninteractingAgents agentProgram = do+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-  -- TODO Write out current list so we can pick up where we left off????-  --      (when (currentTime logger `mod` 1000 == 0) $ logStats universe logger)-  mapM_ (withAgent agentProgram) 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.@@ -114,36 +135,48 @@ --   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.---   (The universe will then be updated with these changes.)+--   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 = -  [a] -> StateT (Universe c l d n x a) IO [a]+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 -> [AgentId] ->-    StateT (Universe c l d n x a) IO ()+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 -> Either String [a] ->-      StateT (Universe c l d n x a) IO ()-withAgents' _ (Left msg) = +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-withAgents' program (Right as) = -  program as >>= mapM_ (zoom agentDB . storeOrArchive)+  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 -> StateT (Universe c l d n x a) IO ()-runInteractingAgents agentsProgram = do+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-  mapM_ (withAgents agentsProgram) $ makeViews 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)

@@ -179,8 +179,8 @@ fromEither     :: a -> Either e a -> a fromEither d x = case x of {Left _ -> d; Right v  -> v} --- | The 'catEithers' function takes a list of 'Either's and returns---   a list of all the 'Right' values. +-- | Takes a list of 'Either's and returns a list of all the 'Right'+--   values.  catEithers              :: [Either e a] -> [a] catEithers ls = [x | Right x <- ls] 

@@ -0,0 +1,65 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.CounterQC+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------+{-# LANGUAGE DeriveGeneric #-}++module ALife.Creatur.CounterQC+  (+    test+  ) where++import ALife.Creatur.Counter+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)++tryCounter :: FilePath -> IO ()+tryCounter dir = do+  let filename = dir ++ "/counter"+  let k = mkPersistentCounter filename+  (initialCount, k2) <- runStateT current k+  assertEqual "test1" initialCount 0+  fileExists <- doesFileExist filename+  assertBool "file created too early" (not fileExists)++  k3 <- execStateT increment k2+  nextCount <- evalStateT current k3+  assertEqual "test2" 1 nextCount++  -- Re-read the counter. Was it updated properly?+  let k4 = mkPersistentCounter filename+  oldCount <- evalStateT current k4+  assertEqual "test3" 1 oldCount++  k5 <- execStateT increment k4+  nextCount2 <- evalStateT current k5+  assertEqual "test4" 2 nextCount2++  -- Re-read the counter. Was it updated properly?+  let k6 = mkPersistentCounter filename+  oldCount2 <- evalStateT current k6+  assertEqual "test5" 2 oldCount2++testCounter :: IO ()+testCounter = withSystemTempDirectory "creaturTest.tmp" tryCounter++test :: TF.Test+test = testGroup "HUnit ALife.Creatur.CounterQC"+  [+    testCase "counter"+      testCounter+  ]++

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