creatur (empty) → 2.0.10

raw patch · 25 files changed

+1827/−0 lines, 25 filesdep +HUnitdep +MonadRandomdep +QuickChecksetup-changed

Dependencies added: HUnit, MonadRandom, QuickCheck, array, base, base-unicode-symbols, binary, bytestring, cereal, creatur, directory, ghc-prim, gray-extended, hdaemonize, hmatrix, lens, mtl, old-locale, process, random, split, temporary, test-framework, test-framework-hunit, test-framework-quickcheck2, time, transformers, unix, zlib

Files

• LICENSE +27/−0
• Setup.hs +2/−0
• creatur.cabal +98/−0
• src/ALife/Creatur.hs +37/−0
• src/ALife/Creatur/AgentNamer.hs +53/−0
• src/ALife/Creatur/Clock.hs +41/−0
• src/ALife/Creatur/Counter.hs +73/−0
• src/ALife/Creatur/Daemon.hs +89/−0
• src/ALife/Creatur/Database.hs +42/−0
• src/ALife/Creatur/Database/FileSystem.hs +98/−0
• src/ALife/Creatur/Genetics/Code.hs +31/−0
• src/ALife/Creatur/Genetics/CodeInternal.hs +92/−0
• src/ALife/Creatur/Genetics/Gene.hs +47/−0
• src/ALife/Creatur/Genetics/Recombination.hs +174/−0
• src/ALife/Creatur/Genetics/Reproduction/Asexual.hs +58/−0
• src/ALife/Creatur/Genetics/Reproduction/Sexual.hs +58/−0
• src/ALife/Creatur/Logger.hs +102/−0
• src/ALife/Creatur/Universe.hs +105/−0
• src/ALife/Creatur/Universe/Task.hs +149/−0
• src/ALife/Creatur/Util.hs +170/−0
• test/ALife/Creatur/Database/FileSystemQC.hs +45/−0
• test/ALife/Creatur/Genetics/CodeQC.hs +85/−0
• test/ALife/Creatur/Genetics/CrossoverQC.hs +32/−0
• test/ALife/Creatur/UtilQC.hs +98/−0
• test/Main.hs +21/−0

@@ -0,0 +1,27 @@+Copyright (c) 2010-2012, Amy de Buitléir+All rights reserved.++Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met:++* Redistributions of source code must retain the above copyright +  notice, this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.+* Neither the name of the author nor the names of other contributors+  may be used to endorse or promote products derived from this software+  without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,98 @@+Name:              creatur+Version:           2.0.10+Stability:         experimental+Synopsis:          Framework for artificial life experiments.+Description:       A software framework for automating experiments+                   with artificial life. It provides a daemon which+                   maintains its own "clock", schedules events, +                   provides logging, and ensures that each agent gets +                   its turn to use the CPU. You can use other +                   applications on the computer at the same time+                   without fear of interfering with experiments; they+                   will run normally, just more slowly. See the +                   tutorial at +                   <https://github.com/mhwombat/creatur-examples/raw/master/Tutorial.pdf>+                   for examples on how to use the+                   Créatúr framework.+                   .+                   About the name: \"Créatúr\" (pronounced kray-toor)+                   is an irish word meaning animal, creature, or an +                   unfortunate person.+Category:          AI+License:           BSD3+License-file:      LICENSE+Copyright:         (c) Amy de Buitléir 2010-2012+Author:            Amy de Buitléir+Maintainer:        amy@nualeargais.ie+Build-Type:        Simple+Cabal-Version:     >=1.8++library+  GHC-Options:      -Wall+  Hs-source-dirs:   src+  exposed-modules:  ALife.Creatur,+                    ALife.Creatur.AgentNamer,+                    ALife.Creatur.Clock,+                    ALife.Creatur.Counter,+                    ALife.Creatur.Daemon,+                    ALife.Creatur.Database,+                    ALife.Creatur.Database.FileSystem,+                    ALife.Creatur.Genetics.Code,+                    ALife.Creatur.Genetics.CodeInternal,+                    ALife.Creatur.Genetics.Gene,+                    ALife.Creatur.Genetics.Recombination,+                    ALife.Creatur.Genetics.Reproduction.Asexual,+                    ALife.Creatur.Genetics.Reproduction.Sexual,+                    ALife.Creatur.Logger,+                    ALife.Creatur.Universe,+                    ALife.Creatur.Universe.Task,+                    ALife.Creatur.Util+  Build-Depends:    +                    array ==0.4.*,+                    base ==4.*,+                    base-unicode-symbols ==0.2.*,+                    bytestring ==0.9.*,+                    cereal ==0.3.*,+                    directory ==1.2.*,+                    gray-extended ==1.*,+                    hdaemonize ==0.4.*,+                    hmatrix ==0.14.*,+                    lens ==3.7.*,+                    MonadRandom ==0.1.*,+                    mtl ==2.1.*,+                    old-locale ==1.0.*,+                    process ==1.1.*,+                    random ==1.0.*,+                    split ==0.2.1.*,+                    time ==1.4.*,+                    transformers ==0.3.*,+                    unix ==2.6.*,+                    zlib ==0.5.*++Test-suite creatur-tests+  Type:             exitcode-stdio-1.0+  Main-is:          Main.hs+  GHC-Options:      -Wall+  Hs-source-dirs:   test+  Build-Depends:    +                    array ==0.4.*,+                    base ==4.*,+                    base-unicode-symbols ==0.2.*,+                    binary == 0.5.*,+                    cereal ==0.3.*,+                    creatur,+                    ghc-prim ==0.2.*,+                    hmatrix ==0.14.*,+                    HUnit ==1.2.*,+                    MonadRandom ==0.1.*,+                    mtl ==2.1.*,+                    temporary ==1.1.*,+                    test-framework ==0.6.*,+                    test-framework-hunit ==0.3.*,+                    test-framework-quickcheck2 ==0.2.*,+                    QuickCheck >= 2.5+  Other-modules:    ALife.Creatur.UtilQC+                    ALife.Creatur.Database.FileSystemQC+                    ALife.Creatur.Genetics.CodeQC+                    ALife.Creatur.Genetics.CrossoverQC+

@@ -0,0 +1,37 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Definitions use throughout the Créatúr framework.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}++module ALife.Creatur+ (+    Agent(..),+    AgentId,+    Time+ ) where++-- | The internal clock used by Créatúr is a simple counter.+type Time = Int++-- | A unique ID associated with an agent.+type AgentId = String++-- | An artificial life species.+--   All species used in Créatúr must be an instance of this class.+class Agent a where++  -- | Returns the agent ID.+  agentId ∷ a → AgentId++  -- | Returns True if the agent is alive, false otherwise.+  isAlive ∷ a → Bool+

