creatur 2.0.12 → 3.0.0

raw patch · 30 files changed

+1518/−560 lines, 30 filesdep −base-unicode-symbolsdep −ghc-primdep ~QuickCheckdep ~lensdep ~test-frameworkPVP ok

version bump matches the API change (PVP)

Dependencies removed: base-unicode-symbols, ghc-prim

Dependency ranges changed: QuickCheck, lens, test-framework, test-framework-quickcheck2

API changes (from Hackage documentation)

Files

• creatur.cabal +13/−13
• src/ALife/Creatur.hs +4/−4
• src/ALife/Creatur/AgentNamer.hs +10/−11
• src/ALife/Creatur/Clock.hs +3/−4
• src/ALife/Creatur/Counter.hs +17/−18
• src/ALife/Creatur/Daemon.hs +23/−24
• src/ALife/Creatur/Database.hs +8/−8
• src/ALife/Creatur/Database/FileSystem.hs +36/−26
• src/ALife/Creatur/Genetics/BRGCBool.hs +260/−0
• src/ALife/Creatur/Genetics/BRGCWord8.hs +261/−0
• src/ALife/Creatur/Genetics/Code.hs +26/−10
• src/ALife/Creatur/Genetics/CodeInternal.hs +0/−92
• src/ALife/Creatur/Genetics/Diploid.hs +299/−0
• src/ALife/Creatur/Genetics/Gene.hs +0/−47
• src/ALife/Creatur/Genetics/Recombination.hs +36/−38
• src/ALife/Creatur/Genetics/Reproduction/Asexual.hs +17/−11
• src/ALife/Creatur/Genetics/Reproduction/Sexual.hs +17/−12
• src/ALife/Creatur/Logger.hs +23/−25
• src/ALife/Creatur/Universe.hs +21/−22
• src/ALife/Creatur/Universe/Task.hs +42/−40
• src/ALife/Creatur/Util.hs +52/−40
• test/ALife/Creatur/Database/FileSystemQC.hs +18/−6
• test/ALife/Creatur/Genetics/BRGCBoolQC.hs +71/−0
• test/ALife/Creatur/Genetics/BRGCWord8QC.hs +71/−0
• test/ALife/Creatur/Genetics/CodeQC.hs +28/−41
• test/ALife/Creatur/Genetics/CrossoverQC.hs +0/−32
• test/ALife/Creatur/Genetics/DiploidQC.hs +60/−0
• test/ALife/Creatur/Genetics/RecombinationQC.hs +41/−0
• test/ALife/Creatur/UtilQC.hs +39/−31
• test/Main.hs +22/−5

@@ -1,5 +1,5 @@ Name:              creatur-Version:           2.0.12+Version:           3.0.0 Stability:         experimental Synopsis:          Framework for artificial life experiments. Description:       A software framework for automating experiments@@ -29,7 +29,7 @@ Cabal-Version:     >=1.8  library-  GHC-Options:      -Wall+  GHC-Options:      -Wall -fno-warn-orphans   Hs-source-dirs:   src   exposed-modules:  ALife.Creatur,                     ALife.Creatur.AgentNamer,@@ -39,8 +39,9 @@                     ALife.Creatur.Database,                     ALife.Creatur.Database.FileSystem,                     ALife.Creatur.Genetics.Code,-                    ALife.Creatur.Genetics.CodeInternal,-                    ALife.Creatur.Genetics.Gene,+                    ALife.Creatur.Genetics.BRGCBool,+                    ALife.Creatur.Genetics.BRGCWord8,+                    ALife.Creatur.Genetics.Diploid,                     ALife.Creatur.Genetics.Recombination,                     ALife.Creatur.Genetics.Reproduction.Asexual,                     ALife.Creatur.Genetics.Reproduction.Sexual,@@ -51,14 +52,13 @@   Build-Depends:                         array ==0.4.*,                     base ==4.*,-                    base-unicode-symbols ==0.2.*,                     bytestring ==0.10.*,                     cereal ==0.3.*,                     directory ==1.2.*,                     gray-extended ==1.*,                     hdaemonize ==0.4.*,                     hmatrix ==0.14.*,-                    lens ==3.7.*,+                    lens ==3.8.*,                     MonadRandom ==0.1.*,                     mtl ==2.1.*,                     old-locale ==1.0.*,@@ -78,22 +78,22 @@   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 ==0.8.*,                     test-framework-hunit ==0.3.*,-                    test-framework-quickcheck2 ==0.2.*,-                    QuickCheck >= 2.5+                    test-framework-quickcheck2 ==0.3.*,+                    QuickCheck ==2.5.*   Other-modules:    ALife.Creatur.UtilQC                     ALife.Creatur.Database.FileSystemQC                     ALife.Creatur.Genetics.CodeQC-                    ALife.Creatur.Genetics.CrossoverQC-+                    ALife.Creatur.Genetics.DiploidQC,+                    ALife.Creatur.Genetics.BRGCBoolQC+                    ALife.Creatur.Genetics.BRGCWord8QC+                    ALife.Creatur.Genetics.RecombinationQC

@@ -7,10 +7,10 @@ -- Stability   :  experimental -- Portability :  portable ----- Definitions use throughout the Créatúr framework.+-- Definitions used throughout the Créatúr framework. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}  module ALife.Creatur  (@@ -30,8 +30,8 @@ class Agent a where    -- | Returns the agent ID.-  agentId ∷ a → AgentId+  agentId :: a -> AgentId    -- | Returns True if the agent is alive, false otherwise.-  isAlive ∷ a → Bool+  isAlive :: a -> Bool 

@@ -1,6 +1,6 @@ ------------------------------------------------------------------------ -- |--- Module      :  ALife.Creatur.Tools.AgentNamer+-- Module      :  ALife.Creatur.AgentNamer -- Copyright   :  (c) Amy de Buitléir 2012-2013 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie@@ -12,7 +12,6 @@ -- simulation runs. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax #-} module ALife.Creatur.AgentNamer   (     AgentNamer(..),@@ -28,26 +27,26 @@  class AgentNamer n where   -- | Assign a unique ID using the supplied prefix.-  genName ∷ StateT n IO AgentId+  genName :: StateT n IO AgentId  data SimpleAgentNamer = SimpleAgentNamer    {-    prefix ∷ String,-    counter ∷ PersistentCounter+    prefix :: String,+    counter :: PersistentCounter   } -mkSimpleAgentNamer ∷ String → FilePath → SimpleAgentNamer+mkSimpleAgentNamer :: String -> FilePath -> SimpleAgentNamer mkSimpleAgentNamer s f = SimpleAgentNamer s $ mkPersistentCounter f -withCounter ∷ StateT PersistentCounter IO x → StateT SimpleAgentNamer IO x+withCounter :: StateT PersistentCounter IO x -> StateT SimpleAgentNamer IO x withCounter runProgram = do-  u ← get-  stateMap (\c → u {counter=c}) counter runProgram+  u <- get+  stateMap (\c -> u {counter=c}) counter runProgram  instance AgentNamer SimpleAgentNamer where   genName = do-    p ← gets prefix-    k ← withCounter (increment >> current)+    p <- gets prefix+    k <- withCounter (increment >> current)     return $ p ++ show k  

@@ -1,6 +1,6 @@ ------------------------------------------------------------------------ -- |--- Module      :  ALife.Creatur.Tools.Logger+-- Module      :  ALife.Creatur.Clock -- Copyright   :  (c) Amy de Buitléir 2012-2013 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie@@ -17,7 +17,6 @@ -- CPU performance can still be meaningfully compared. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax #-} module ALife.Creatur.Clock   (     Clock(..)@@ -35,7 +34,7 @@ --   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+  currentTime :: StateT c IO Time   -- | Advance the clock to the next "tick".-  incTime ∷ StateT c IO ()+  incTime :: StateT c IO () 

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

@@ -11,7 +11,7 @@ -- framework. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}  module ALife.Creatur.Daemon   (@@ -23,67 +23,66 @@   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 :: MVar Bool termReceived = unsafePerformIO (newMVar False)  -- | Daemon configuration.---   If @username@ ≡ "", the daemon will run under the login name.+--   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+    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 :: Daemon s -> s -> IO () launch d s = do-  uid ← getRealUserID-  if uid ≠ 0+  uid <- getRealUserID+  if uid /= 0     then putStrLn "Must run as root"     else do-      u ← daemonUsername d+      u <- daemonUsername d       serviced $ simpleDaemon          { program = daemonMain d s,           user    = Just u } -daemonUsername ∷ Daemon s → IO String+daemonUsername :: Daemon s -> IO String daemonUsername d =   if (null . username) d     then getLoginName     else (return . username) d     -daemonMain ∷ Daemon s → s → () → IO ()+daemonMain :: Daemon s -> s -> () -> IO () daemonMain d s _ = do-  s' ← onStartup d s-  _ ← installHandler sigTERM (Catch handleTERM) (Just fullSignalSet)-  _ ← daemonMainLoop d s'+  s' <- onStartup d s+  _ <- installHandler sigTERM (Catch handleTERM) (Just fullSignalSet)+  _ <- daemonMainLoop d s'   return () -daemonMainLoop ∷ Daemon s → s → IO ()+daemonMainLoop :: Daemon s -> s -> IO () daemonMainLoop d s = do   threadDelay . sleepTime $ d-  timeToStop ← readMVar termReceived+  timeToStop <- readMVar termReceived   if timeToStop      then onShutdown d s     else do-      s' ← handle ((onException d) s) $ execStateT (task d) s+      s' <- handle (onException d s) $ execStateT (task d) s       daemonMainLoop d s' -handleTERM ∷ IO ()+handleTERM :: IO () handleTERM = do-  _ ← swapMVar termReceived True+  _ <- swapMVar termReceived True   return () 

@@ -10,7 +10,7 @@ -- Database interface for the Créatúr framework. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}  module ALife.Creatur.Database  (@@ -22,21 +22,21 @@ import Data.Serialize (Serialize)  class Record r where-  key ∷ r → String+  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]+  keys :: StateT d IO [String]   -- | Read a record from the database.-  lookup ∷ Serialize (DBRecord d) ⇒ -    String → StateT d IO (Either String (DBRecord d))+  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 ()+  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 ()+  delete :: Serialize (DBRecord d) => String -> StateT d IO () 

