diff --git a/creatur.cabal b/creatur.cabal --- a/creatur.cabal +++ b/creatur.cabal @@ -1,5 +1,5 @@ Name: creatur -Version: 5.9.1 +Version: 5.9.2 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.9.1 + tag: 5.9.2 library GHC-Options: -Wall -fno-warn-orphans @@ -110,16 +110,21 @@ test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, QuickCheck ==2.7.* - Other-modules: ALife.Creatur.UtilQC + Other-modules: ALife.Creatur.ChecklistQC ALife.Creatur.CounterQC ALife.Creatur.Database.CachedFileSystemQC ALife.Creatur.Database.FileSystemQC - ALife.Creatur.Genetics.DiploidQC, + ALife.Creatur.Genetics.BRGCBoolBench ALife.Creatur.Genetics.BRGCBoolQC - ALife.Creatur.Genetics.BRGCWord8QC ALife.Creatur.Genetics.BRGCWord16QC + ALife.Creatur.Genetics.BRGCWord8Bench + ALife.Creatur.Genetics.BRGCWord8QC + ALife.Creatur.Genetics.DiploidQC, ALife.Creatur.Genetics.RecombinationQC ALife.Creatur.PersistentQC + ALife.Creatur.UniverseQC + ALife.Creatur.UtilQC + -- Benchmark creatur-bench -- Type: exitcode-stdio-1.0 diff --git a/test/ALife/Creatur/ChecklistQC.hs b/test/ALife/Creatur/ChecklistQC.hs new file mode 100644 --- /dev/null +++ b/test/ALife/Creatur/ChecklistQC.hs @@ -0,0 +1,78 @@ +------------------------------------------------------------------------ +-- | +-- Module : ALife.Creatur.ChecklistQC +-- Copyright : (c) Amy de Buitléir 2013-2015 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- QuickCheck tests. +-- +------------------------------------------------------------------------ +{-# LANGUAGE DeriveGeneric #-} + +module ALife.Creatur.ChecklistQC + ( + test + ) where + +import qualified ALife.Creatur as A +import ALife.Creatur.Database (Record, key) +import ALife.Creatur.Checklist +import Control.Monad.State (execStateT, evalStateT) +import Data.Serialize (Serialize) +import GHC.Generics (Generic) +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) + +data TestAgent = TestAgent { aAgentId :: String, aIsAlive :: Bool } + deriving (Eq, Show, Generic) + +instance Serialize TestAgent + +instance A.Agent TestAgent where + agentId = aAgentId + isAlive = aIsAlive + +instance Record TestAgent where + key = aAgentId + +testChecklist :: IO () +testChecklist = withSystemTempDirectory "creaturTest.tmp" testChecklist' + +testChecklist' :: FilePath -> IO () +testChecklist' dir = do + let filename = dir ++ "/checklist" + let c = mkPersistentChecklist filename + c1 <- execStateT (setItems ["taskA", "taskB", "taskC"]) c + s1 <- evalStateT status c1 + assertEqual "test1" (["taskA", "taskB", "taskC"],[]) s1 + + c2 <- execStateT (markDone "taskB") c1 + s2 <- evalStateT status c2 + assertEqual "test2" (["taskA", "taskC"],["taskB"]) s2 + + c3 <- execStateT (delete "taskA") c2 + s3 <- evalStateT status c3 + assertEqual "test3" (["taskC"],["taskB"]) s3 + + c4 <- execStateT (markDone "taskA") c3 + s4 <- evalStateT status c4 + assertEqual "test4" (["taskC"],["taskB"]) s4 + + c5 <- execStateT (markDone "taskC") c4 + s5 <- evalStateT status c5 + assertEqual "test5" ([],["taskB", "taskC"]) s5 + d5 <- evalStateT done c5 + assertBool "test5a" d5 + +test :: TF.Test +test = testGroup "HUnit ALife.Creatur.ChecklistQC" + [ + testCase "testChecklist" testChecklist + ] + + diff --git a/test/ALife/Creatur/Genetics/BRGCBoolBench.hs b/test/ALife/Creatur/Genetics/BRGCBoolBench.hs new file mode 100644 --- /dev/null +++ b/test/ALife/Creatur/Genetics/BRGCBoolBench.hs @@ -0,0 +1,57 @@ +------------------------------------------------------------------------ +-- | +-- Module : ALife.Creatur.Genetics.BRGCBoolBench +-- Copyright : (c) Amy de Buitléir 2014-2015 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- Benchmarks. +-- +------------------------------------------------------------------------ +{-# LANGUAGE DeriveGeneric, FlexibleInstances #-} +module ALife.Creatur.Genetics.BRGCBoolBench + ( + benchmark + ) where + +import Prelude hiding (read) +import ALife.Creatur.Genetics.BRGCBool +import Data.Word (Word8) +import Criterion.Main (Benchmark, Pure, nf, bgroup, bench) + +word8 :: Word8 +word8 = 0 + +word8Encoded :: [Bool] +word8Encoded = write word8 + +putWord8Benchmark :: Pure +putWord8Benchmark = nf write word8 + +getWord8Benchmark :: Pure +getWord8Benchmark = nf (read :: Sequence -> Either [String] Word8) word8Encoded + +word8s :: [Word8] +word8s = [0..255] + +word8sEncoded :: [Bool] +word8sEncoded = write word8s + +putWord8sBenchmark :: Pure +putWord8sBenchmark = nf write word8s + +getWord8sBenchmark :: Pure +getWord8sBenchmark = nf (read :: Sequence -> Either [String] [Word8]) word8sEncoded + +benchmark :: Benchmark +benchmark = bgroup "ALife.Creatur.Genetics.BRGCBoolBench" + [ + bench "put Word8" putWord8Benchmark, + bench "get Word8" getWord8Benchmark, + bench "put [Word8]" putWord8sBenchmark, + bench "get [Word8]" getWord8sBenchmark + ] + + diff --git a/test/ALife/Creatur/Genetics/BRGCWord8Bench.hs b/test/ALife/Creatur/Genetics/BRGCWord8Bench.hs new file mode 100644 --- /dev/null +++ b/test/ALife/Creatur/Genetics/BRGCWord8Bench.hs @@ -0,0 +1,65 @@ +------------------------------------------------------------------------ +-- | +-- Module : ALife.Creatur.Genetics.BRGCWord8Bench +-- Copyright : (c) Amy de Buitléir 2014-2015 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- Benchmarks. +-- +------------------------------------------------------------------------ +{-# LANGUAGE DeriveGeneric, FlexibleInstances #-} +module ALife.Creatur.Genetics.BRGCWord8Bench + ( + benchmark + ) where + +import Prelude hiding (read) +import ALife.Creatur.Genetics.BRGCWord8 +import Data.Word (Word8) +import Criterion.Main (Benchmark, Pure, nf, bgroup, bench) + +word8 :: Word8 +word8 = 0 + +word8Encoded :: [Word8] +word8Encoded = write word8 + +putWord8Benchmark :: Pure +putWord8Benchmark = nf write word8 + +getWord8Benchmark :: Pure +getWord8Benchmark = nf (read :: Sequence -> Either [String] Word8) word8Encoded + +word8s :: [Word8] +word8s = concatMap (replicate 10) [0..255] + +word8sEncoded :: [Word8] +word8sEncoded = write word8s + +putWord8sBenchmark :: Pure +putWord8sBenchmark = nf write word8s + +getWord8sBenchmark :: Pure +getWord8sBenchmark = nf (read :: Sequence -> Either [String] [Word8]) word8sEncoded + +-- putRawWord8sBenchmark :: Pure +-- putRawWord8sBenchmark = nf (runWriter putRawWord8s) word8s + +-- getRawWord8sBenchmark :: Pure +-- getRawWord8sBenchmark = nf (runReader getRawWord8sBenchmark) word8sEncoded + +benchmark :: Benchmark +benchmark = bgroup "ALife.Creatur.Genetics.BRGCWord8Bench" + [ + bench "put Word8" putWord8Benchmark, + bench "get Word8" getWord8Benchmark, + bench "put [Word8]" putWord8sBenchmark, + bench "get [Word8]" getWord8sBenchmark + -- bench "putRaw [Word8]" putRawWord8sBenchmark, + -- bench "getRaw [Word8]" getRawWord8sBenchmark + ] + + diff --git a/test/ALife/Creatur/UniverseQC.hs b/test/ALife/Creatur/UniverseQC.hs new file mode 100644 --- /dev/null +++ b/test/ALife/Creatur/UniverseQC.hs @@ -0,0 +1,122 @@ +------------------------------------------------------------------------ +-- | +-- Module : ALife.Creatur.UniverseQC +-- Copyright : (c) Amy de Buitléir 2012-2015 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- QuickCheck tests. +-- +------------------------------------------------------------------------ +{-# LANGUAGE DeriveGeneric #-} + +module ALife.Creatur.UniverseQC + ( + test + ) where + +import qualified ALife.Creatur as A +import ALife.Creatur.Database (Record, key) +import ALife.Creatur.Universe +import Control.Monad.State (execStateT, evalStateT, runStateT) +import Data.Serialize (Serialize) +import GHC.Generics (Generic) +import System.Directory (doesFileExist, doesDirectoryExist) +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) + +data TestAgent = TestAgent { aAgentId :: String, aIsAlive :: Bool } + deriving (Eq, Show, Generic) + +instance Serialize TestAgent + +instance A.Agent TestAgent where + agentId = aAgentId + isAlive = aIsAlive + +instance Record TestAgent where + key = aAgentId + +testUniverseCreation :: IO () +testUniverseCreation = withSystemTempDirectory "creaturTest.tmp" testUniverseCreation' + +testUniverseCreation' :: FilePath -> IO () +testUniverseCreation' dir = do + let logFileName = dir ++ "/universe" + let u = mkSimpleUniverse "wombat" logFileName :: SimpleUniverse TestAgent + (t, u2) <- runStateT currentTime u + assertEqual "test1" 0 t + dirExists <- doesDirectoryExist logFileName + assertBool "universe created too early" (not dirExists) + + u3 <- execStateT incTime u2 + t2 <- evalStateT currentTime u3 + assertEqual "test2" 1 t2 + + -- Re-read the time. Was it updated properly? + let u4 = mkSimpleUniverse "wombat" logFileName :: SimpleUniverse TestAgent + t3 <- evalStateT currentTime u4 + assertEqual "test3" 1 t3 + + u5 <- execStateT incTime u4 + t4 <- evalStateT currentTime u5 + assertEqual "test4" 2 t4 + + -- Re-read the counter. Was it updated properly? + let u6 = mkSimpleUniverse "wombat" logFileName :: SimpleUniverse TestAgent + t5 <- evalStateT currentTime u6 + assertEqual "test5" 2 t5 + +testUniverseDB :: IO () +testUniverseDB = withSystemTempDirectory "creaturTest.tmp" testUniverseDB' + +testUniverseDB' :: FilePath -> IO () +testUniverseDB' dir = do + let logFileName = dir ++ "/universe" + let u = mkSimpleUniverse "wombat" logFileName :: SimpleUniverse TestAgent + let a = TestAgent "agent_a" True + u2 <- execStateT (store a) u + xs <- evalStateT agentIds u2 + assertBool "agent not in agentIds list" ((A.agentId a) `elem` xs) + let a2 = a { aIsAlive=False } + u3 <- execStateT (store a2) u2 + xs' <- evalStateT agentIds u3 + assertBool "agent still in agentIds list" ((A.agentId a) `notElem` xs') + let f = logFileName ++ "/db/" ++ A.agentId a + fileExists <- doesFileExist f + assertBool "agent file not removed" (not fileExists) + let f2 = logFileName ++ "/db/archive/" ++ A.agentId a + fileExists2 <- doesFileExist f2 + assertBool "agent file not archived" (fileExists2) + +testUniverseLineup :: IO () +testUniverseLineup = withSystemTempDirectory "creaturTest.tmp" testUniverseLineup' + +testUniverseLineup' :: FilePath -> IO () +testUniverseLineup' dir = do + let logFileName = dir ++ "/universe" + let u = mkSimpleUniverse "wombat" logFileName :: SimpleUniverse TestAgent + let a = TestAgent "agent_a" True + let b = TestAgent "agent_b" True + let c = TestAgent "agent_c" True + u2 <- execStateT (store a >> store b >> store c >> refreshLineup) u + xs <- evalStateT lineup u2 + assertBool "agent not in lineup" ((A.agentId a) `elem` xs) + let a2 = a { aIsAlive=False } + u3 <- execStateT (store a2 >> markDone (A.agentId a2)) u2 + xs' <- evalStateT lineup u3 + assertBool "agent still in lineup" ((A.agentId a) `notElem` xs') + +test :: TF.Test +test = testGroup "HUnit ALife.Creatur.UniverseQC" + [ + testCase "testUniverseCreation" testUniverseCreation, + testCase "testUniverseDB" testUniverseDB, + testCase "testUniverseLineup" testUniverseLineup + ] + +