@@ -0,0 +1,53 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Tools.AgentNamer+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Assigns a unique ID upon request. IDs generated by an @AgentNamer@ +-- are guaranteed to be unique within a given universe, across all +-- simulation runs.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax #-}+module ALife.Creatur.AgentNamer+  (+    AgentNamer(..),+    SimpleAgentNamer,+    mkSimpleAgentNamer+  ) where++import ALife.Creatur (AgentId)+import ALife.Creatur.Counter (PersistentCounter, current, increment,+  mkPersistentCounter)+import ALife.Creatur.Util (stateMap)+import Control.Monad.State (StateT, get, gets)++class AgentNamer n where+  -- | Assign a unique ID using the supplied prefix.+  genName ∷ StateT n IO AgentId++data SimpleAgentNamer = SimpleAgentNamer +  {+    prefix ∷ String,+    counter ∷ PersistentCounter+  }++mkSimpleAgentNamer ∷ String → FilePath → SimpleAgentNamer+mkSimpleAgentNamer s f = SimpleAgentNamer s $ mkPersistentCounter f++withCounter ∷ StateT PersistentCounter IO x → StateT SimpleAgentNamer IO x+withCounter runProgram = do+  u ← get+  stateMap (\c → u {counter=c}) counter runProgram++instance AgentNamer SimpleAgentNamer where+  genName = do+    p ← gets prefix+    k ← withCounter (increment >> current)+    return $ p ++ show k++

@@ -0,0 +1,41 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Tools.Logger+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- An internal simulation clock which persists between runs. This is a+-- simple counter, completely independent from any system clock or+-- hardware clock. The clock does not automatically advance, it only+-- advances when @'incTime'@ is called. In this way, the Créatúr +-- framework will run consistently, treating all agents fairly,+-- regardless of current processor load. It also ensures that data+-- obtained from simulation runs on different machines with different+-- CPU performance can still be meaningfully compared.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax #-}+module ALife.Creatur.Clock+  (+    Clock(..)+  ) where++import ALife.Creatur (Time)+import Control.Monad.State (StateT)++-- | A clock representing the time in a Créatúr universe.+--   It is used to schedule events and ensure that each agent gets its+--   fair share of the CPU.+--   This clock is entirely separate from the system clock.+--   It advances only when @'incTime'@ is called.+--   This allows Créatúr to run without being affected by other+--   processes which might be using the CPU at the same time.+class Clock c where+  -- | The current time, measured in "ticks"+  currentTime ∷ StateT c IO Time+  -- | Advance the clock to the next "tick".+  incTime ∷ StateT c IO ()+

@@ -0,0 +1,73 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Tools.Logger+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A simple counter which persists between runs.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax #-}+module ALife.Creatur.Counter+  (+    Counter(..),+    PersistentCounter,+    mkPersistentCounter+  ) where++import ALife.Creatur.Clock (Clock, currentTime, incTime)+import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State (StateT, get, gets, modify, put)+import System.Directory (doesFileExist)++class Counter c where+  current ∷ StateT c IO Int+  increment ∷ StateT c IO ()++data PersistentCounter = PersistentCounter {+    initialised ∷ Bool,+    time ∷ Int,+    filename ∷ FilePath+  } deriving Show++-- | Creates a counter that will store its value in the specified file.+mkPersistentCounter ∷ FilePath → PersistentCounter+mkPersistentCounter = PersistentCounter False (-1)++instance Counter PersistentCounter where+  current = do+    initIfNeeded+    gets time+  increment = do+    t ← current+    let t' = t + 1+    f ← gets filename+    modify (\c → c { time=t' })+    liftIO $ writeFile f $ show t'++initIfNeeded ∷ StateT PersistentCounter IO ()+initIfNeeded = do+  isInitialised ← gets initialised+  unless isInitialised $ do+    counter ← get+    counter' ← liftIO $ initialise counter+    put counter'++initialise ∷ PersistentCounter → IO PersistentCounter+initialise counter = do+  let f = filename counter+  fExists ← doesFileExist f+  if fExists+    then do+      s ← readFile f+      return $ counter { initialised=True, time=read s }+    else return $ counter { initialised=True, time=0 }++instance Clock PersistentCounter where+  currentTime = current+  incTime = increment+

@@ -0,0 +1,89 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Daemon+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Provides a UNIX daemon to run an experiment using the Créatúr+-- framework.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}++module ALife.Creatur.Daemon+  (+    Daemon(..),+    launch+  ) where++import Control.Concurrent (MVar, newMVar, readMVar, swapMVar, +  threadDelay)+import Control.Exception (SomeException, handle)+import Control.Monad.State (StateT, execStateT)+import Data.Eq.Unicode ((≠))+import System.IO.Unsafe (unsafePerformIO)+import System.Posix.Daemonize (CreateDaemon(..), serviced, simpleDaemon)+import System.Posix.Signals (Handler(Catch), fullSignalSet, +  installHandler, sigTERM)+import System.Posix.User (getLoginName, getRealUserID)++termReceived ∷ MVar Bool+termReceived = unsafePerformIO (newMVar False)++-- | Daemon configuration.+--   If @username@ ≡ "", the daemon will run under the login name.+data Daemon s = Daemon+  {+    onStartup ∷ s → IO s,+    onShutdown ∷ s → IO (),+    onException ∷ s → SomeException → IO s,+    task ∷ StateT s IO (),+    username ∷ String,+    sleepTime ∷ Int+  }++-- | @'launch' username sleepTime state task@ creates a daemon+--   running as @username@, which invokes @task@ repeatedly, sleeping +--   for @sleepTime@ microseconds between invocations of @task@.+launch ∷ Daemon s → s → IO ()+launch d s = do+  uid ← getRealUserID+  if uid ≠ 0+    then putStrLn "Must run as root"+    else do+      u ← daemonUsername d+      serviced $ simpleDaemon +        { program = daemonMain d s,+          user    = Just u }++daemonUsername ∷ Daemon s → IO String+daemonUsername d =+  if (null . username) d+    then getLoginName+    else (return . username) d+    +daemonMain ∷ Daemon s → s → () → IO ()+daemonMain d s _ = do+  s' ← onStartup d s+  _ ← installHandler sigTERM (Catch handleTERM) (Just fullSignalSet)+  _ ← daemonMainLoop d s'+  return ()++daemonMainLoop ∷ Daemon s → s → IO ()+daemonMainLoop d s = do+  threadDelay . sleepTime $ d+  timeToStop ← readMVar termReceived+  if timeToStop +    then onShutdown d s+    else do+      s' ← handle ((onException d) s) $ execStateT (task d) s+      daemonMainLoop d s'++handleTERM ∷ IO ()+handleTERM = do+  _ ← swapMVar termReceived True+  return ()+

@@ -0,0 +1,42 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Database+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Database interface for the Créatúr framework.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}++module ALife.Creatur.Database+ (+    Database(..),+    Record(..)+ ) where++import Control.Monad.State (StateT)+import Data.Serialize (Serialize)++class Record r where+  key ∷ r → String+  +-- | A database offering storage and retrieval for records.+class Database d where+  type DBRecord d+  -- | Get a list of all keys in the database.+  keys ∷ StateT d IO [String]+  -- | Read a record from the database.+  lookup ∷ Serialize (DBRecord d) ⇒ +    String → StateT d IO (Either String (DBRecord d))+  -- | Write a record to the database. +  --   If an agent with the same name already exists, it will be overwritten.+  store ∷ (Record (DBRecord d), Serialize (DBRecord d)) ⇒ +    DBRecord d → StateT d IO ()+  -- | Remove a record from the database.+  --   The database may archive records rather than simply deleting them.+  delete ∷ Serialize (DBRecord d) ⇒ String → StateT d IO ()+