@@ -1,7 +1,17 @@-{-# 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+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- A ridiculously simple database that stores each record in a+-- separate file. The name of the file is the record's key.+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts #-} module ALife.Creatur.Database.FileSystem   (     FSDatabase,@@ -20,13 +30,13 @@ 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.+-- | 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+    initialised :: Bool,+    mainDir :: FilePath,+    archiveDir :: FilePath   } deriving Show  instance Database (FSDatabase r) where@@ -34,13 +44,13 @@    keys = do     initIfNeeded-    d ← gets mainDir-    files ← liftIO $ getDirectoryContents d+    d <- gets mainDir+    files <- liftIO $ getDirectoryContents d     return $ filter isRecordFileName files    lookup k = do     initIfNeeded-    d ← gets mainDir+    d <- gets mainDir     let f = d ++ '/':k     liftIO $ readRecord3 f @@ -50,49 +60,49 @@    delete name = do     initIfNeeded-    fileExists ← liftIO $ doesFileExist name+    fileExists <- liftIO $ doesFileExist name     when fileExists $ liftIO $ removeFile name  -- | @'mkFSDatabase' d@ (re)creates the FSDatabase in the --   directory @d@.-mkFSDatabase ∷ FilePath → FSDatabase r+mkFSDatabase :: FilePath -> FSDatabase r mkFSDatabase d = FSDatabase False d (d ++ "/archive") -initIfNeeded ∷ StateT (FSDatabase r) IO ()+initIfNeeded :: StateT (FSDatabase r) IO () initIfNeeded = do-  isInitialised ← gets initialised+  isInitialised <- gets initialised   unless isInitialised $ do-    u ← get-    u' ← liftIO $ initialise u+    u <- get+    u' <- liftIO $ initialise u     put u' -initialise ∷ FSDatabase r → IO (FSDatabase r)+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 :: DS.Serialize r => FilePath -> IO (Either String r) readRecord3 f = do-  x ← readFile f+  x <- readFile f   return $ DS.decode x  -- | Write a record to a file.-writeRecord3 ∷ (Record r, DS.Serialize r) ⇒ FilePath → r → IO ()+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 :: (Record r, DS.Serialize r) => +  (FSDatabase r -> FilePath) -> r -> StateT (FSDatabase r) IO () writeRecord2 dirGetter r = do-  d ← gets dirGetter+  d <- gets dirGetter   let f = d ++ '/':key r   liftIO $ writeRecord3 f r   -- liftIO $ agentId r ++ " archived to " ++ show f      -isRecordFileName ∷ String → Bool+isRecordFileName :: String -> Bool isRecordFileName s =   s `notElem` [ "archive", ".", ".." ] 

@@ -0,0 +1,260 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.BRGCBool+-- Copyright   :  (c) Amy de Buitléir 2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Utilities for working with genes that are encoded as a sequence of+-- bits, using a Binary Reflected Gray Code (BRGC).+--+-- 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 are likely to 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.+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,+    DefaultSignatures, DeriveGeneric, TypeOperators #-}+module ALife.Creatur.Genetics.BRGCBool+  (+    Genetic(..),+    Sequence,+    Writer,+    write,+    runWriter,+    Reader,+    read,+    runReader,+    copy,+    consumed,+    DiploidSequence,+    DiploidReader,+    readAndExpress,+    runDiploidReader,+    getAndExpress,+    getAndExpressWithDefault,+    copy2,+    consumed2+  ) where++import Prelude hiding (read)+import ALife.Creatur.Genetics.Diploid (Diploid, express)+import Codec.Gray (integralToGray, grayToIntegral)+import Control.Applicative ((<$>), (<*>))+import Control.Monad (replicateM)+import Control.Monad.State.Lazy (StateT, runState, execState, evalState)+import qualified Control.Monad.State.Lazy as S (put, get, gets)+import Data.Char (ord, chr, intToDigit)+import Data.Functor.Identity (Identity)+import Data.Maybe (fromMaybe)+import Data.Word (Word8, Word16)+import GHC.Generics+import Numeric (showIntAtBase)++type Sequence = [Bool]++type Writer = StateT Sequence Identity++write :: Genetic x => x -> Sequence+write x = execState (put x) []++runWriter :: Writer () -> Sequence+runWriter w = execState w []++type Reader = StateT (Sequence, Int) Identity++read :: Genetic g => Sequence -> Maybe g+read s = evalState get (s, 0)++runReader :: Reader g -> Sequence -> g+runReader r s = evalState r (s, 0)++-- | Return the entire genome.+copy :: Reader Sequence+copy = S.gets fst++-- | Return the portion of the genome that has been read.+consumed :: Reader Sequence+consumed = do+  (xs, i) <- S.get+  return $ take i xs++-- | A class representing anything which is represented in, and+--   determined by, an agent's genome.+--   This might include traits, parameters, "organs" (components of+--   agents), or even entire agents.+--   Instances of this class can be thought of as genes, i.e.,+--   instructions for building an agent.+class Genetic g where+  -- | Writes a gene to a sequence.+  put :: g -> Writer ()++  default put :: (Generic g, GGenetic (Rep g)) => g -> Writer ()+  put = gput . from++  -- | Reads the next gene in a sequence.+  get :: Reader (Maybe g)++  default get :: (Generic g, GGenetic (Rep g)) => Reader (Maybe g)+  get = do+    a <- gget+    return . fmap to $ a++  getWithDefault :: g -> Reader g+  getWithDefault d = fmap (fromMaybe d) get++class GGenetic f where+  gput :: f a -> Writer ()+  gget :: Reader (Maybe (f a))++-- | Unit: used for constructors without arguments+instance GGenetic U1 where+  gput U1 = return ()+  gget = return (Just U1)++-- | Constants, additional parameters and recursion of kind *+instance (GGenetic a, GGenetic b) => GGenetic (a :*: b) where+  gput (a :*: b) = gput a >> gput b+  gget = do+    a <- gget+    b <- gget+    return $ (:*:) <$> a <*> b++-- | Meta-information (constructor names, etc.)+instance (GGenetic a, GGenetic b) => GGenetic (a :+: b) where+  gput (L1 x) = put True >> gput x+  gput (R1 x) = put False >> gput x+  gget = do+    a <- get+    if a == Just True+       then fmap (fmap L1) gget+       else fmap (fmap R1) gget++-- | Sums: encode choice between constructors+instance (GGenetic a) => GGenetic (M1 i c a) where+  gput (M1 x) = gput x+  gget = fmap (fmap M1) gget++-- | Products: encode multiple arguments to constructors+instance (Genetic a) => GGenetic (K1 i a) where+  gput (K1 x) = put x+  gget = do+    a <- get+    return . fmap K1 $ a++--+-- Instances+--++instance Genetic Bool where+  put x = do+    xs <- S.get+    S.put (xs ++ [x])+  get = do+    (xs, i) <- S.get+    let xs' = drop i xs+    if null xs'+       then return Nothing+       else do+         let x = head xs'+         S.put (xs, i+1)+         return $ Just x++instance Genetic Char where+  put = putRawBoolArray . intToBools 8 . ord+  get = do+    bs <- getRawBoolArray 8+    return . fmap chr . fmap boolsToInt $ bs++instance Genetic Word8 where+  put = putRawBoolArray . intToBools 8 . integralToGray+  get = fmap (fmap (grayToIntegral . boolsToInt)) (getRawBoolArray 8)++instance Genetic Word16 where+  put = putRawBoolArray . intToBools 16 . integralToGray+  get = fmap (fmap (grayToIntegral . boolsToInt)) (getRawBoolArray 16)++instance (Genetic a) => Genetic [a]++instance (Genetic a) => Genetic (Maybe a)++--+-- Utilities+--++-- Useful when we know exactly how many bits there should be.+putRawBoolArray :: [Bool] -> Writer ()+putRawBoolArray = mapM_ put++getRawBoolArray :: Int -> Reader (Maybe [Bool])+getRawBoolArray n = do+  xs <- replicateM n get+  return . sequence $ xs++intToBools :: (Integral a, Show a) => Int -> a -> [Bool]+intToBools nBits x =+  map (\b -> b == '1') . tail . showIntAtBase 2 intToDigit x' $ ""+  where x' = 2^nBits + fromIntegral x :: Int++boolsToInt :: Integral a => [Bool] -> a+boolsToInt bs = f 0 ns+  where ns = map (\x -> if x then 1 else 0) bs+        f i [] = i+        f i (j:js) = f (i*2+j) js++--+-- Diploid genes+--++type DiploidSequence = (Sequence, Sequence)++type DiploidReader = StateT ((Sequence, Int), (Sequence, Int)) Identity++readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Maybe g+readAndExpress (s1, s2) = evalState getAndExpress ((s1, 0), (s2, 0))++runDiploidReader :: DiploidReader g -> DiploidSequence -> g+runDiploidReader r (s1, s2) = evalState r ((s1, 0), (s2, 0))++-- | Return the entire genome.+copy2 :: DiploidReader DiploidSequence+copy2 = do+  (ra, rb) <- S.get+  let as = evalState copy ra+  let bs = evalState copy rb+  return (as, bs)++-- | Return the portion of the genome that has been read.+consumed2 :: DiploidReader DiploidSequence+consumed2 = do+  (ra, rb) <- S.get+  let as = evalState consumed ra+  let bs = evalState consumed rb+  return (as, bs)++-- | Read the next pair of genes from twin sequences of genetic+--   information, and return the resulting gene (after taking+--   into account any dominance relationship) and the remaining+--   (unread) portion of the two nucleotide strands.+getAndExpress :: (Genetic g, Diploid g) => DiploidReader (Maybe g)+getAndExpress = do+  (sa, sb) <- S.get+  let (a, sa') = runState get sa+  let (b, sb') = runState get sb+  S.put (sa', sb')+  return $ expressMaybe a b++getAndExpressWithDefault :: (Genetic g, Diploid g) => g -> DiploidReader g+getAndExpressWithDefault d = fmap (fromMaybe d) getAndExpress++expressMaybe :: Diploid 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,261 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.BRGCWord8+-- Copyright   :  (c) Amy de Buitléir 2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Utilities for working with genes that are encoded as a sequence of+-- bytes, using a Binary Reflected Gray Code (BRGC).+--+-- 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 are likely to 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.+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,+    DefaultSignatures, DeriveGeneric, TypeOperators #-}+module ALife.Creatur.Genetics.BRGCWord8+  (+    Genetic(..),+    Sequence,+    Writer,+    write,+    runWriter,+    Reader,+    read,+    runReader,+    copy,+    consumed,+    DiploidSequence,+    DiploidReader,+    readAndExpress,+    runDiploidReader,+    getAndExpress,+    getAndExpressWithDefault,+    copy2,+    consumed2,+    putRawWord8,+    getRawWord8+  ) where++import Prelude hiding (read)+import ALife.Creatur.Genetics.Diploid (Diploid, express)+import Codec.Gray (integralToGray, grayToIntegral)+import Control.Applicative ((<$>), (<*>))+import Control.Monad.State.Lazy (StateT, runState, execState, evalState)+import qualified Control.Monad.State.Lazy as S (put, get, gets)+import Data.Char (ord, chr)+import Data.Functor.Identity (Identity)+import Data.Maybe (fromMaybe)+import Data.Word (Word8, Word16)+import GHC.Generics++type Sequence = [Word8]++type Writer = StateT Sequence Identity++write :: Genetic x => x -> Sequence+write x = execState (put x) []++runWriter :: Writer () -> Sequence+runWriter w = execState w []++type Reader = StateT (Sequence, Int) Identity++read :: Genetic g => Sequence -> Maybe g+read s = evalState get (s, 0)++runReader :: Reader g -> Sequence -> g+runReader r s = evalState r (s, 0)++-- | Return the entire genome.+copy :: Reader Sequence+copy = S.gets fst++-- | Return the portion of the genome that has been read.+consumed :: Reader Sequence+consumed = do+  (xs, i) <- S.get+  return $ take i xs++-- | A class representing anything which is represented in, and+--   determined by, an agent's genome.+--   This might include traits, parameters, "organs" (components of+--   agents), or even entire agents.+--   Instances of this class can be thought of as genes, i.e.,+--   instructions for building an agent.+class Genetic g where+  -- | Writes a gene to a sequence.+  put :: g -> Writer ()++  default put :: (Generic g, GGenetic (Rep g)) => g -> Writer ()+  put = gput . from++  -- | Reads the next gene in a sequence.+  get :: Reader (Maybe g)++  default get :: (Generic g, GGenetic (Rep g)) => Reader (Maybe g)+  get = do+    a <- gget+    return . fmap to $ a++  getWithDefault :: g -> Reader g+  getWithDefault d = fmap (fromMaybe d) get++class GGenetic f where+  gput :: f a -> Writer ()+  gget :: Reader (Maybe (f a))++-- | Unit: used for constructors without arguments+instance GGenetic U1 where+  gput U1 = return ()+  gget = return (Just U1)++-- | Constants, additional parameters and recursion of kind *+instance (GGenetic a, GGenetic b) => GGenetic (a :*: b) where+  gput (a :*: b) = gput a >> gput b+  gget = do+    a <- gget+    b <- gget+    return $ (:*:) <$> a <*> b++-- | Meta-information (constructor names, etc.)+instance (GGenetic a, GGenetic b) => GGenetic (a :+: b) where+  gput (L1 x) = putRawWord8 0 >> gput x+  gput (R1 x) = putRawWord8 1 >> gput x+  gget = do+    a <- getRawWord8+    case a of+      (Just x) -> do+        if even x -- Only care about the last bit+          then fmap (fmap L1) gget+          else fmap (fmap R1) gget+      Nothing -> return Nothing++-- | Sums: encode choice between constructors+instance (GGenetic a) => GGenetic (M1 i c a) where+  gput (M1 x) = gput x+  gget = fmap (fmap M1) gget++-- | Products: encode multiple arguments to constructors+instance (Genetic a) => GGenetic (K1 i a) where+  gput (K1 x) = put x+  gget = do+    a <- get+    return . fmap K1 $ a++--+-- Instances+--++instance Genetic Bool where+  put False = putRawWord8 0+  put True  = putRawWord8 1+  get = fmap (fmap word8ToBool) getRawWord8++word8ToBool :: Word8 -> Bool+word8ToBool x = if even x then False else True++instance Genetic Char where+  put = putRawWord8 . fromIntegral . ord+  get = fmap (fmap (chr . fromIntegral)) getRawWord8++instance Genetic Word8 where+  put = putRawWord8 . integralToGray+  get = fmap (fmap grayToIntegral) getRawWord8++instance Genetic Word16 where+  put g = putRawWord8 high >> putRawWord8 low+    where x = integralToGray g+          high = fromIntegral (x `div` 0x100)+          low = fromIntegral (x `mod` 0x100)+  get = do+    h <- getRawWord8 :: Reader (Maybe Word8)+    let high = fmap (\x -> fromIntegral x * 0x100) h :: Maybe Word16+    l <- getRawWord8 :: Reader (Maybe Word8)+    let low = fmap fromIntegral l :: Maybe Word16+    return . fmap grayToIntegral $ (+) <$> high <*> low++instance (Genetic a) => Genetic [a]++instance (Genetic a) => Genetic (Maybe a)++--+-- Utilities+--++-- | Write a Word8 value to the genome without encoding it+putRawWord8 :: Word8 -> Writer ()+putRawWord8 x = do+  xs <- S.get+  S.put (xs ++ [x])++-- | Read a Word8 value from the genome without decoding it+getRawWord8 :: Reader (Maybe Word8)+getRawWord8 = do+  (xs, i) <- S.get+  let xs' = drop i xs+  if null xs'+     then return Nothing+     else do+       let x = head xs'+       S.put (xs, i+1)+       return $ Just x++--+-- Diploid genes+--++type DiploidSequence = (Sequence, Sequence)++type DiploidReader = StateT ((Sequence, Int), (Sequence, Int)) Identity++readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Maybe g+readAndExpress (s1, s2) = evalState getAndExpress ((s1, 0), (s2, 0))++runDiploidReader :: DiploidReader g -> DiploidSequence -> g+runDiploidReader r (s1, s2) = evalState r ((s1, 0), (s2, 0))++-- | Return the entire genome.+copy2 :: DiploidReader DiploidSequence+copy2 = do+  (ra, rb) <- S.get+  let as = evalState copy ra+  let bs = evalState copy rb+  return (as, bs)++-- | Return the portion of the genome that has been read.+consumed2 :: DiploidReader DiploidSequence+consumed2 = do+  (ra, rb) <- S.get+  let as = evalState consumed ra+  let bs = evalState consumed rb+  return (as, bs)++-- | Read the next pair of genes from twin sequences of genetic+--   information, and return the resulting gene (after taking+--   into account any dominance relationship) and the remaining+--   (unread) portion of the two nucleotide strands.+getAndExpress :: (Genetic g, Diploid g) => DiploidReader (Maybe g)+getAndExpress = do+  (sa, sb) <- S.get+  let (a, sa') = runState get sa+  let (b, sb') = runState get sb+  S.put (sa', sb')+  return $ expressMaybe a b++getAndExpressWithDefault :: (Genetic g, Diploid g) => g -> DiploidReader g+getAndExpressWithDefault d = fmap (fromMaybe d) getAndExpress++expressMaybe :: Diploid 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

@@ -7,25 +7,41 @@ -- Stability   :  experimental -- Portability :  portable ----- Encoding schemes for genes.+-- Lookup table for encoding genes. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax #-}- module ALife.Creatur.Genetics.Code   (     -- * Coding schemes-    Code,-    mkGrayCode,+    Code(..),     -- * Encoding and decoding     encode,     encodeNext,     decode,-    decodeNext,-    -- * Miscellaneous-    asBits+    decodeNext   ) where -import ALife.Creatur.Genetics.CodeInternal (Code, mkGrayCode, encode, -  encodeNext, decode, decodeNext, asBits)+import ALife.Creatur.Util (reverseLookup) +-- | An encoding scheme.+data Code a b = Code { cSize :: Int, cTable :: [(a,[b])] } deriving Show++-- | Encodes a value as a sequence of letters in the code alphabet.+encode :: Eq a => Code a b -> a -> Maybe [b]+encode = flip lookup . cTable++-- | Encodes a value and append it to the sequence provided. If the+--   value cannot be encoded, the sequence is returned unmodified.+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 letters in the+--   code alphabet.+decode :: Eq b => Code a b -> [b] -> Maybe a+decode = flip reverseLookup . cTable++-- | Decodes a value from a sequence, and returns the value and the+--   unused portion of the sequence.+decodeNext :: Eq b => Code a b -> [b] -> Maybe (a, [b])+decodeNext c bs = decode c bs1 >>= \g -> Just (g, bs2)+  where (bs1, bs2) = splitAt (cSize c) bs

@@ -1,92 +0,0 @@---------------------------------------------------------------------------- |--- 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,299 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.Diploid+-- Copyright   :  (c) Amy de Buitléir 2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- TODO+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,+    DefaultSignatures, DeriveGeneric, TypeOperators,+    UndecidableInstances #-}+module ALife.Creatur.Genetics.Diploid+  (+    Diploid(..),+    expressMaybe+    -- * Deriving generic instances of @Diploid@+    -- $Generic+  ) where++import Data.Word+import GHC.Generics++-- | A /diploid/ agent has two complete sets of genetic instructions.+--   Instances of this class can be thought of as paired genes or+--   paired instructions for building an agent.+--   When two instructions in a pair differ, /dominance/ relationships+--   determine how the genes will be /expressed/ in the agent.+--   Minimal complete definition: @'express'@.+class Diploid g where+  -- | Given two possible forms of a gene, @'express'@ takes into+  --   account any dominance relationship, and returns a gene+  --   representing the result.+  express :: g -> g -> g++  default express :: (Generic g, GDiploid (Rep g)) => g -> g -> g+  express x y = to $ gexpress (from x) (from y)++class GDiploid f where+  gexpress :: f g -> f g -> f g++-- | Unit: used for constructors without arguments+instance GDiploid U1 where+  gexpress U1 U1 = U1++-- | Constants, additional parameters and recursion of kind *+instance (GDiploid a, GDiploid b) => GDiploid (a :*: b) where+  gexpress (a :*: b) (c :*: d) = (gexpress a c) :*: (gexpress b d)++-- | Meta-information (constructor names, etc.)+instance (GDiploid a, GDiploid b) => GDiploid (a :+: b) where+  gexpress (L1 x) (L1 y) = L1 (gexpress x y)+  gexpress (L1 x) _      = L1 x+  gexpress _ (L1 x)      = L1 x+  gexpress (R1 x) (R1 y) = R1 (gexpress x y)++-- | Sums: encode choice between constructors+instance (GDiploid a) => GDiploid (M1 i c a) where+  gexpress (M1 x) (M1 y) = M1 (gexpress x y)++-- | Products: encode multiple arguments to constructors+instance (Diploid a) => GDiploid (K1 i a) where+  gexpress (K1 x) (K1 y) = K1 (express x y)++instance Diploid Bool where+  express a b = a || b++instance Diploid Char where+  express = min++instance Diploid Int where+  express = min++instance Diploid Word where+  express = min++instance Diploid Word8 where+  express = min++instance Diploid Word16 where+  express = min++instance Diploid Word32 where+  express = min++instance Diploid Word64 where+  express = min++instance Diploid Double where+  express = min++instance (Diploid a) => Diploid [a]++instance (Diploid a) => Diploid (Maybe a)++-- TODO: Types I might want to define instances for+-- Bool	 +-- Char	 +-- Double	 +-- Float	 +-- Int	 +-- Int8	 +-- Int16	 +-- Int32	 +-- Int64	 +-- Integer	 +-- Ordering	 +-- Word	 +-- Word8	 +-- Word16	 +-- Word32	 +-- Word64	 +-- ()	 +-- TyCon	 +-- TypeRep	 +-- ArithException	 +-- ErrorCall	 +-- SomeException	 +-- IOException	 +-- MaskingState	 +-- Lexeme	 +-- IOMode	 +-- SeekMode	 +-- CUIntMax	 +-- CIntMax	 +-- CUIntPtr	 +-- CIntPtr	 +-- CSUSeconds	 +-- CUSeconds	 +-- CTime	 +-- CClock	 +-- CSigAtomic	 +-- CWchar	 +-- CSize	 +-- CPtrdiff	 +-- CDouble	 +-- CFloat	 +-- CULLong	 +-- CLLong	 +-- CULong	 +-- CLong	 +-- CUInt	 +-- CInt	 +-- CUShort	 +-- CShort	 +-- CUChar	 +-- CSChar	 +-- CChar	 +-- GeneralCategory	 +-- Associativity	 +-- Fixity	 +-- Arity	 +-- Dynamic	 +-- IntPtr	 +-- WordPtr	 +-- Any	 +-- All	 +-- CodingProgress	 +-- TextEncoding	 +-- NewlineMode	 +-- Newline	 +-- BufferMode	 +-- Handle	 +-- IOErrorType	 +-- ExitCode	 +-- ArrayException	 +-- AsyncException	 +-- AssertionFailed	 +-- Deadlock	 +-- BlockedIndefinitelyOnSTM	 +-- BlockedIndefinitelyOnMVar	 +-- CodingFailureMode	 +-- ThreadStatus	 +-- BlockReason	 +-- ThreadId	 +-- NestedAtomically	 +-- NonTermination	 +-- NoMethodError	 +-- RecUpdError	 +-- RecConError	 +-- RecSelError	 +-- PatternMatchFail	 +-- Fd	 +-- CRLim	 +-- CTcflag	 +-- CSpeed	 +-- CCc	 +-- CUid	 +-- CNlink	 +-- CGid	 +-- CSsize	 +-- CPid	 +-- COff	 +-- CMode	 +-- CIno	 +-- CDev	 +-- Event	 +-- FdKey	 +-- HandlePosn	 +-- Fixity	 +-- ConstrRep	 +-- DataRep	 +-- Constr	 +-- DataType	 +-- GCStats	 +-- Version	 +-- a => Diploid [a]	 +-- (Integral a, Diploid a) => Diploid (Ratio a)	 +-- (Ptr a)	 +-- (FunPtr a)	 +-- a => Diploid (Maybe a)	 +-- (ForeignPtr a)	 +-- (IsEven n)	 +-- (IsZero n)	 +-- a => Diploid (Last a)	 +-- a => Diploid (First a)	 +-- a => Diploid (Product a)	 +-- a => Diploid (Sum a)	 +-- a => Diploid (Dual a)	 +-- a => Diploid (Complex a)	 +-- HasResolution a => Diploid (Fixed a)	 +-- (a -> b)	 +-- (Diploid a, Diploid b) => Diploid (Either a b)	 +-- (Diploid a, Diploid b) => Diploid (a, b)	 +-- (ST s a)	 +-- (SingE k (Kind k) rep, Diploid rep) => Diploid (Sing k a)	 +-- (Diploid a, Diploid b, Diploid c) => Diploid (a, b, c)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d) => Diploid (a, b, c, d)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e) => Diploid (a, b, c, d, e)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f) => Diploid (a, b, c, d, e, f)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g) => Diploid (a, b, c, d, e, f, g)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g, Diploid h) => Diploid (a, b, c, d, e, f, g, h)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g, Diploid h, Diploid i) => Diploid (a, b, c, d, e, f, g, h, i)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g, Diploid h, Diploid i, Diploid j) => Diploid (a, b, c, d, e, f, g, h, i, j)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g, Diploid h, Diploid i, Diploid j, Diploid k) => Diploid (a, b, c, d, e, f, g, h, i, j, k)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g, Diploid h, Diploid i, Diploid j, Diploid k, Diploid l) => Diploid (a, b, c, d, e, f, g, h, i, j, k, l)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g, Diploid h, Diploid i, Diploid j, Diploid k, Diploid l, Diploid m) => Diploid (a, b, c, d, e, f, g, h, i, j, k, l, m)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g, Diploid h, Diploid i, Diploid j, Diploid k, Diploid l, Diploid m, Diploid n) => Diploid (a, b, c, d, e, f, g, h, i, j, k, l, m, n)	 +-- (Diploid a, Diploid b, Diploid c, Diploid d, Diploid e, Diploid f, Diploid g, Diploid h, Diploid i, Diploid j, Diploid k, Diploid l, Diploid m, Diploid n, Diploid o) => Diploid (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)	 ++++{- $Generic+You can easily use the generic mechanism provided to automatically+create implementations of @Diploid@ for arbitrarily complex types.+First, you need to import:++>import GHC.Generics++Instances of @Diploid@ have been defined for some base types.+You will need to create instances for any additional base types+that you use.++If the arrays are of different lengths, the result will be as long as+the shorter array.++>λ> express [1,2,3,4] [5,6,7,8,9] :: [Int]+>[1,2,3,4]++You can automatically derive instances for more complex types:++>data MyType = MyTypeA Bool | MyTypeB Int | MyTypeC Bool Int [MyType]+>deriving (Show, Generic)++>instance Diploid MyType+>instance Diploid [MyType]++>λ> express (MyTypeA True) (MyTypeA False)+>MyTypeA True++>λ> express (MyTypeB 2048) (MyTypeB 36)+>MyTypeB 36++Even with complex values, the implementation should just+"do the right thing".++>λ> express (MyTypeC False 789 [MyTypeA True, MyTypeB 33, MyTypeC True 12 []]) (MyTypeC True 987 [MyTypeA False, MyTypeB 11, MyTypeC True 3 []])+>MyTypeC True 789 [MyTypeA True,MyTypeB 11,MyTypeC True 3 []]++When a type has multiple constructors, the constructors that appear+earlier in the definition are dominant over those that appear later.+For example:++>λ> express (MyTypeA True) (MyTypeB 7)+>MyTypeA True++>λ> express (MyTypeB 4) (MyTypeC True 66 [])+>MyTypeB 4++-}++expressMaybe :: Diploid 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

@@ -1,47 +0,0 @@---------------------------------------------------------------------------- |--- 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--

@@ -12,8 +12,6 @@ -- to recombine \"genetic\" instructions for building artificial life. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax #-}- module ALife.Creatur.Genetics.Recombination   (     crossover,@@ -46,7 +44,7 @@ --     '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+--   If n <= 0 or m <= 0, the corresponding input list will be completely --   transferred to the other. --   @ --     /Expression/                               /Result/@@ -61,7 +59,7 @@ --     'cutAndSplice' 10 0 (\"abcdef\", \"ABCDEF\")   (\"abcdefABCDEF\",\"\") --     'cutAndSplice' 0 0 (\"\", \"ABCDEF\")          (\"ABCDEF\",\"\") --   @-cutAndSplice ∷ Int → Int → ([a], [a]) → ([a], [a])+cutAndSplice :: Int -> Int -> ([a], [a]) -> ([a], [a]) cutAndSplice n m (as, bs) = (cs, ds)     where cs = as1 ++ bs2           ds = bs1 ++ as2@@ -70,105 +68,105 @@  -- | Same as @'cutAndSplice'@, except that the two locations are --   chosen at random.-randomCutAndSplice ∷ (RandomGen g) ⇒ ([a], [a]) → Rand g ([a], [a])+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)+    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])+--   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 :: (RandomGen g) => ([a], [a]) -> Rand g ([a], [a]) randomCrossover (as, bs) = do-    n ← getRandomR (0,length as - 1)+    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 :: (Random n, RandomGen g) => [n] -> Rand g [n] mutateList xs = do-  (i, _) ← randomListSelection xs-  x ← getRandom+  (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 :: +  (Random n, RandomGen g) => ([n], [n]) -> Rand g ([n], [n]) mutatePairedLists (xs,ys) = do-  chooseFst ← weightedRandomBoolean 0.5+  chooseFst <- weightedRandomBoolean 0.5   if chooseFst      then do-      xs' ← mutateList xs+      xs' <- mutateList xs       return (xs', ys)     else do-      ys' ← mutateList ys+      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 :: RandomGen g => Double -> (b -> Rand g b) -> b -> Rand g b withProbability p op genes = do-  doOp ← weightedRandomBoolean p+  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 :: RandomGen g => Double -> (b -> Rand g b) -> b -> Rand g b repeatWithProbability p op genes = do-  doOp ← weightedRandomBoolean p+  doOp <- weightedRandomBoolean p   if doOp      then do-      genes' ← op genes+      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)+-- 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)+-- 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 :: (RandomGen g) => Double -> Rand g Bool weightedRandomBoolean p = do-  x ← getRandomR (0.0,1.0)+  x <- getRandomR (0.0,1.0)   return (x < p) -randomOneOfPair ∷ (RandomGen g) ⇒ (a, a) → Rand g a+randomOneOfPair :: (RandomGen g) => (a, a) -> Rand g a randomOneOfPair pair = do-  chooseFst ← weightedRandomBoolean 0.5+  chooseFst <- weightedRandomBoolean 0.5   if chooseFst      then return . fst $ pair     else return . snd $ pair -randomOneOfList ∷ (RandomGen g) ⇒ [a] → Rand g a+randomOneOfList :: (RandomGen g) => [a] -> Rand g a randomOneOfList xs = do-  (_, z) ← randomListSelection xs+  (_, 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 :: (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)))+--  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 :: (RandomGen g) => [a] -> Rand g (Int, a) randomListSelection xs = do-  i ← getRandomR (0,length xs - 1)+  i <- getRandomR (0,length xs - 1)   return (i, xs !! i) 

@@ -8,13 +8,16 @@ -- 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 #-}+{-# LANGUAGE TypeFamilies #-} module ALife.Creatur.Genetics.Reproduction.Asexual   (     Reproductive(..)@@ -27,31 +30,34 @@ --   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].+  -- | A sequence of hereditary information for an agent.   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]+  --+  --   1. 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+  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:+  --   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)+  --+  --   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+    g <- recombine a b     return $ build name g  

@@ -8,13 +8,16 @@ -- 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 #-}+{-# LANGUAGE TypeFamilies #-} module ALife.Creatur.Genetics.Reproduction.Sexual   (     Reproductive(..)@@ -27,32 +30,34 @@ --   its offspring. Minimal complete definition: all except @mate@. class Reproductive a where -  -- | The basic unit of hereditary information for an agent.+  -- | A sequence of hereditary information for an agent.   --   The type signature for the agent's genome is -  --   ([Base a], [Base a]).+  --   (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]+  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+  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:+  --   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)+  --+  --   1. Pairs the two strands to create a genome for the child.+  --+  --   1. 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+    ga <- produceGamete a+    gb <- produceGamete b     return $ build name (ga, gb) 

@@ -1,6 +1,6 @@ ------------------------------------------------------------------------ -- |--- Module      :  ALife.Creatur.Tools.Logger+-- Module      :  ALife.Creatur.Logger -- Copyright   :  (c) Amy de Buitléir 2011-2013 -- License     :  BSD-style -- Maintainer  :  amy@nualeargais.ie@@ -11,7 +11,6 @@ -- framework. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax    #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}  module ALife.Creatur.Logger@@ -24,23 +23,22 @@ 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 ()+  writeToLog :: String -> StateT l IO ()  -- | A rotating logger. data SimpleRotatingLogger = SimpleRotatingLogger {-    initialised ∷ Bool,-    directory ∷ FilePath,-    logFilename ∷ FilePath,-    expFilename ∷ FilePath,-    maxRecordsPerFile ∷ Int,-    recordCount ∷ Int+    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@@ -49,7 +47,7 @@ --   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 :: FilePath -> String -> Int -> SimpleRotatingLogger mkSimpleRotatingLogger d pre n = SimpleRotatingLogger False d fLog fExp n (-1)   where fLog = d ++ "/" ++ pre ++ ".log"         fExp = d ++ "/" ++ pre ++ ".exp"@@ -57,45 +55,45 @@ instance Logger SimpleRotatingLogger where   writeToLog msg = do     initIfNeeded-    logger ← get-    logger' ← liftIO $ bumpRecordCount logger+    logger <- get+    logger' <- liftIO $ bumpRecordCount logger     put logger'     liftIO $ write' logger' msg -initIfNeeded ∷ StateT SimpleRotatingLogger IO ()+initIfNeeded :: StateT SimpleRotatingLogger IO () initIfNeeded = do-  isInitialised ← gets initialised+  isInitialised <- gets initialised   unless isInitialised $ do-    logger ← get-    logger' ← liftIO $ initialise logger+    logger <- get+    logger' <- liftIO $ initialise logger     put logger' -initialise ∷ SimpleRotatingLogger → IO SimpleRotatingLogger+initialise :: SimpleRotatingLogger -> IO SimpleRotatingLogger initialise logger = do   createDirectoryIfMissing True (directory logger)   let fExp = expFilename logger-  expFileExists ← doesFileExist fExp+  expFileExists <- doesFileExist fExp   if expFileExists     then do-      s ← readFile fExp+      s <- readFile fExp       return $ logger { initialised=True, recordCount=read s}     else return $ logger { initialised=True, recordCount=0} -write' ∷ SimpleRotatingLogger → String → IO ()+write' :: SimpleRotatingLogger -> String -> IO () write' logger msg = do-  timestamp ←+  timestamp <-       fmap (formatTime defaultTimeLocale "%y%m%d%H%M%S%z") getZonedTime   appendFile (logFilename logger)     $ timestamp ++ "\t" ++ msg ++ "\n" -bumpRecordCount ∷ SimpleRotatingLogger → IO SimpleRotatingLogger+bumpRecordCount :: SimpleRotatingLogger -> IO SimpleRotatingLogger bumpRecordCount logger = do   let n = 1 + recordCount logger-  when (0 ≡ n `mod` maxRecordsPerFile logger) $ liftIO $ rotateLog logger+  when (0 == n `mod` maxRecordsPerFile logger) $ liftIO $ rotateLog logger   writeFile (expFilename logger) (show n)   return logger{ recordCount=n } -rotateLog ∷ SimpleRotatingLogger → IO ()+rotateLog :: SimpleRotatingLogger -> IO () rotateLog logger = do   let f = logFilename logger   renameFile f $ f ++ '.' : (show . recordCount) logger

@@ -7,11 +7,10 @@ -- Stability   :  experimental -- Portability :  portable ----- TODO: fill in+-- Provides a habitat for artificial life. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax, TemplateHaskell, TypeFamilies, -    FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, TypeFamilies, FlexibleContexts #-}  module ALife.Creatur.Universe  (@@ -47,55 +46,55 @@  -- | A habitat containing artificial life. data Universe c l d n x a = Universe {-    _clock ∷ c,-    _logger ∷ l,-    _agentDB ∷ d,-    _namer ∷ n,-    _extra ∷ x+    _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+instance (Clock c, Logger l) => Logger (Universe c l d n x a) where   writeToLog msg = do-    t ← currentTime+    t <- currentTime     zoom logger $ writeToLog $ show t ++ "\t" ++ msg -instance Clock c ⇒ Clock (Universe c l d n x a) where+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+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 :: 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 :: (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+  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 :: +  (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 :: (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 :: 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

@@ -7,10 +7,14 @@ -- Stability   :  experimental -- Portability :  portable ----- TODO: fill in+-- Provides tasks that you can use with a daemon. These tasks handle+-- reading and writing agents, which reduces the amount of code you+-- need to write.  --+-- It’s also easy to write your own tasks, using these as a guide.)+-- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}  module ALife.Creatur.Universe.Task  (@@ -39,13 +43,11 @@ 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 :: Logger u => Daemon u simpleDaemon = Daemon   {     onStartup = startupHandler,@@ -56,47 +58,47 @@     sleepTime = 100000   } -startupHandler ∷ Logger u ⇒ u → IO u+startupHandler :: Logger u => u -> IO u startupHandler = execStateT (writeToLog "Starting") -shutdownHandler ∷ Logger u ⇒ u → IO ()+shutdownHandler :: Logger u => u -> IO () shutdownHandler u = do-  _ ← execStateT (writeToLog "Shutdown requested") u+  _ <- execStateT (writeToLog "Shutdown requested") u   return () -exceptionHandler ∷ Logger u ⇒ u → SomeException → IO u+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+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 → +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+  (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 → +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+  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 :: (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+  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)+  --      (when (currentTime logger `mod` 1000 == 0) $ logStats universe logger)   mapM_ (withAgent agentProgram) xs'   zoom clock incTime @@ -116,34 +118,34 @@ --   (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]+  [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] →+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+  (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] →+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)+  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 :: (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+  xs <- agentIds+  xs' <- liftIO $ evalRandIO $ shuffle xs   mapM_ (withAgents agentsProgram) $ makeViews xs'   zoom clock incTime -makeViews ∷ [a] → [[a]]+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))+  where f (n,xs) = if n == length xs then Nothing else Just (rotate xs,(n+1,rotate xs)) 

@@ -10,50 +10,55 @@ -- Utility functions that don't fit anywhere else. -- -------------------------------------------------------------------------{-# LANGUAGE UnicodeSyntax #-}- module ALife.Creatur.Util   (---    constrain,-    cropRect,-    cropSquare,-    perfectSquare,+    -- * Integers     ilogBase,     isPowerOf,     isqrt,+    perfectSquare,+    -- * Arrays+    cropRect,+    cropSquare,+    -- * Sequences     replaceElement,     reverseLookup,     rotate,     safeReplaceElement,     shuffle,+    -- * Bits/Booleans+    boolsToBits,+    showBin,+    -- * Monads     stateMap+--    constrain,   ) 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.Char (intToDigit) import Data.List.Split (chunksOf)-import Data.Ord.Unicode ((≤), (≥)) import GHC.Arr (elems, listArray, readSTArray, thawSTArray, writeSTArray)+import Numeric (showIntAtBase) --- constrain ∷ Ord a ⇒ (a, a) → a → a+-- 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 :: RandomGen g => [a] -> Rand g [a] shuffle xs = do   let l = length xs-  rands ← take l `fmap` getRandomRs (0, l-1)+  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+      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'@@ -61,18 +66,18 @@  -- | @'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 :: [a] -> Int -> a -> [a] safeReplaceElement xs i x =-  if i ≥ 0 && i < length xs+  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 :: [a] -> Int -> a -> [a] replaceElement xs i x = -  if 0 ≤ i && i < length xs then fore ++ (x : aft) else xs+  if 0 <= i && i < length xs then fore ++ (x : aft) else xs   where fore = take i xs         aft = drop (i+1) xs @@ -85,7 +90,7 @@ -- -- > a b c d e -- > f g h i j            g h i--- > k l m n o    --→    l m n+-- > k l m n o    --->    l m n -- > p q r s t            q r s -- > u v w x y --@@ -94,8 +99,8 @@ --   @[\'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     = []+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@@ -112,7 +117,7 @@ --   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+-- > g h i j k l    --->   i j k -- > m n o p q r           o p q -- > s t u v w x --@@ -121,50 +126,57 @@ --   @[\'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 :: (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+  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 :: 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 :: (Integral a, Integral b) => a -> b isqrt n = (floor . sqrt) n'-  where n' = fromIntegral n ∷ Float+  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 :: (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+  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+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+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 :: (Eq b) => b -> [(a,b)] -> Maybe a reverseLookup _ []          =  Nothing reverseLookup value ((x,y):xys)-    | value ≡ y =  Just x+    | value == y =  Just x     | otherwise  =  reverseLookup value xys -stateMap ∷ Monad m ⇒ (s → t) → (t → s) → StateT s m a → StateT t m a+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 :: [a] -> [a] rotate [] = [] rotate (x:xs) = xs ++ [x] +-- | Convert a list of bits to a string of @0@s and @1@s.+boolsToBits :: [Bool] -> String+boolsToBits = map (\b -> if b then '1' else '0')++-- | Show /non-negative/ 'Integral' numbers in binary.+showBin :: (Integral a,Show a) => a -> ShowS+showBin = showIntAtBase 2 intToDigit

@@ -1,4 +1,16 @@-{-# LANGUAGE UnicodeSyntax, DeriveGeneric #-}+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Database.FileSystemQC+-- 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.Database.FileSystemQC   (@@ -24,18 +36,18 @@  instance Serialize TestRecord -tryStoreLookup ∷ FilePath → IO ()+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'+  db' <- execStateT (store record) db+  Right record' <- evalStateT (lookup (key record)) db'   assertEqual "wombat" record record' -testStoreLookup ∷ IO ()+testStoreLookup :: IO () testStoreLookup = withSystemTempDirectory "creaturTest.tmp" tryStoreLookup -test ∷ TF.Test+test :: TF.Test test = testGroup "HUnit ALife.Creatur.Database.FileSystemQC"   [     testCase "store and lookup"

@@ -0,0 +1,71 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.BRGCBoolQC+-- Copyright   :  (c) Amy de Buitléir 2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------+{-# LANGUAGE DeriveGeneric, FlexibleInstances #-}+module ALife.Creatur.Genetics.BRGCBoolQC+  (+    test+  ) where++import Prelude hiding (read)+import ALife.Creatur.Genetics.BRGCBool+import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)+import GHC.Generics (Generic)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary, Gen, Property, arbitrary, choose,+  oneof, property, sized, vectorOf)++prop_round_trippable :: (Eq g, Genetic g) => g -> Property+prop_round_trippable g = property $ g' == Just g+  where x = write g+        g' = read x++data TestStructure = A | B Bool | C Word8 | D Word16 Char | E [TestStructure]+  deriving (Show, Eq, Generic)++instance Genetic TestStructure++sizedArbTestStructure :: Int -> Gen TestStructure+sizedArbTestStructure 0 =+  oneof [ return A, B <$> arbitrary, C <$> arbitrary,+          D <$> arbitrary <*> arbitrary]+sizedArbTestStructure n = do+  k <- choose (0,min 8 (n-1))+  oneof [+          return A,+          B <$> arbitrary,+          C <$> arbitrary,+          D <$> arbitrary <*> arbitrary,+          E <$> vectorOf k (sizedArbTestStructure (n-1))+        ]+  +instance Arbitrary TestStructure where+  arbitrary = sized sizedArbTestStructure+              +test :: Test+test = testGroup "ALife.Creatur.Genetics.BRGCBoolQC"+  [+    testProperty "prop_encoding_round_trippable - Bool"+      (prop_round_trippable :: Bool -> Property),+    testProperty "prop_encoding_round_trippable - Char"+      (prop_round_trippable :: Char -> Property),+    testProperty "prop_encoding_round_trippable - Word8"+      (prop_round_trippable :: Word8 -> Property),+    testProperty "prop_encoding_round_trippable - Word16"+      (prop_round_trippable :: Word16 -> Property),+    testProperty "prop_encoding_round_trippable - TestStructure"+      (prop_round_trippable :: TestStructure -> Property)+  ]++

@@ -0,0 +1,71 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.BRGCWord8QC+-- Copyright   :  (c) Amy de Buitléir 2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------+{-# LANGUAGE DeriveGeneric, FlexibleInstances #-}+module ALife.Creatur.Genetics.BRGCWord8QC+  (+    test+  ) where++import Prelude hiding (read)+import ALife.Creatur.Genetics.BRGCWord8+import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)+import GHC.Generics (Generic)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary, Gen, Property, arbitrary, choose,+  oneof, property, sized, vectorOf)++prop_round_trippable :: (Eq g, Genetic g) => g -> Property+prop_round_trippable g = property $ g' == Just g+  where x = write g+        g' = read x++data TestStructure = A | B Bool | C Word8 | D Word16 Char | E [TestStructure]+  deriving (Show, Eq, Generic)++instance Genetic TestStructure++sizedArbTestStructure :: Int -> Gen TestStructure+sizedArbTestStructure 0 =+  oneof [ return A, B <$> arbitrary, C <$> arbitrary,+          D <$> arbitrary <*> arbitrary]+sizedArbTestStructure n = do+  k <- choose (0,min 8 (n-1))+  oneof [+          return A,+          B <$> arbitrary,+          C <$> arbitrary,+          D <$> arbitrary <*> arbitrary,+          E <$> vectorOf k (sizedArbTestStructure (n-1))+        ]+  +instance Arbitrary TestStructure where+  arbitrary = sized sizedArbTestStructure+              +test :: Test+test = testGroup "ALife.Creatur.Genetics.BRGCWord8QC"+  [+    testProperty "prop_encoding_round_trippable - Bool"+      (prop_round_trippable :: Bool -> Property),+    testProperty "prop_encoding_round_trippable - Char"+      (prop_round_trippable :: Char -> Property),+    testProperty "prop_encoding_round_trippable - Word8"+      (prop_round_trippable :: Word8 -> Property),+    testProperty "prop_encoding_round_trippable - Word16"+      (prop_round_trippable :: Word16 -> Property),+    testProperty "prop_encoding_round_trippable - TestStructure"+      (prop_round_trippable :: TestStructure -> Property)+  ]++

@@ -1,85 +1,72 @@-{-# LANGUAGE UnicodeSyntax #-}-+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.CodeQC+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------ 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)+-- Guaranteed not to have multiple values for the same code (but might+-- have multiple codes for the same value). Compare with TestCode2. data TestCode = TestCode (Code Char Bool) deriving Show -sizedArbTestCode ∷ Int → Gen TestCode+sizedArbTestCode :: Int -> Gen TestCode sizedArbTestCode n = do-  cs ← vectorOf n arbitrary-  xs ← vectorOf n arbitrary+  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 -> Char -> Property prop_encoding_round_trippable (TestCode g) c =-  property $ maybe Nothing (decode g) (encode g c) ≡ 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+-- Guaranteed not to have multiple values for the same code, or multiple+-- codes for the same value. Compare with TestCode. data TestCode2 = TestCode2 (Code Char Bool) deriving Show -sizedArbTestCode2 ∷ Int → Gen TestCode2+sizedArbTestCode2 :: Int -> Gen TestCode2 sizedArbTestCode2 n = do-  cs ← vectorOf n arbitrary-  xs ← vectorOf n arbitrary+  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 -> [Bool] -> Property prop_decoding_round_trippable (TestCode2 g) x =-  property $ maybe Nothing (encode g) (decode g x) ≡ 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 :: 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+      prop_decoding_round_trippable   ]  

@@ -1,32 +0,0 @@-{-# 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,60 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.DiploidQC+-- Copyright   :  (c) Amy de Buitléir 2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------+{-# LANGUAGE DeriveGeneric, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ALife.Creatur.Genetics.DiploidQC+  (+    test+  ) where++import ALife.Creatur.Genetics.Diploid+import Control.Applicative ((<$>), (<*>))+import GHC.Generics (Generic)+import Test.Framework as TF (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary, Gen, Property, arbitrary, choose,+  oneof, property, sized, vectorOf)++data TestStructure = A | B Bool | C Int | D Bool Char | E [TestStructure]+  deriving (Show, Eq, Generic)++instance Diploid TestStructure++sizedArbTestStructure :: Int -> Gen TestStructure+sizedArbTestStructure 0 =+  oneof [ return A, B <$> arbitrary, C <$> arbitrary,+          D <$> arbitrary <*> arbitrary]+sizedArbTestStructure n = do+  k <- choose (0,min 8 (n-1))+  oneof [+          return A,+          B <$> arbitrary,+          C <$> arbitrary,+          D <$> arbitrary <*> arbitrary,+          E <$> vectorOf k (sizedArbTestStructure (n-1))+        ]+  +instance Arbitrary TestStructure where+  arbitrary = sized sizedArbTestStructure++prop_identity :: TestStructure -> Property+prop_identity g = property $ express g g == g+++test :: Test+test = testGroup "ALife.Creatur.Genetics.DiploidQC"+  [+    testProperty "prop_identity" prop_identity+  ]++

@@ -0,0 +1,41 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.RecombinationQC+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------+module ALife.Creatur.Genetics.RecombinationQC+  (+    test+  ) where++import ALife.Creatur.Genetics.Recombination (crossover, cutAndSplice)+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.RecombinationQC"+  [+    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+  ]

@@ -1,5 +1,15 @@-{-# LANGUAGE UnicodeSyntax #-}-+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.UtilQC+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- QuickCheck tests.+--+------------------------------------------------------------------------ module ALife.Creatur.UtilQC   (     test@@ -8,75 +18,73 @@ 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+-- 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+-- 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 ::+  (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+    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+        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+        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 :: 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 :: Int -> String -> Property prop_cropSquare_returns_correct_size n xs =-    property $ length xs' ≡ expectedSize+    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 :: 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+      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 :: String -> Int -> Char -> Property prop_safeReplaceElement_doesnt_change_length cs i c =-  property $ length cs ≡ length (safeReplaceElement 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 ::+  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+      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'+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 :: Test test = testGroup "QuickCheck ALife.Creatur.UtilQC"   [ --    testProperty "prop_constrain_obeys_bounds"

@@ -1,21 +1,38 @@-{-# LANGUAGE UnicodeSyntax #-}+------------------------------------------------------------------------+-- |+-- Module      :  Main+-- Copyright   :  (c) Amy de Buitléir 2012-2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- Runs the QuickCheck tests.+--+------------------------------------------------------------------------ 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 ALife.Creatur.Genetics.DiploidQC (test)+import ALife.Creatur.Genetics.RecombinationQC (test)+import ALife.Creatur.Genetics.BRGCBoolQC (test)+import ALife.Creatur.Genetics.BRGCWord8QC (test)  import Test.Framework as TF (defaultMain, Test) -tests ∷ [TF.Test]+tests :: [TF.Test] tests =    [      ALife.Creatur.Database.FileSystemQC.test,     ALife.Creatur.UtilQC.test,     ALife.Creatur.Genetics.CodeQC.test,-    ALife.Creatur.Genetics.CrossoverQC.test+    ALife.Creatur.Genetics.DiploidQC.test,+    ALife.Creatur.Genetics.RecombinationQC.test,+    ALife.Creatur.Genetics.BRGCBoolQC.test,+    ALife.Creatur.Genetics.BRGCWord8QC.test   ] -main ∷ IO ()+main :: IO () main = defaultMain tests