diff --git a/creatur.cabal b/creatur.cabal --- a/creatur.cabal +++ b/creatur.cabal @@ -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 diff --git a/src/ALife/Creatur.hs b/src/ALife/Creatur.hs --- a/src/ALife/Creatur.hs +++ b/src/ALife/Creatur.hs @@ -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 diff --git a/src/ALife/Creatur/AgentNamer.hs b/src/ALife/Creatur/AgentNamer.hs --- a/src/ALife/Creatur/AgentNamer.hs +++ b/src/ALife/Creatur/AgentNamer.hs @@ -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 diff --git a/src/ALife/Creatur/Clock.hs b/src/ALife/Creatur/Clock.hs --- a/src/ALife/Creatur/Clock.hs +++ b/src/ALife/Creatur/Clock.hs @@ -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 () diff --git a/src/ALife/Creatur/Counter.hs b/src/ALife/Creatur/Counter.hs --- a/src/ALife/Creatur/Counter.hs +++ b/src/ALife/Creatur/Counter.hs @@ -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 } diff --git a/src/ALife/Creatur/Daemon.hs b/src/ALife/Creatur/Daemon.hs --- a/src/ALife/Creatur/Daemon.hs +++ b/src/ALife/Creatur/Daemon.hs @@ -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 () diff --git a/src/ALife/Creatur/Database.hs b/src/ALife/Creatur/Database.hs --- a/src/ALife/Creatur/Database.hs +++ b/src/ALife/Creatur/Database.hs @@ -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 () diff --git a/src/ALife/Creatur/Database/FileSystem.hs b/src/ALife/Creatur/Database/FileSystem.hs --- a/src/ALife/Creatur/Database/FileSystem.hs +++ b/src/ALife/Creatur/Database/FileSystem.hs @@ -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", ".", ".." ] diff --git a/src/ALife/Creatur/Genetics/BRGCBool.hs b/src/ALife/Creatur/Genetics/BRGCBool.hs new file mode 100644 --- /dev/null +++ b/src/ALife/Creatur/Genetics/BRGCBool.hs @@ -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 diff --git a/src/ALife/Creatur/Genetics/BRGCWord8.hs b/src/ALife/Creatur/Genetics/BRGCWord8.hs new file mode 100644 --- /dev/null +++ b/src/ALife/Creatur/Genetics/BRGCWord8.hs @@ -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 diff --git a/src/ALife/Creatur/Genetics/Code.hs b/src/ALife/Creatur/Genetics/Code.hs --- a/src/ALife/Creatur/Genetics/Code.hs +++ b/src/ALife/Creatur/Genetics/Code.hs @@ -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 diff --git a/src/ALife/Creatur/Genetics/CodeInternal.hs b/src/ALife/Creatur/Genetics/CodeInternal.hs deleted file mode 100644 --- a/src/ALife/Creatur/Genetics/CodeInternal.hs +++ /dev/null @@ -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 - - diff --git a/src/ALife/Creatur/Genetics/Diploid.hs b/src/ALife/Creatur/Genetics/Diploid.hs new file mode 100644 --- /dev/null +++ b/src/ALife/Creatur/Genetics/Diploid.hs @@ -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 diff --git a/src/ALife/Creatur/Genetics/Gene.hs b/src/ALife/Creatur/Genetics/Gene.hs deleted file mode 100644 --- a/src/ALife/Creatur/Genetics/Gene.hs +++ /dev/null @@ -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 - - diff --git a/src/ALife/Creatur/Genetics/Recombination.hs b/src/ALife/Creatur/Genetics/Recombination.hs --- a/src/ALife/Creatur/Genetics/Recombination.hs +++ b/src/ALife/Creatur/Genetics/Recombination.hs @@ -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) diff --git a/src/ALife/Creatur/Genetics/Reproduction/Asexual.hs b/src/ALife/Creatur/Genetics/Reproduction/Asexual.hs --- a/src/ALife/Creatur/Genetics/Reproduction/Asexual.hs +++ b/src/ALife/Creatur/Genetics/Reproduction/Asexual.hs @@ -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 diff --git a/src/ALife/Creatur/Genetics/Reproduction/Sexual.hs b/src/ALife/Creatur/Genetics/Reproduction/Sexual.hs --- a/src/ALife/Creatur/Genetics/Reproduction/Sexual.hs +++ b/src/ALife/Creatur/Genetics/Reproduction/Sexual.hs @@ -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) diff --git a/src/ALife/Creatur/Logger.hs b/src/ALife/Creatur/Logger.hs --- a/src/ALife/Creatur/Logger.hs +++ b/src/ALife/Creatur/Logger.hs @@ -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 diff --git a/src/ALife/Creatur/Universe.hs b/src/ALife/Creatur/Universe.hs --- a/src/ALife/Creatur/Universe.hs +++ b/src/ALife/Creatur/Universe.hs @@ -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 diff --git a/src/ALife/Creatur/Universe/Task.hs b/src/ALife/Creatur/Universe/Task.hs --- a/src/ALife/Creatur/Universe/Task.hs +++ b/src/ALife/Creatur/Universe/Task.hs @@ -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)) diff --git a/src/ALife/Creatur/Util.hs b/src/ALife/Creatur/Util.hs --- a/src/ALife/Creatur/Util.hs +++ b/src/ALife/Creatur/Util.hs @@ -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 -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 diff --git a/test/ALife/Creatur/Database/FileSystemQC.hs b/test/ALife/Creatur/Database/FileSystemQC.hs --- a/test/ALife/Creatur/Database/FileSystemQC.hs +++ b/test/ALife/Creatur/Database/FileSystemQC.hs @@ -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" diff --git a/test/ALife/Creatur/Genetics/BRGCBoolQC.hs b/test/ALife/Creatur/Genetics/BRGCBoolQC.hs new file mode 100644 --- /dev/null +++ b/test/ALife/Creatur/Genetics/BRGCBoolQC.hs @@ -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) + ] + + diff --git a/test/ALife/Creatur/Genetics/BRGCWord8QC.hs b/test/ALife/Creatur/Genetics/BRGCWord8QC.hs new file mode 100644 --- /dev/null +++ b/test/ALife/Creatur/Genetics/BRGCWord8QC.hs @@ -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) + ] + + diff --git a/test/ALife/Creatur/Genetics/CodeQC.hs b/test/ALife/Creatur/Genetics/CodeQC.hs --- a/test/ALife/Creatur/Genetics/CodeQC.hs +++ b/test/ALife/Creatur/Genetics/CodeQC.hs @@ -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 ] diff --git a/test/ALife/Creatur/Genetics/CrossoverQC.hs b/test/ALife/Creatur/Genetics/CrossoverQC.hs deleted file mode 100644 --- a/test/ALife/Creatur/Genetics/CrossoverQC.hs +++ /dev/null @@ -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 - ] diff --git a/test/ALife/Creatur/Genetics/DiploidQC.hs b/test/ALife/Creatur/Genetics/DiploidQC.hs new file mode 100644 --- /dev/null +++ b/test/ALife/Creatur/Genetics/DiploidQC.hs @@ -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 + ] + + diff --git a/test/ALife/Creatur/Genetics/RecombinationQC.hs b/test/ALife/Creatur/Genetics/RecombinationQC.hs new file mode 100644 --- /dev/null +++ b/test/ALife/Creatur/Genetics/RecombinationQC.hs @@ -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 + ] diff --git a/test/ALife/Creatur/UtilQC.hs b/test/ALife/Creatur/UtilQC.hs --- a/test/ALife/Creatur/UtilQC.hs +++ b/test/ALife/Creatur/UtilQC.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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