@@ -0,0 +1,98 @@+{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}++-- | Represents r FSDatabase (including agents, clock, logging facility,+--   etc.) that can run within the Créatúr framework.+module ALife.Creatur.Database.FileSystem+  (+    FSDatabase,+    mkFSDatabase+  ) where++import ALife.Creatur.Database (Database(..), DBRecord, Record, +  delete, key, keys, store)+import Prelude hiding (readFile, writeFile)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State (StateT, get, gets, put)+import Data.ByteString as BS (readFile, writeFile)+import qualified Data.Serialize as DS +  (Serialize, decode, encode)+import System.Directory (createDirectoryIfMissing, doesFileExist, +  getDirectoryContents, removeFile)++-- | A simple database where each record is stored in a separate file, and+--   the name of the file is the record's key.+data FSDatabase r = FSDatabase+  {+    initialised ∷ Bool,+    mainDir ∷ FilePath,+    archiveDir ∷ FilePath+  } deriving Show++instance Database (FSDatabase r) where+  type DBRecord (FSDatabase r) = r++  keys = do+    initIfNeeded+    d ← gets mainDir+    files ← liftIO $ getDirectoryContents d+    return $ filter isRecordFileName files++  lookup k = do+    initIfNeeded+    d ← gets mainDir+    let f = d ++ '/':k+    liftIO $ readRecord3 f++  store r = do+    initIfNeeded+    writeRecord2 mainDir r++  delete name = do+    initIfNeeded+    fileExists ← liftIO $ doesFileExist name+    when fileExists $ liftIO $ removeFile name++-- | @'mkFSDatabase' d@ (re)creates the FSDatabase in the+--   directory @d@.+mkFSDatabase ∷ FilePath → FSDatabase r+mkFSDatabase d = FSDatabase False d (d ++ "/archive")++initIfNeeded ∷ StateT (FSDatabase r) IO ()+initIfNeeded = do+  isInitialised ← gets initialised+  unless isInitialised $ do+    u ← get+    u' ← liftIO $ initialise u+    put u'++initialise ∷ FSDatabase r → IO (FSDatabase r)+initialise u = do+  createDirectoryIfMissing True (mainDir u)+  createDirectoryIfMissing True (archiveDir u)+  return u { initialised=True }++-- | Read a record from a file.+readRecord3 ∷ DS.Serialize r ⇒ FilePath → IO (Either String r)+readRecord3 f = do+  x ← readFile f+  return $ DS.decode x++-- | Write a record to a file.+writeRecord3 ∷ (Record r, DS.Serialize r) ⇒ FilePath → r → IO ()+writeRecord3 f a = do+  let x = DS.encode a+  writeFile f x++writeRecord2 ∷ (Record r, DS.Serialize r) ⇒ +  (FSDatabase r → FilePath) → r → StateT (FSDatabase r) IO ()+writeRecord2 dirGetter r = do+  d ← gets dirGetter+  let f = d ++ '/':key r+  liftIO $ writeRecord3 f r+  -- liftIO $ agentId r ++ " archived to " ++ show f     ++isRecordFileName ∷ String → Bool+isRecordFileName s =+  s `notElem` [ "archive", ".", ".." ]+

@@ -0,0 +1,31 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.Code+-- Copyright   :  (c) Amy de Buitléir 2011-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Encoding schemes for genes.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax #-}++module ALife.Creatur.Genetics.Code+  (+    -- * Coding schemes+    Code,+    mkGrayCode,+    -- * Encoding and decoding+    encode,+    encodeNext,+    decode,+    decodeNext,+    -- * Miscellaneous+    asBits+  ) where++import ALife.Creatur.Genetics.CodeInternal (Code, mkGrayCode, encode, +  encodeNext, decode, decodeNext, asBits)+

@@ -0,0 +1,92 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.Code+-- Copyright   :  (c) Amy de Buitléir 2011-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Encoding schemes for genes.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax #-}++module ALife.Creatur.Genetics.CodeInternal where++import ALife.Creatur.Util (ilogBase, isPowerOf, reverseLookup)+import Codec.Gray (grayCodes)+import Prelude hiding (cycle)++-- | An encoding scheme.+data Code a b = Code { cSize ∷ Int, cTable ∷ [(a,[b])] } deriving Show++-- | Encodes a value as a sequence of bits.+encode ∷ Eq a ⇒ Code a b → a → Maybe [b]+encode = flip lookup . cTable++---- | Given a list of encoding schemes paired with genes, encode all of the+----   genes. Unencodable genes will be skipped.+--encodeAll ∷ Eq a ⇒ [(Code a, a)] → [b]+--encodeAll ps = foldr encodeNext [] ps++encodeNext ∷ Eq a ⇒ (Code a b, a) → [b] → [b]+encodeNext (c, a) bs = maybe bs (bs ++) (encode c a)++-- | Returns the value corresponding to a sequence of bits.+decode ∷ Eq b ⇒ Code a b → [b] → Maybe a+decode = flip reverseLookup . cTable++--decodeAll _ [] = []+--decodeAll bs (c:cs) = g:gs'+--  where g = decode c bs1+--        (bs1, bs2) = splitAt (cSize c) bs+--        gs' = decodeAll bs2 cs++decodeNext ∷ Eq b ⇒ Code a b → [b] → (Maybe a, [b])+decodeNext c bs = (decode c bs1, bs2)+  where (bs1, bs2) = splitAt (cSize c) bs++-- | Convert a list of bits to a string of @0@s and @1@s.+asBits ∷ [Bool] → String+asBits = map (\b → if b then '1' else '0')++-- | Constructs a Gray code for the specified values, using the minimum number+--   of bits required to encode all of the values.+--+--   If the number of values provided is not a perfect square, some codes will+--   not be used; calling @decode@ with those values will return @Nothing@.+--   You can find out if this will be the case by calling @'excessGrayCodes'@.+--   For example @mkGrayCode [\'a\',\'b\',\'c\']@ would assign the code+--   @00@ to @'a'@, @01@ to @'b'@, and @11@ to @'c'@, leaving @10@ unassigned.+--   To avoid having unassigned codes, you can repeat a value in the input +--   list so the example above could be modified to  +--   @mkGrayCode [\'a\',\'a\',\'b\',\'c\']@, which would assign the codes+--   @00@ and @01@ to 'a', @11@ to @'b'@, and @10@ to @'c'@.+--+--   A Gray code maps values to codes in a way that guarantees that the codes+--   for two consecutive values will differ by only one bit. This feature+--   can be useful in evolutionary programming because the genes resulting +--   from a crossover operation will be similar to the inputs. This helps to+--   ensure that offspring are similar to their parents, as any radical+--   changes from one generation to the next are the result of mutation+--   alone.+mkGrayCode ∷ [a] → Code a Bool+mkGrayCode xs = Code k (zip xs cs)+  where n = grayCodeLength $ length xs+        k = (length . head) cs+        cs = grayCodes n++-- | @'grayCodeLength' n@ returns the number of bits required to encode @n@+--   values.+grayCodeLength ∷ Int → Int+grayCodeLength n = if n `isPowerOf` 2 then k else k + 1+  where k = ilogBase (2 ∷ Int) n++-- | @'grayCodeCapacity' n@ returns the number of values that can be encoded+--   using @n@ bits. The number of values that can be encoded in n bits is +--   2^n.+grayCodeCapacity ∷ Int → Int+grayCodeCapacity n = 2^n++

@@ -0,0 +1,47 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.Gene+-- Copyright   :  (c) Amy de Buitléir 2011-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Definitions related to artificial genes.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax #-}++module ALife.Creatur.Genetics.Gene +  (+--    ACTG(..),+    PairedGene(..),+    decodeAndExpress+  ) where++import ALife.Creatur.Genetics.Code (Code, decodeNext)++-- | A paired instruction for building an agent.+class PairedGene g where+  -- | Given two possible forms of a PairedGene, @'express'@ takes into+  --   account any dominance relationship, and returns a PairedGene+  --   representing the result.+  express ∷ g → g → g++-- | Read the next pair of PairedGenes from a two sequences of +--   "nucleotides", and return the resulting PairedGene (after taking+--   into account any dominance relationship) and the remaining (unread)+--   portion of the two nucleotide strands.+decodeAndExpress ∷ +  (PairedGene g, Eq n) ⇒ Code g n → ([n], [n]) → (Maybe g, ([n], [n]))+decodeAndExpress c (as,bs) = (expressMaybe a b, (as',bs'))+  where (a,as') = decodeNext c as+        (b,bs') = decodeNext c bs++expressMaybe ∷ PairedGene g ⇒ Maybe g → Maybe g → Maybe g+expressMaybe (Just a) (Just b) = Just (express a b)+expressMaybe (Just a) Nothing  = Just a+expressMaybe Nothing (Just b)  = Just b+expressMaybe Nothing Nothing   = Nothing++

@@ -0,0 +1,174 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.Recombination+-- Copyright   :  (c) Amy de Buitléir 2011-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Provides a mechanism to break apart and rejoin sequences of data. +-- Inspired by DNA recombination in biology, this technique can be used+-- to recombine \"genetic\" instructions for building artificial life.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax #-}++module ALife.Creatur.Genetics.Recombination+  (+    crossover,+    cutAndSplice,+    mutateList,+    mutatePairedLists,+    randomOneOfList,+    randomOneOfPair,+    randomCrossover,+    randomCutAndSplice,+    repeatWithProbability,+    withProbability+  ) where++import ALife.Creatur.Util (safeReplaceElement)++import System.Random (Random)+import Control.Monad.Random (Rand, RandomGen, getRandom, getRandomR)++-- | Cuts two lists at the specified locations, swaps the ends, and +--   splices them. The resulting lists will be:+--   @+--     a[0..n-1] ++ b[m..]+--     b[0..m-1] ++ a[n..]+--   @+--   Here are some examples.+--   @+--     /Expression/                               /Result/+--     'cutAndSplice' 2 5 (\"abcdef\", \"ABCDEF\")    (\"abF\",\"ABCDEcdef\")+--     'cutAndSplice' 3 1 (\"abcd\", \"ABCDEFG\")     (\"abcBCDEFG\",\"Ad\")+--     'cutAndSplice' 4 4 (\"abcdef\", \"ABCDEF\")    (\"abcdEF\",\"ABCDef\")+--   @+--   If n ≤ 0 or m ≤ 0, the corresponding input list will be completely+--   transferred to the other.+--   @+--     /Expression/                               /Result/+--     'cutAndSplice' 0 4 (\"abcdef\", \"ABCDEF\")    (\"EF\",\"ABCDabcdef\")+--     'cutAndSplice' (-2) 4 (\"abcd\", \"ABCDEFGH\") (\"EFGH\",\"ABCDabcd\")+--     'cutAndSplice' 5 0 (\"abcdef\", \"ABCDEF\")    (\"abcdeABCDEF\",\"f\")+--   @+--   If n or m are greater than or equal to length of the corresponding list,+--   that list will not be transferred.+--   @+--     /Expression/                               /Result/+--     'cutAndSplice' 10 0 (\"abcdef\", \"ABCDEF\")   (\"abcdefABCDEF\",\"\")+--     'cutAndSplice' 0 0 (\"\", \"ABCDEF\")          (\"ABCDEF\",\"\")+--   @+cutAndSplice ∷ Int → Int → ([a], [a]) → ([a], [a])+cutAndSplice n m (as, bs) = (cs, ds)+    where cs = as1 ++ bs2+          ds = bs1 ++ as2+          (as1, as2) = splitAt n as+          (bs1, bs2) = splitAt m bs++-- | Same as @'cutAndSplice'@, except that the two locations are+--   chosen at random.+randomCutAndSplice ∷ (RandomGen g) ⇒ ([a], [a]) → Rand g ([a], [a])+randomCutAndSplice (as, bs) = do+    n ← getRandomR (0,length as - 1)+    m ← getRandomR (0,length bs - 1)+    return (cutAndSplice n m (as, bs))++-- | Cuts two lists at the specified location, swaps the ends, and +--   splices them. This is a variation of 'cutAndSplice' where n ≡ m.+crossover ∷ Int → ([a], [a]) → ([a], [a])+crossover n = cutAndSplice n n++-- | Same as @'crossover'@, except that the location is chosen at +--   random.+randomCrossover ∷ (RandomGen g) ⇒ ([a], [a]) → Rand g ([a], [a])+randomCrossover (as, bs) = do+    n ← getRandomR (0,length as - 1)+    return (crossover n (as, bs))++-- | Mutates a random element in the list.+mutateList ∷ (Random n, RandomGen g) ⇒ [n] → Rand g [n]+mutateList xs = do+  (i, _) ← randomListSelection xs+  x ← getRandom+  return (safeReplaceElement xs i x)++-- | Mutates a random element in one list in a pair.+mutatePairedLists ∷ +  (Random n, RandomGen g) ⇒ ([n], [n]) → Rand g ([n], [n])+mutatePairedLists (xs,ys) = do+  chooseFst ← weightedRandomBoolean 0.5+  if chooseFst +    then do+      xs' ← mutateList xs+      return (xs', ys)+    else do+      ys' ← mutateList ys+      return (xs, ys')++-- | Performs an operation with the specified probability.+withProbability ∷ RandomGen g ⇒ Double → (b → Rand g b) → b → Rand g b+withProbability p op genes = do+  doOp ← weightedRandomBoolean p+  if doOp then op genes else return genes++-- | Performs an operation a random number of times.+--   The probability of repeating the operation @n@ times is @p^n@.+repeatWithProbability ∷ RandomGen g ⇒ Double → (b → Rand g b) → b → Rand g b+repeatWithProbability p op genes = do+  doOp ← weightedRandomBoolean p+  if doOp +    then do+      genes' ← op genes+      repeatWithProbability p op genes'+    else return genes+++-- :m + ALife.Creatur.Genetics.Gene+-- let g = (replicate 10 A, replicate 10 C)+-- evalRandIO (withProbability 0.1 randomCrossover g >≥ withProbability 0.01 randomCutAndSplice >≥ withProbability 0.001 mutatePairedLists)+-- Any mixing of As and Cs will be the result of crossover (if the lengths are the same) or cut-and-splice (if the lengths are different).+-- Any Gs or Ts that show up are the result of mutation.+-- evalRandIO (withProbability 0.5 randomCrossover g >≥ withProbability 0.05 randomCutAndSplice >≥ withProbability 0.5 mutatePairedLists >≥ randomOneOfPair)+++-- | Randomly select a boolean, but weighted to return True with probability +--   p.+weightedRandomBoolean ∷ (RandomGen g) ⇒ Double → Rand g Bool+weightedRandomBoolean p = do+  x ← getRandomR (0.0,1.0)+  return (x < p)++randomOneOfPair ∷ (RandomGen g) ⇒ (a, a) → Rand g a+randomOneOfPair pair = do+  chooseFst ← weightedRandomBoolean 0.5+  if chooseFst +    then return . fst $ pair+    else return . snd $ pair++randomOneOfList ∷ (RandomGen g) ⇒ [a] → Rand g a+randomOneOfList xs = do+  (_, z) ← randomListSelection xs+  return z++---- | Sample a random element from a weighted list.+----   The total weight of all elements must not be 0.+---- Adapted from the code in MonadRandom+--randomWeightedChoice ∷ (RandomGen g) ⇒ [(a, Double)] → Rand g a+--randomWeightedChoice [] = error "randomFromList called with empty list"+--randomWeightedChoice [(x,_)] = return x+--randomWeightedChoice xs = do+--  let s = sum $ map snd xs -- total weight+--  let cs = scanl1 (\(_,q) (y,s') → (y, s'+q)) xs     -- cumulative weight+--  p ← getRandomR (0.0,s)+--  return (fst (head (dropWhile (\(_,q) → q < p) cs)))++-- | Choose an element at random from a list and return the element and its +--   index+randomListSelection ∷ (RandomGen g) ⇒ [a] → Rand g (Int, a)+randomListSelection xs = do+  i ← getRandomR (0,length xs - 1)+  return (i, xs !! i)+

@@ -0,0 +1,58 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.Reproduction.Asexual+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A reproduction method for artificial lifeforms where:+-- * Each agent has a /single/ strand of genetic information.+-- * Each child has two parents.+-- * Each parent contributes approximately half of its genetic+--   information to the offspring.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax, TypeFamilies #-}+module ALife.Creatur.Genetics.Reproduction.Asexual+  (+    Reproductive(..)+  ) where++import ALife.Creatur (AgentId)+import Control.Monad.Random (Rand, RandomGen)++-- | A species that reproduces, transmitting genetic information to+--   its offspring. Minimal complete definition: all except @mate@.+class Reproductive a where++  -- | The basic unit of hereditary information for an agent.+  --   The type signature for the agent's genome is [Base a].+  type Base a++  -- | Recombines the genetic information from two parents, creating+  --   genetic information for potential offspring.+  --   Typically this involves the following steps:+  --   1. Recombine the two strands of genetic information (one from+  --      each parent) to obtain two new strands.+  --   2. Discard one strand, and return the remaining one.+  recombine ∷ RandomGen r ⇒ a → a → Rand r [Base a]++  -- | Builds an agent based on the genome provided, if it is possible+  --   to do so.+  build ∷ AgentId → [Base a] → Maybe a++  -- | @'makeOffspring' (parent1, parent2) name@ uses the genetic+  --   information from @parent1@ and @parent2@ to produce a child with+  --   the agent ID @name@.+  --   The default implementation:+  --   1. Calls @'recombine'@ to create a genome for the child.+  --   2. Calls @'build' to construct a child with this genome.+  makeOffspring ∷ RandomGen r ⇒ a → a → AgentId → Rand r (Maybe a)+  makeOffspring a b name = do+    g ← recombine a b+    return $ build name g+++

@@ -0,0 +1,58 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.Reproduction.Sexual+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A reproduction method for artificial lifeforms where:+-- * Each agent has /two/ strands of genetic information.+-- * Each child has two parents.+-- * Each parent contributes approximately half of its genetic+--   information to the offspring.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax, TypeFamilies #-}+module ALife.Creatur.Genetics.Reproduction.Sexual+  (+    Reproductive(..)+  ) where++import ALife.Creatur (AgentId)+import Control.Monad.Random (Rand, RandomGen)++-- | A species that reproduces, transmitting genetic information to+--   its offspring. Minimal complete definition: all except @mate@.+class Reproductive a where++  -- | The basic unit of hereditary information for an agent.+  --   The type signature for the agent's genome is +  --   ([Base a], [Base a]).+  type Base a++  -- | From the /two/ strands of the genetic information from this +  --   agent, creates a /single/ strand that will contribute to the+  --   child's genome. +  --   (This is analogous to creating either a single sperm or ova.)+  produceGamete ∷ RandomGen r ⇒ a → Rand r [Base a]++  -- | Builds an agent based on the genome provided, if it is possible+  --   to do so.+  build ∷ AgentId → ([Base a], [Base a]) → Maybe a++  -- | @'makeOffspring' (parent1, parent2) name@ uses the genetic+  --   information from @parent1@ and @parent2@ to produce a child with+  --   the agent ID @name@.+  --   The default implementation:+  --   1. Calls @'produceGamete'@ to produce a single strand of genetic+  --      information from each parent.+  --   2. Pairs the two strands to create a genome for the child.+  --   3. Calls @'build' construct a child with this genome.+  makeOffspring ∷ RandomGen r ⇒ a → a → AgentId → Rand r (Maybe a)+  makeOffspring a b name = do+    ga ← produceGamete a+    gb ← produceGamete b+    return $ build name (ga, gb)+

@@ -0,0 +1,102 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Tools.Logger+-- Copyright   :  (c) Amy de Buitléir 2011-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A simple rotating log, tailored to the needs of the Créatúr +-- framework.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax    #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module ALife.Creatur.Logger+  (+    Logger(..),+    SimpleRotatingLogger,+    mkSimpleRotatingLogger+  ) where++import Control.Monad (when, unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State (StateT, get, gets, put)+import Data.Eq.Unicode ((≡))+import Data.Time (formatTime, getZonedTime)+import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)+import System.Locale (defaultTimeLocale)++class Logger l where+  -- | @'write' msg@ formats and writes a new log message.+  writeToLog ∷ String → StateT l IO ()++-- | A rotating logger.+data SimpleRotatingLogger = SimpleRotatingLogger {+    initialised ∷ Bool,+    directory ∷ FilePath,+    logFilename ∷ FilePath,+    expFilename ∷ FilePath,+    maxRecordsPerFile ∷ Int,+    recordCount ∷ Int+  } deriving Show++-- | @'mkSimpleRotatingLogger' d prefix n@ creates a logger that will write to+--   directory @d@. The log \"rotates\" (starts a new log file) every @n@+--   records. Log files follow the naming convention @prefix@./k/, where /k/ +--   is the number of the last log record contained in the file. If logging+--   has already been set up in @directory@, then logging will continue where+--   it left off; appending to the most recent log file.+mkSimpleRotatingLogger ∷ FilePath → String → Int → SimpleRotatingLogger+mkSimpleRotatingLogger d pre n = SimpleRotatingLogger False d fLog fExp n (-1)+  where fLog = d ++ "/" ++ pre ++ ".log"+        fExp = d ++ "/" ++ pre ++ ".exp"++instance Logger SimpleRotatingLogger where+  writeToLog msg = do+    initIfNeeded+    logger ← get+    logger' ← liftIO $ bumpRecordCount logger+    put logger'+    liftIO $ write' logger' msg++initIfNeeded ∷ StateT SimpleRotatingLogger IO ()+initIfNeeded = do+  isInitialised ← gets initialised+  unless isInitialised $ do+    logger ← get+    logger' ← liftIO $ initialise logger+    put logger'++initialise ∷ SimpleRotatingLogger → IO SimpleRotatingLogger+initialise logger = do+  createDirectoryIfMissing True (directory logger)+  let fExp = expFilename logger+  expFileExists ← doesFileExist fExp+  if expFileExists+    then do+      s ← readFile fExp+      return $ logger { initialised=True, recordCount=read s}+    else return $ logger { initialised=True, recordCount=0}++write' ∷ SimpleRotatingLogger → String → IO ()+write' logger msg = do+  timestamp ←+      fmap (formatTime defaultTimeLocale "%y%m%d%H%M%S%z") getZonedTime+  appendFile (logFilename logger)+    $ timestamp ++ "\t" ++ msg ++ "\n"++bumpRecordCount ∷ SimpleRotatingLogger → IO SimpleRotatingLogger+bumpRecordCount logger = do+  let n = 1 + recordCount logger+  when (0 ≡ n `mod` maxRecordsPerFile logger) $ liftIO $ rotateLog logger+  writeFile (expFilename logger) (show n)+  return logger{ recordCount=n }++rotateLog ∷ SimpleRotatingLogger → IO ()+rotateLog logger = do+  let f = logFilename logger+  renameFile f $ f ++ '.' : (show . recordCount) logger+

@@ -0,0 +1,105 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Universe+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- TODO: fill in+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax, TemplateHaskell, TypeFamilies, +    FlexibleContexts #-}++module ALife.Creatur.Universe+ (+    Universe(..),+    SimpleUniverse,+    mkSimpleUniverse,+    agentDB,+    clock,+    logger,+    multiLookup,+    extra,+    agentIds,+    addAgent,+    storeOrArchive+ ) where++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, keys, lookup, store)+import ALife.Creatur.Database.FileSystem (FSDatabase, mkFSDatabase)+import ALife.Creatur.Logger (Logger, SimpleRotatingLogger, +  mkSimpleRotatingLogger, writeToLog)+import Control.Lens (makeLenses, zoom)+import Control.Monad (unless)+import Control.Monad.State (StateT)+import Data.Either (partitionEithers)+import Data.Serialize (Serialize)++-- | A habitat containing artificial life.+data Universe c l d n x a = Universe {+    _clock ∷ c,+    _logger ∷ l,+    _agentDB ∷ d,+    _namer ∷ n,+    _extra ∷ x+  }++makeLenses ''Universe++instance (Clock c, Logger l) ⇒ Logger (Universe c l d n x a) where+  writeToLog msg = do+    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++instance AgentNamer n ⇒ AgentNamer (Universe c l d n x a) where+  genName = zoom namer N.genName++agentIds ∷ Database d ⇒ StateT (Universe c l d n x a) IO [String]+agentIds = zoom agentDB keys++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+  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++addAgent ∷ (Serialize a, Database d, Record a, a ~ DBRecord d) ⇒+     DBRecord d → StateT (Universe c l d n x a) IO ()+addAgent a = zoom agentDB (store 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 ()+  where c = mkPersistentCounter (dir ++ "/clock")+        l = mkSimpleRotatingLogger (dir ++ "/log/") name rotateCount+        d = mkFSDatabase (dir ++ "/db")+        n = mkSimpleAgentNamer (name ++ "_") (dir ++ "/namer")++

@@ -0,0 +1,149 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Universe.Task+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- TODO: fill in+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}++module ALife.Creatur.Universe.Task+ (+    AgentProgram,+    AgentsProgram,+    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.Unicode ((≫=))+import Control.Monad.State (StateT, execStateT)+import Data.Eq.Unicode ((≡))+import Data.List (unfoldr)+import Data.Serialize (Serialize)++simpleDaemon ∷ Logger u ⇒ Daemon u+simpleDaemon = Daemon+  {+    onStartup = startupHandler,+    onShutdown = shutdownHandler,+    onException = exceptionHandler,+    task = undefined,+    username = "",+    sleepTime = 100000+  }++startupHandler ∷ Logger u ⇒ u → IO u+startupHandler = execStateT (writeToLog "Starting")++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).+--   (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++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 ()+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) = +  writeToLog $ "Unable to read '" ++ name ++ "': " ++ msg+withAgent' program _ (Right a) = +  program a ≫= zoom agentDB . storeOrArchive++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+  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'+  zoom clock incTime++-- | 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.+--   (The universe will then be updated with these changes.)+--   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]++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 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) = +  writeToLog $ "Database error: " ++ msg+withAgents' program (Right as) = +  program as ≫= mapM_ (zoom agentDB . storeOrArchive)++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+  xs ← agentIds+  xs' ← liftIO $ evalRandIO $ shuffle xs+  mapM_ (withAgents agentsProgram) $ makeViews xs'+  zoom clock incTime++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))+

@@ -0,0 +1,170 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Util+-- Copyright   :  (c) Amy de Buitléir 2011-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Utility functions that don't fit anywhere else.+--+------------------------------------------------------------------------+{-# LANGUAGE UnicodeSyntax #-}++module ALife.Creatur.Util+  (+--    constrain,+    cropRect,+    cropSquare,+    perfectSquare,+    ilogBase,+    isPowerOf,+    isqrt,+    replaceElement,+    reverseLookup,+    rotate,+    safeReplaceElement,+    shuffle,+    stateMap+  ) where++import Control.Monad (forM_, liftM)+import Control.Monad.Random (Rand, RandomGen, getRandomRs)+import Control.Monad.State (StateT(..))+import Data.Array.ST (runSTArray)+import Data.Eq.Unicode ((≡))+import Data.List.Split (chunksOf)+import Data.Ord.Unicode ((≤), (≥))+import GHC.Arr (elems, listArray, readSTArray, thawSTArray, writeSTArray)++-- constrain ∷ Ord a ⇒ (a, a) → a → a+-- constrain (a,b) x | b < a     = error "Invalid range"+--                   | x < a     = a+--                   | x > b     = b+--                   | otherwise = x++-- | From <http://www.haskell.org/haskellwiki/Random_shuffle>+shuffle ∷ RandomGen g ⇒ [a] → Rand g [a]+shuffle xs = do+  let l = length xs+  rands ← take l `fmap` getRandomRs (0, l-1)+  let ar = runSTArray $ do+      ar' ← thawSTArray $ listArray (0, l-1) xs+      forM_ (zip [0..(l-1)] rands) $ \(i, j) → do+          vi ← readSTArray ar' i+          vj ← readSTArray ar' j+          writeSTArray ar' j vi+          writeSTArray ar' i vj+      return ar'+  return (elems ar)++-- | @'safeReplaceElement' xs n x@ returns a copy of @xs@ in which the @n@th+--   element (if it exists) has been replaced with @x@.+safeReplaceElement ∷ [a] → Int → a → [a]+safeReplaceElement xs i x =+  if i ≥ 0 && i < length xs+    then replaceElement xs i x+    else xs++-- | @'replaceElement' xs n x@ returns a copy of @xs@ in which the @n@th+--   element has been replaced with @x@. Causes an exception if @xs@ has+--   fewer than @n+1@ elements. Compare with @'safeReplaceElement'@.+replaceElement ∷ [a] → Int → a → [a]+replaceElement xs i x = +  if 0 ≤ i && i < length xs then fore ++ (x : aft) else xs+  where fore = take i xs+        aft = drop (i+1) xs++-- | Assuming @xs@ is a sequence containing the elements of a square matrix,+--   @'cropSquare' n xs@ returns the elements of the submatrix of size @n@x@n@,+--   centred within the original matrix @xs@.+--+--   Example: Suppose we have a /5/x/5/ matrix and we want to extract the+--   central /3/x/3/ submatrix, as illustrated below.+--+-- > a b c d e+-- > f g h i j            g h i+-- > k l m n o    --→    l m n+-- > p q r s t            q r s+-- > u v w x y+--+--   We can represent the elements of the original matrix as @[\'a\'..\'y\']@.+--   The elements of the submatrix are+--   @[\'g\', \'h\', \'i\', \'l\', \'m\', \'n\', \'q\', \'r\', \'s\']@,+--   or equivalently, @\"ghilmnqrs\"@. And that is what+--   @'cropSquare' 3 [\'a\'..\'y\']@ returns.+cropSquare ∷ Int → [a] → [a]+cropSquare n xs | n ≤ 0     = []+                | n < m     = +                    cropRect (margin, margin) (margin+n-1, margin+n-1) xs m+                | otherwise = take (m*m) xs+  where m = (isqrt . length) xs+        margin = (m - n) `div` 2++-- | Assuming @xs@ is a sequence containing the elements of a matrix with @k@+--   columns, @'cropRect' (a,b) (c, d) k xs@ returns the elements of the+--   submatrix from @(a,b)@ in the upper left corner to @(c,d)@ in the lower+--   right corner).+--   Note: Matrix indices begin at @(0,0)@.+--+--   Example: Suppose we have a /4/x/6/ matrix and we want to extract the+--   submatrix from (1,2) to (2,4), as illustrated below.+--+-- > a b c d e f+-- > g h i j k l    --→   i j k+-- > m n o p q r           o p q+-- > s t u v w x+--+--   We can represent the elements of the original matrix as @[\'a\'..\'x\']@.+--   The elements of the submatrix are+--   @[\'i\', \'j\', \'k\', \'o\', \'p\', \'q\']@, or equivalently,+--   @\"ijkopq\"@. And that is what @'cropRect' (1,2) (2,4) 6 [\'a\'..\'x\']@+--   returns.+cropRect ∷ (Int, Int) → (Int, Int) → [a] → Int → [a]+cropRect (a,b) (c, d) xs k = concatMap f selectedRows+  where rows = if k ≤ 0 then [] else chunksOf k xs+        selectedRows = safeSlice a c rows+        f = safeSlice b d++safeSlice ∷ Int → Int → [a] → [a]+safeSlice a b = drop a . take (b+1)++-- | @'isqrt' n@ returns the greatest integer not greater than the square root+--   of @n@.+isqrt ∷ (Integral a, Integral b) ⇒ a → b+isqrt n = (floor . sqrt) n'+  where n' = fromIntegral n ∷ Float++-- | @'ilogBase' n m@ returns the greatest integer not greater than the log+--   base n of @m@.+ilogBase ∷ (Integral a, Integral b, Integral c) ⇒ a → b → c+ilogBase n m = (floor . logBase n') m'+  where n' = fromIntegral n ∷ Float+        m' = fromIntegral m ∷ Float++-- | @'perfectSquare' n@ returns @True@ if @n@ is a perfect square (i.e., if +--   there exists an _integer_ m such that m*m = n)+perfectSquare ∷ Integral a ⇒ a → Bool+perfectSquare n = n ≡ m*m+  where m = isqrt n++-- | @n 'isPowerOf' m@ returns @True@ if @n@ is a power of m (i.e., if +--   there exists an _integer_ k such that m^k = n)+isPowerOf ∷ Integral a ⇒ a → a → Bool+isPowerOf n m = n ≡ m^k+  where k = ilogBase m n ∷ Int++reverseLookup ∷ (Eq b) ⇒ b → [(a,b)] → Maybe a+reverseLookup _ []          =  Nothing+reverseLookup value ((x,y):xys)+    | value ≡ y =  Just x+    | otherwise  =  reverseLookup value xys++stateMap ∷ Monad m ⇒ (s → t) → (t → s) → StateT s m a → StateT t m a+stateMap f g (StateT h) = StateT $ liftM (fmap f) . h . g++rotate ∷ [a] → [a]+rotate [] = []+rotate (x:xs) = xs ++ [x]+

@@ -0,0 +1,45 @@+{-# LANGUAGE UnicodeSyntax, DeriveGeneric #-}++module ALife.Creatur.Database.FileSystemQC+  (+    test+  ) where++import Prelude hiding (lookup)+import ALife.Creatur.Database (Record, key, store, lookup)+import ALife.Creatur.Database.FileSystem (mkFSDatabase)+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)+import Test.Framework.Providers.HUnit (testCase)++data TestRecord = TestRecord String Int+  deriving (Show, Eq, Generic)++instance Record TestRecord where+  key (TestRecord k _) = k++instance Serialize TestRecord++tryStoreLookup ∷ FilePath → IO ()+tryStoreLookup dir = do+  let db = mkFSDatabase dir+  let record = TestRecord "alpha" 7+  db' ← execStateT (store record) db+  Right record' ← evalStateT (lookup (key record)) db'+  assertEqual "wombat" record record'++testStoreLookup ∷ IO ()+testStoreLookup = withSystemTempDirectory "creaturTest.tmp" tryStoreLookup++test ∷ TF.Test+test = testGroup "HUnit ALife.Creatur.Database.FileSystemQC"+  [+    testCase "store and lookup"+      testStoreLookup+  ]++

@@ -0,0 +1,85 @@+{-# LANGUAGE UnicodeSyntax #-}++module ALife.Creatur.Genetics.CodeQC+  (+    test+  ) where++import ALife.Creatur.Genetics.Code+import ALife.Creatur.Genetics.CodeInternal+import Data.Eq.Unicode ((≡))+import Data.Ord.Unicode ((≤))+import Data.List (nub)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary, Gen, Property, arbitrary, property, +  sized, vectorOf)++-- guaranteed not to have multiple values for the same code (but might have+-- multiple codes for the same value)+data TestCode = TestCode (Code Char Bool) deriving Show++sizedArbTestCode ∷ Int → Gen TestCode+sizedArbTestCode n = do+  cs ← vectorOf n arbitrary+  xs ← vectorOf n arbitrary+  return $ TestCode $ Code n $ zip cs (nub xs)++instance Arbitrary TestCode where+  arbitrary = sized sizedArbTestCode++prop_encoding_round_trippable ∷ TestCode → Char → Property+prop_encoding_round_trippable (TestCode g) c =+  property $ maybe Nothing (decode g) (encode g c) ≡ c'+    where c' = if c `elem` cs then Just c else Nothing+          cs = map fst $ cTable g++-- guaranteed not to have multiple values for the same code, or multiple codes+-- for the same value+data TestCode2 = TestCode2 (Code Char Bool) deriving Show++sizedArbTestCode2 ∷ Int → Gen TestCode2+sizedArbTestCode2 n = do+  cs ← vectorOf n arbitrary+  xs ← vectorOf n arbitrary+  return $ TestCode2 $ Code n $ zip (nub cs) (nub xs)++instance Arbitrary TestCode2 where+  arbitrary = sized sizedArbTestCode2++prop_decoding_round_trippable ∷ TestCode2 → [Bool] → Property+prop_decoding_round_trippable (TestCode2 g) x =+  property $ maybe Nothing (encode g) (decode g x) ≡ x'+    where x' = if x `elem` xs then Just x else Nothing+          xs = map snd $ cTable g++data TestParms = TestParms String deriving Show++sizedTestParms ∷ Int → Gen TestParms+sizedTestParms n = do+  let n' = 2 + min 8 n -- keep number of values low to speed up tests+  let values = take n' ['a' .. 'z']+  return $ TestParms values++instance Arbitrary TestParms where+  arbitrary = sized sizedTestParms+  +prop_gray_code_is_efficient ∷ TestParms → Property+prop_gray_code_is_efficient (TestParms values) = +  property $ 2 ^ (nBits - 1) < nValues && nValues ≤ 2 ^ nBits+    where g = mkGrayCode values+          nValues = length values+          nBits = (length . snd . head . cTable) g++test ∷ Test+test = testGroup "QuickCheck ALife.Creatur.Genetics.CodeQC"+  [+    testProperty "prop_encoding_round_trippable"+      prop_encoding_round_trippable,+    testProperty "prop_decoding_round_trippable"+      prop_decoding_round_trippable,+    testProperty "prop_gray_code_is_efficient"+      prop_gray_code_is_efficient+  ]++

@@ -0,0 +1,32 @@+{-# LANGUAGE UnicodeSyntax #-}++module ALife.Creatur.Genetics.CrossoverQC+  (+    test+  ) where++import ALife.Creatur.Genetics.Crossover (crossover, cutAndSplice)+import Data.Eq.Unicode ((≡))+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Property, property)++prop_cutAndSplice_preserves_sum_of_lengths ∷+  Int → Int → (String, String) → Property+prop_cutAndSplice_preserves_sum_of_lengths n m (as, bs) =+  property $ length as' + length bs' ≡ length as + length bs+    where (as', bs') = cutAndSplice n m (as, bs)++prop_crossover_preserves_sum_of_lengths ∷ Int → (String, String) → Property+prop_crossover_preserves_sum_of_lengths n (as, bs) =+  property $ length as' + length bs' ≡ length as + length bs+    where (as', bs') = crossover n (as, bs)++test ∷ Test+test = testGroup "QuickCheck ALife.Creatur.Genetics.CrossoverQC"+  [+    testProperty "prop_cutAndSplice_preserves_sum_of_lengths"+      prop_cutAndSplice_preserves_sum_of_lengths,+    testProperty "prop_crossover_preserves_sum_of_lengths"+      prop_crossover_preserves_sum_of_lengths+  ]

@@ -0,0 +1,98 @@+{-# LANGUAGE UnicodeSyntax #-}++module ALife.Creatur.UtilQC+  (+    test+  ) where++import ALife.Creatur.Util (cropRect, cropSquare, isqrt, replaceElement, +  safeReplaceElement, shuffle)+import Control.Monad.Random (evalRand, mkStdGen)+import Data.Eq.Unicode ((≡))+import Data.Ix (range)+import Data.List (sort)+import Data.Ord.Unicode ((≤))+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Property, property)++-- prop_constrain_obeys_bounds ∷ (Int, Int) → Int → Property+-- prop_constrain_obeys_bounds (a, b) x = property $ a ≤ x' && x' ≤ b+--  where x' = constrain (a, b) x++-- prop_constrain_works ∷ (Int, Int) → Int → Property+-- prop_constrain_works (a, b) x = property $ x' ≡ x || x ≤ a || b ≤ x || b < a+--  where x' = constrain (a, b) x++prop_cropRect_returns_correct_size ∷+  (Int, Int) → (Int, Int) → String → Int → Property+prop_cropRect_returns_correct_size (a,b) (c, d) xs k =+    property $ length xs' ≡ expectedSize || length xs < expectedSize+  where expectedSize = length is'+        is = range ((0,0),(lastRow,lastCol))+        is' = filter wanted is+        wanted (i,j) = a ≤ i && i ≤ c && b ≤ j && j ≤ d+        lastRow = if k ≡ 0 then -1 else (length xs `div` k) - 1 + delta+        lastCol = constrain (-1,length xs - 1) (k - 1)+        delta = if length xs `mod` k ≡ 0 then 0 else 1 --add partial row+        xs' = cropRect (a, b) (c, d) xs k++-- Warning: If b < a, returns either a or x+constrain ∷ Ord a ⇒ (a, a) → a → a+constrain (a,b) x | x < a     = a+                  | x > b     = b+                  | otherwise = x++prop_cropSquare_returns_correct_size ∷ Int → String → Property+prop_cropSquare_returns_correct_size n xs =+    property $ length xs' ≡ expectedSize+  where expectedRows = min n ((isqrt . length) xs)+        expectedSize = if n < 0 then 0 else expectedRows*expectedRows+        xs' = cropSquare n xs++prop_replaceElement_changes_the_right_element ∷ String → Int → Char → Property+prop_replaceElement_changes_the_right_element cs i c =+  property+    $+      if 0 ≤ i && i < length cs+        then replaceElement cs i c !! i ≡ c+        else replaceElement cs i c ≡ cs++prop_safeReplaceElement_doesnt_change_length ∷ String → Int → Char → Property+prop_safeReplaceElement_doesnt_change_length cs i c =+  property $ length cs ≡ length (safeReplaceElement cs i c)++prop_safeReplaceElement_changes_the_right_element ∷+  String → Int → Char → Property+prop_safeReplaceElement_changes_the_right_element cs i c =+  property+    $+      if 0 ≤ i && i < length cs+        then cs' !! i ≡ c+        else cs' ≡ cs+  where cs' = safeReplaceElement cs i c++prop_shuffle_doesnt_change_elements ∷ String → Int → Property+prop_shuffle_doesnt_change_elements xs k = property $ sort xs ≡ sort xs'+  where xs' = evalRand (shuffle xs) (mkStdGen k)++test ∷ Test+test = testGroup "QuickCheck ALife.Creatur.UtilQC"+  [+--    testProperty "prop_constrain_obeys_bounds"+--      prop_constrain_obeys_bounds,+--    testProperty "prop_constrain_works"+--      prop_constrain_works,+    testProperty "prop_safeReplaceElement_changes_the_right_element"+      prop_safeReplaceElement_changes_the_right_element,+    testProperty "prop_safeReplaceElement_doesnt_change_length"+      prop_safeReplaceElement_doesnt_change_length,+    testProperty "prop_cropRect_returns_correct_size"+      prop_cropRect_returns_correct_size,+    testProperty "prop_cropSquare_returns_correct_size"+      prop_cropSquare_returns_correct_size,+    testProperty "prop_replaceElement_changes_the_right_element"+      prop_replaceElement_changes_the_right_element,+    testProperty "prop_shuffle_doesnt_change_elements"+      prop_shuffle_doesnt_change_elements+  ]

@@ -0,0 +1,21 @@+{-# LANGUAGE UnicodeSyntax #-}+module Main where++import ALife.Creatur.Database.FileSystemQC (test)+import ALife.Creatur.UtilQC (test)+import ALife.Creatur.Genetics.CodeQC (test)+import ALife.Creatur.Genetics.CrossoverQC (test)++import Test.Framework as TF (defaultMain, Test)++tests ∷ [TF.Test]+tests = +  [ +    ALife.Creatur.Database.FileSystemQC.test,+    ALife.Creatur.UtilQC.test,+    ALife.Creatur.Genetics.CodeQC.test,+    ALife.Creatur.Genetics.CrossoverQC.test+  ]++main ∷ IO ()+main = defaultMain tests