packages feed

creatur 3.0.0 → 4.1.4

raw patch · 16 files changed

+366/−133 lines, 16 filesdep ~cereal

Dependency ranges changed: cereal

Files

creatur.cabal view
@@ -1,5 +1,5 @@ Name:              creatur-Version:           3.0.0+Version:           4.1.4 Stability:         experimental Synopsis:          Framework for artificial life experiments. Description:       A software framework for automating experiments@@ -38,6 +38,7 @@                     ALife.Creatur.Daemon,                     ALife.Creatur.Database,                     ALife.Creatur.Database.FileSystem,+                    ALife.Creatur.Genetics.Analysis,                     ALife.Creatur.Genetics.Code,                     ALife.Creatur.Genetics.BRGCBool,                     ALife.Creatur.Genetics.BRGCWord8,@@ -53,7 +54,7 @@                     array ==0.4.*,                     base ==4.*,                     bytestring ==0.10.*,-                    cereal ==0.3.*,+                    cereal ==0.3.* || ==0.4.*,                     directory ==1.2.*,                     gray-extended ==1.*,                     hdaemonize ==0.4.*,@@ -79,7 +80,7 @@                     array ==0.4.*,                     base ==4.*,                     binary == 0.5.*,-                    cereal ==0.3.*,+                    cereal ==0.3.* || ==0.4.*,                     creatur,                     hmatrix ==0.14.*,                     HUnit ==1.2.*,
src/ALife/Creatur/Counter.hs view
@@ -18,19 +18,21 @@   ) where  import ALife.Creatur.Clock (Clock, currentTime, incTime)+import ALife.Creatur.Util (modifyLift, getLift) import Control.Monad (unless)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State (StateT, get, gets, modify, put)+import Control.Monad.State (StateT, gets, modify) import System.Directory (doesFileExist)+import System.IO (hGetContents, withFile, Handle, IOMode(ReadMode))+import Text.Read (readEither)  class Counter c where   current :: StateT c IO Int   increment :: StateT c IO ()  data PersistentCounter = PersistentCounter {-    initialised :: Bool,-    time :: Int,-    filename :: FilePath+    cInitialised :: Bool,+    cValue :: Int,+    cFilename :: FilePath   } deriving Show  -- | Creates a counter that will store its value in the specified file.@@ -38,35 +40,39 @@ mkPersistentCounter = PersistentCounter False (-1)  instance Counter PersistentCounter where-  current = do-    initIfNeeded-    gets time+  current = initIfNeeded >> gets cValue   increment = do-    t <- current-    let t' = t + 1-    f <- gets filename-    modify (\c -> c { time=t' })-    liftIO $ writeFile f $ show t'+    modify (\c -> c { cValue=1 + cValue c })+    getLift store +store :: PersistentCounter -> IO ()+store counter = writeFile (cFilename counter) $ show (cValue counter)+   initIfNeeded :: StateT PersistentCounter IO () initIfNeeded = do-  isInitialised <- gets initialised-  unless isInitialised $ do-    counter <- get-    counter' <- liftIO $ initialise counter-    put counter'+  isInitialised <- gets cInitialised+  unless isInitialised $ modifyLift initialise  initialise :: PersistentCounter -> IO PersistentCounter initialise counter = do-  let f = filename counter+  let f = cFilename counter   fExists <- doesFileExist f   if fExists     then do-      s <- readFile f-      return $ counter { initialised=True, time=read s }-    else return $ counter { initialised=True, time=0 }+      x <- withFile f ReadMode readCounter -- closes file ASAP+      case x of+        Left msg -> error $ "Unable to read counter from " ++ f ++ ": " ++ msg+        Right c  -> return $ counter { cInitialised=True, cValue=c }+    else return $ counter { cInitialised=True, cValue=0 }  instance Clock PersistentCounter where   currentTime = current   incTime = increment +readCounter :: Handle -> IO (Either String Int)+readCounter h = do+  s <- hGetContents h+  let x = readEither s :: Either String Int+  case x of+    Left msg -> return $ Left (msg ++ "\"" ++ s ++ "\"")+    Right c  -> return $ Right c
src/ALife/Creatur/Daemon.hs view
@@ -21,8 +21,9 @@  import Control.Concurrent (MVar, newMVar, readMVar, swapMVar,    threadDelay)-import Control.Exception (SomeException, handle)+import Control.Exception (SomeException, handle, catch) import Control.Monad.State (StateT, execStateT)+import System.IO (hPutStr, stderr) import System.IO.Unsafe (unsafePerformIO) import System.Posix.Daemonize (CreateDaemon(..), serviced, simpleDaemon) import System.Posix.Signals (Handler(Catch), fullSignalSet, @@ -68,7 +69,7 @@ daemonMain d s _ = do   s' <- onStartup d s   _ <- installHandler sigTERM (Catch handleTERM) (Just fullSignalSet)-  _ <- daemonMainLoop d s'+  _ <- wrap (daemonMainLoop d s')   return ()  daemonMainLoop :: Daemon s -> s -> IO ()@@ -80,6 +81,13 @@     else do       s' <- handle (onException d s) $ execStateT (task d) s       daemonMainLoop d s'++wrap :: IO () -> IO ()+wrap t = catch t+  (\e -> do+     let err = show (e :: SomeException)+     hPutStr stderr ("Warning: " ++ err)+     return ())  handleTERM :: IO () handleTERM = do
src/ALife/Creatur/Database.hs view
@@ -27,10 +27,16 @@ -- | A database offering storage and retrieval for records. class Database d where   type DBRecord d-  -- | Get a list of all keys in the database.+  -- | Get a list of all active keys in the database.   keys :: StateT d IO [String]-  -- | Read a record from the database.+  -- | Get a list of all archived keys in the database. If the database+  --   does not implement archiving, it may return an empty list.+  archivedKeys :: StateT d IO [String]+  -- | Read an active record from the database.   lookup :: Serialize (DBRecord d) => +    String -> StateT d IO (Either String (DBRecord d))+  -- | Read an archived record from the database.+  lookupInArchive :: 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.
src/ALife/Creatur/Database/FileSystem.hs view
@@ -18,12 +18,14 @@     mkFSDatabase   ) where +import Prelude hiding (readFile, writeFile)+ import ALife.Creatur.Database (Database(..), DBRecord, Record,    delete, key, keys, store)-import Prelude hiding (readFile, writeFile)+import ALife.Creatur.Util (modifyLift) import Control.Monad (unless, when) import Control.Monad.IO.Class (liftIO)-import Control.Monad.State (StateT, get, gets, put)+import Control.Monad.State (StateT, gets) import Data.ByteString as BS (readFile, writeFile) import qualified Data.Serialize as DS    (Serialize, decode, encode)@@ -42,18 +44,14 @@ instance Database (FSDatabase r) where   type DBRecord (FSDatabase r) = r -  keys = do-    initIfNeeded-    d <- gets mainDir-    files <- liftIO $ getDirectoryContents d-    return $ filter isRecordFileName files+  keys = keysIn mainDir -  lookup k = do-    initIfNeeded-    d <- gets mainDir-    let f = d ++ '/':k-    liftIO $ readRecord3 f+  archivedKeys = keysIn archiveDir +  lookup k = k `lookupIn` mainDir++  lookupInArchive k = k `lookupIn` archiveDir+   store r = do     initIfNeeded     writeRecord2 mainDir r@@ -63,6 +61,25 @@     fileExists <- liftIO $ doesFileExist name     when fileExists $ liftIO $ removeFile name +keysIn+  :: (FSDatabase r -> FilePath) -> StateT (FSDatabase r) IO [String]+keysIn x = do+    initIfNeeded+    d <- gets x+    files <- liftIO $ getDirectoryContents d+    return $ filter isRecordFileName files++lookupIn+  :: DS.Serialize r =>+     String+     -> (FSDatabase r -> FilePath)+     -> StateT (FSDatabase r) IO (Either String r)+lookupIn k x = do+    initIfNeeded+    d <- gets x+    let f = d ++ '/':k+    liftIO $ readRecord3 f+   -- | @'mkFSDatabase' d@ (re)creates the FSDatabase in the --   directory @d@. mkFSDatabase :: FilePath -> FSDatabase r@@ -71,10 +88,7 @@ initIfNeeded :: StateT (FSDatabase r) IO () initIfNeeded = do   isInitialised <- gets initialised-  unless isInitialised $ do-    u <- get-    u' <- liftIO $ initialise u-    put u'+  unless isInitialised $ modifyLift initialise  initialise :: FSDatabase r -> IO (FSDatabase r) initialise u = do
+ src/ALife/Creatur/Genetics/Analysis.hs view
@@ -0,0 +1,76 @@+------------------------------------------------------------------------+-- |+-- Module      :  ALife.Creatur.Genetics.Analysis+-- Copyright   :  (c) Amy de Buitléir 2013+-- License     :  BSD-style+-- Maintainer  :  amy@nualeargais.ie+-- Stability   :  experimental+-- Portability :  portable+--+-- ???+--+------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,+    DefaultSignatures, DeriveGeneric, TypeOperators #-}+module ALife.Creatur.Genetics.Analysis+  (+    Analysable(..)+  ) where++import Data.Word (Word8, Word16)+import GHC.Generics++class Analysable g where+  -- | Writes a gene to a sequence.+  analyse :: g -> String++  default analyse :: (Generic g, GAnalysable (Rep g)) => g -> String+  analyse = ganalyse . from++class GAnalysable f where+  ganalyse :: f a -> String++-- | Unit: used for constructors without arguments+instance GAnalysable U1 where+  ganalyse U1 = "U1 "++-- | Constants, additional parameters and recursion of kind *+instance (GAnalysable a, GAnalysable b) => GAnalysable (a :*: b) where+  ganalyse (a :*: b) = ganalyse a ++ ":*: " ++ ganalyse b++-- | Meta-information (constructor names, etc.)+instance (GAnalysable a, GAnalysable b) => GAnalysable (a :+: b) where+  ganalyse (L1 x) = "L1 " ++ ganalyse x+  ganalyse (R1 x) = "R1 " ++ ganalyse x++-- | Sums: encode choice between constructors+instance (GAnalysable a) => GAnalysable (M1 i c a) where+  ganalyse (M1 x) = "M1 " ++ ganalyse x++-- | Products: encode multiple arguments to constructors+instance (Analysable a) => GAnalysable (K1 i a) where+  ganalyse (K1 x) = "K1 " ++ analyse x++--+-- Instances+--++instance Analysable Bool where+  analyse x = show x ++ " "++instance Analysable Char where+  analyse x = show x ++ " "++instance Analysable Word8 where+  analyse x = show x ++ " "++instance Analysable Word16 where+  analyse x = show x ++ " "++instance (Analysable a) => Analysable [a]++instance (Analysable a) => Analysable (Maybe a)++instance (Analysable a, Analysable b) => Analysable (a, b)++instance (Analysable a, Analysable b) => Analysable (Either a b)
src/ALife/Creatur/Genetics/BRGCBool.hs view
@@ -45,6 +45,7 @@  import Prelude hiding (read) import ALife.Creatur.Genetics.Diploid (Diploid, express)+import ALife.Creatur.Util (fromEither) import Codec.Gray (integralToGray, grayToIntegral) import Control.Applicative ((<$>), (<*>)) import Control.Monad (replicateM)@@ -52,7 +53,6 @@ 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)@@ -69,7 +69,7 @@  type Reader = StateT (Sequence, Int) Identity -read :: Genetic g => Sequence -> Maybe g+read :: Genetic g => Sequence -> Either [String] g read s = evalState get (s, 0)  runReader :: Reader g -> Sequence -> g@@ -99,24 +99,24 @@   put = gput . from    -- | Reads the next gene in a sequence.-  get :: Reader (Maybe g)+  get :: Reader (Either [String] g) -  default get :: (Generic g, GGenetic (Rep g)) => Reader (Maybe g)+  default get :: (Generic g, GGenetic (Rep g)) => Reader (Either [String] g)   get = do     a <- gget     return . fmap to $ a    getWithDefault :: g -> Reader g-  getWithDefault d = fmap (fromMaybe d) get+  getWithDefault d = fmap (fromEither d) get  class GGenetic f where   gput :: f a -> Writer ()-  gget :: Reader (Maybe (f a))+  gget :: Reader (Either [String] (f a))  -- | Unit: used for constructors without arguments instance GGenetic U1 where   gput U1 = return ()-  gget = return (Just U1)+  gget = return (Right U1)  -- | Constants, additional parameters and recursion of kind * instance (GGenetic a, GGenetic b) => GGenetic (a :*: b) where@@ -132,9 +132,10 @@   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+    case a of+      Right True  -> fmap (fmap L1) gget+      Right False -> fmap (fmap R1) gget+      Left s -> return (Left s)  -- | Sums: encode choice between constructors instance (GGenetic a) => GGenetic (M1 i c a) where@@ -160,11 +161,11 @@     (xs, i) <- S.get     let xs' = drop i xs     if null xs'-       then return Nothing+       then return $ Left ["End of sequence"]        else do          let x = head xs'          S.put (xs, i+1)-         return $ Just x+         return $ Right x  instance Genetic Char where   put = putRawBoolArray . intToBools 8 . ord@@ -184,6 +185,11 @@  instance (Genetic a) => Genetic (Maybe a) +instance (Genetic a, Genetic b) => Genetic (a, b)++instance (Genetic a, Genetic b) => Genetic (Either a b)++ -- -- Utilities --@@ -192,7 +198,7 @@ putRawBoolArray :: [Bool] -> Writer () putRawBoolArray = mapM_ put -getRawBoolArray :: Int -> Reader (Maybe [Bool])+getRawBoolArray :: Int -> Reader (Either [String] [Bool]) getRawBoolArray n = do   xs <- replicateM n get   return . sequence $ xs@@ -216,7 +222,7 @@  type DiploidReader = StateT ((Sequence, Int), (Sequence, Int)) Identity -readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Maybe g+readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Either [String] g readAndExpress (s1, s2) = evalState getAndExpress ((s1, 0), (s2, 0))  runDiploidReader :: DiploidReader g -> DiploidSequence -> g@@ -242,19 +248,23 @@ --   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 :: (Genetic g, Diploid g) => DiploidReader (Either [String] 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+  return $ expressEither a b  getAndExpressWithDefault :: (Genetic g, Diploid g) => g -> DiploidReader g-getAndExpressWithDefault d = fmap (fromMaybe d) getAndExpress+getAndExpressWithDefault d = fmap (fromEither 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+expressEither+  :: Diploid g+    => Either [String] g -> Either [String] g+      -> Either [String] g+expressEither (Right a) (Right b) = Right (express a b)+expressEither (Right a) (Left _)  = Right a+expressEither (Left _)  (Right b) = Right b+expressEither (Left xs) (Left ys) =+  Left $ (map ("sequence 1: " ++) xs) ++ (map ("sequence 2: " ++) ys)
src/ALife/Creatur/Genetics/BRGCWord8.hs view
@@ -42,18 +42,20 @@     copy2,     consumed2,     putRawWord8,-    getRawWord8+    getRawWord8,+    putRawWord8s,+    getRawWord8s   ) where  import Prelude hiding (read) import ALife.Creatur.Genetics.Diploid (Diploid, express)+import ALife.Creatur.Util (fromEither) 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 @@ -69,7 +71,7 @@  type Reader = StateT (Sequence, Int) Identity -read :: Genetic g => Sequence -> Maybe g+read :: Genetic g => Sequence -> Either [String] g read s = evalState get (s, 0)  runReader :: Reader g -> Sequence -> g@@ -99,24 +101,24 @@   put = gput . from    -- | Reads the next gene in a sequence.-  get :: Reader (Maybe g)+  get :: Reader (Either [String] g) -  default get :: (Generic g, GGenetic (Rep g)) => Reader (Maybe g)+  default get :: (Generic g, GGenetic (Rep g)) => Reader (Either [String] g)   get = do     a <- gget     return . fmap to $ a    getWithDefault :: g -> Reader g-  getWithDefault d = fmap (fromMaybe d) get+  getWithDefault d = fmap (fromEither d) get  class GGenetic f where   gput :: f a -> Writer ()-  gget :: Reader (Maybe (f a))+  gget :: Reader (Either [String] (f a))  -- | Unit: used for constructors without arguments instance GGenetic U1 where   gput U1 = return ()-  gget = return (Just U1)+  gget = return (Right U1)  -- | Constants, additional parameters and recursion of kind * instance (GGenetic a, GGenetic b) => GGenetic (a :*: b) where@@ -133,11 +135,11 @@   gget = do     a <- getRawWord8     case a of-      (Just x) -> do+      Right x -> do         if even x -- Only care about the last bit           then fmap (fmap L1) gget           else fmap (fmap R1) gget-      Nothing -> return Nothing+      Left s -> return $ Left s  -- | Sums: encode choice between constructors instance (GGenetic a) => GGenetic (M1 i c a) where@@ -177,16 +179,21 @@           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+    h <- getRawWord8 :: Reader (Either [String] Word8)+    let high = fmap (\x -> fromIntegral x * 0x100) h :: Either [String] Word16+    l <- getRawWord8 :: Reader (Either [String] Word8)+    let low = fmap fromIntegral l :: Either [String] Word16     return . fmap grayToIntegral $ (+) <$> high <*> low  instance (Genetic a) => Genetic [a]  instance (Genetic a) => Genetic (Maybe a) +instance (Genetic a, Genetic b) => Genetic (a, b)++instance (Genetic a, Genetic b) => Genetic (Either a b)++ -- -- Utilities --@@ -198,17 +205,36 @@   S.put (xs ++ [x])  -- | Read a Word8 value from the genome without decoding it-getRawWord8 :: Reader (Maybe Word8)+getRawWord8 :: Reader (Either [String] Word8) getRawWord8 = do   (xs, i) <- S.get   let xs' = drop i xs   if null xs'-     then return Nothing+     then return $ Left ["End of sequence"]      else do        let x = head xs'        S.put (xs, i+1)-       return $ Just x+       return $ Right x +-- | Write a raw sequence of Word8 values to the genome+putRawWord8s :: [Word8] -> Writer ()+putRawWord8s = mapM_ putRawWord8++-- | Read a raw sequence of Word8 values from the genome+getRawWord8s :: Int -> Reader (Either [String] [Word8])+getRawWord8s n =+  if n == 0+    then return $ Right []+    else do+      (xs, i) <- S.get+      let xs' = drop i xs+      if null xs' || length xs' < n+        then return $ Left ["End of genes"]+        else do+          let ys = take n xs'+          S.put (xs, i+n)+          return $ Right ys+ -- -- Diploid genes --@@ -217,7 +243,7 @@  type DiploidReader = StateT ((Sequence, Int), (Sequence, Int)) Identity -readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Maybe g+readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Either [String] g readAndExpress (s1, s2) = evalState getAndExpress ((s1, 0), (s2, 0))  runDiploidReader :: DiploidReader g -> DiploidSequence -> g@@ -243,19 +269,23 @@ --   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 :: (Genetic g, Diploid g) => DiploidReader (Either [String] 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+  return $ expressEither a b  getAndExpressWithDefault :: (Genetic g, Diploid g) => g -> DiploidReader g-getAndExpressWithDefault d = fmap (fromMaybe d) getAndExpress+getAndExpressWithDefault d = fmap (fromEither 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+expressEither+  :: Diploid g+    => Either [String] g -> Either [String] g+      -> Either [String] g+expressEither (Right a) (Right b) = Right (express a b)+expressEither (Right a) (Left _)  = Right a+expressEither (Left _)  (Right b) = Right b+expressEither (Left xs) (Left ys) =+  Left $ (map ("sequence 1: " ++) xs) ++ (map ("sequence 2: " ++) ys)
src/ALife/Creatur/Genetics/Diploid.hs view
@@ -96,6 +96,8 @@  instance (Diploid a) => Diploid (Maybe a) +instance (Diploid a, Diploid b) => Diploid (a, b)+ -- TODO: Types I might want to define instances for -- Bool	  -- Char
src/ALife/Creatur/Genetics/Reproduction/Asexual.hs view
@@ -46,7 +46,7 @@    -- | 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 -> Either [String] a    -- | @'makeOffspring' (parent1, parent2) name@ uses the genetic   --   information from @parent1@ and @parent2@ to produce a child with@@ -55,7 +55,9 @@   --   1. Calls @'recombine'@ to create a genome for the child.   --   --   2. Calls @'build'@ to construct a child with this genome.-  makeOffspring :: RandomGen r => a -> a -> AgentId -> Rand r (Maybe a)+  makeOffspring+    :: RandomGen r+      => a -> a -> AgentId -> Rand r (Either [String] a)   makeOffspring a b name = do     g <- recombine a b     return $ build name g
src/ALife/Creatur/Genetics/Reproduction/Sexual.hs view
@@ -43,7 +43,7 @@    -- | 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) -> Either [String] a    -- | @'makeOffspring' (parent1, parent2) name@ uses the genetic   --   information from @parent1@ and @parent2@ to produce a child with@@ -55,7 +55,9 @@   --   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+    :: RandomGen r+      => a -> a -> AgentId -> Rand r (Either [String] a)   makeOffspring a b name = do     ga <- produceGamete a     gb <- produceGamete b
src/ALife/Creatur/Logger.hs view
@@ -20,15 +20,15 @@     mkSimpleRotatingLogger   ) where +import ALife.Creatur.Util (modifyLift, getLift) import Control.Monad (when, unless)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State (StateT, get, gets, put)+import Control.Monad.State (StateT, gets) 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' msg@ formats and writes a new log message.   writeToLog :: String -> StateT l IO ()  -- | A rotating logger.@@ -55,18 +55,13 @@ instance Logger SimpleRotatingLogger where   writeToLog msg = do     initIfNeeded-    logger <- get-    logger' <- liftIO $ bumpRecordCount logger-    put logger'-    liftIO $ write' logger' msg+    modifyLift bumpRecordCount+    getLift $ write' msg  initIfNeeded :: StateT SimpleRotatingLogger IO () initIfNeeded = do   isInitialised <- gets initialised-  unless isInitialised $ do-    logger <- get-    logger' <- liftIO $ initialise logger-    put logger'+  unless isInitialised $ modifyLift initialise  initialise :: SimpleRotatingLogger -> IO SimpleRotatingLogger initialise logger = do@@ -79,8 +74,8 @@       return $ logger { initialised=True, recordCount=read s}     else return $ logger { initialised=True, recordCount=0} -write' :: SimpleRotatingLogger -> String -> IO ()-write' logger msg = do+write' :: String -> SimpleRotatingLogger -> IO ()+write' msg logger = do   timestamp <-       fmap (formatTime defaultTimeLocale "%y%m%d%H%M%S%z") getZonedTime   appendFile (logFilename logger)@@ -89,12 +84,12 @@ 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) $ rotateLog logger   writeFile (expFilename logger) (show n)   return logger{ recordCount=n }  rotateLog :: SimpleRotatingLogger -> IO () rotateLog logger = do   let f = logFilename logger-  renameFile f $ f ++ '.' : (show . recordCount) logger+  renameFile f $ f ++ '.' : (show . recordCount $ logger)
src/ALife/Creatur/Universe.hs view
@@ -10,8 +10,8 @@ -- Provides a habitat for artificial life. -- -------------------------------------------------------------------------{-# LANGUAGE TemplateHaskell, TypeFamilies, FlexibleContexts #-}-+{-# LANGUAGE TemplateHaskell, TypeFamilies, FlexibleContexts,+    UndecidableInstances #-} module ALife.Creatur.Universe  (     Universe(..),@@ -23,10 +23,16 @@     multiLookup,     extra,     agentIds,+    getAgent,+    archivedAgentIds,+    getAgentFromArchive,     addAgent,-    storeOrArchive+    storeOrArchive,+    archiveAgent  ) where +import Prelude hiding (lookup)+ import ALife.Creatur (Agent, AgentId, agentId, isAlive) import ALife.Creatur.AgentNamer (AgentNamer, SimpleAgentNamer,    mkSimpleAgentNamer)@@ -34,7 +40,7 @@ import ALife.Creatur.Clock (Clock, currentTime, incTime) import ALife.Creatur.Counter (PersistentCounter, mkPersistentCounter) import ALife.Creatur.Database as D (Database, DBRecord, Record,-  delete, keys, lookup, store)+  delete, key, keys, archivedKeys, lookup, lookupInArchive, store) import ALife.Creatur.Database.FileSystem (FSDatabase, mkFSDatabase) import ALife.Creatur.Logger (Logger, SimpleRotatingLogger,    mkSimpleRotatingLogger, writeToLog)@@ -64,12 +70,35 @@   currentTime = zoom clock currentTime   incTime = zoom clock incTime +-- instance (Database d, DBRecord d ~ DBRecord (Universe c l d n x a)) =>+--     Database (Universe c l d n x a) where+--   type DBRecord (Universe c l d n x a) = a+--   keys = zoom agentDB keys+--   archivedKeys = zoom agentDB archivedKeys+--   lookup = zoom agentDB . lookup+--   lookupInArchive = zoom agentDB . lookupInArchive+--   store = zoom agentDB . store+--   delete = zoom agentDB . delete+ instance AgentNamer n => AgentNamer (Universe c l d n x a) where   genName = zoom namer N.genName  agentIds :: Database d => StateT (Universe c l d n x a) IO [String] agentIds = zoom agentDB keys +archivedAgentIds :: Database d => StateT (Universe c l d n x a) IO [String]+archivedAgentIds = zoom agentDB archivedKeys++getAgent+  :: (Serialize a, Database d, a ~ DBRecord d)+    => String -> StateT (Universe c l d n x a) IO (Either String a)+getAgent = zoom agentDB . lookup++getAgentFromArchive+  :: (Serialize a, Database d, a ~ DBRecord d)+    => String -> StateT (Universe c l d n x a) IO (Either String a)+getAgentFromArchive = zoom agentDB . lookupInArchive+ multiLookup :: (Serialize a, Database d, Record a, a ~ DBRecord d) =>    [AgentId] -> StateT d IO (Either String [DBRecord d]) multiLookup names = do@@ -88,7 +117,11 @@  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)+addAgent = zoom agentDB . store++archiveAgent :: (Serialize a, Database d, Record a, a ~ DBRecord d) =>+     DBRecord d -> StateT (Universe c l d n x a) IO ()+archiveAgent = zoom agentDB . delete . D.key  type SimpleUniverse a =    Universe PersistentCounter SimpleRotatingLogger (FSDatabase a)
src/ALife/Creatur/Util.hs view
@@ -30,13 +30,17 @@     boolsToBits,     showBin,     -- * Monads-    stateMap+    stateMap,+    fromEither,+    catEithers,+    modifyLift,+    getLift --    constrain,   ) where  import Control.Monad (forM_, liftM) import Control.Monad.Random (Rand, RandomGen, getRandomRs)-import Control.Monad.State (StateT(..))+import Control.Monad.State (StateT(..), get, lift, put) import Data.Array.ST (runSTArray) import Data.Char (intToDigit) import Data.List.Split (chunksOf)@@ -168,6 +172,46 @@  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++-- | The 'fromEither' function takes a default value and an 'Either'+--   value.  If the 'Either' is 'Left', it returns the default value;+--   otherwise, it returns the value contained in the 'Right'.+fromEither     :: a -> Either e a -> a+fromEither d x = case x of {Left _ -> d; Right v  -> v}++-- | The 'catEithers' function takes a list of 'Either's and returns+--   a list of all the 'Right' values. +catEithers              :: [Either e a] -> [a]+catEithers ls = [x | Right x <- ls]++-- | Like modify, but the function that maps the old state to the+--   new state operates in the inner monad.+--   For example,+--   +--   > s <- get+--   > s' = lift $ f s+--   > put s'+--   +--   can be replaced with+--   +--   > modifyLift f+modifyLift :: Monad m => (s -> m s) -> StateT s m ()+modifyLift f = get >>= lift . f >>= put++-- | Invoke a function in the inner monad, and pass the state as+--   a parameter.+--   Similar to modifyLift, but the function being invoked doesn't+--   have a return value, so the state is not modified.+--   For example,+--   +--   > s <- get+--   > s' = lift $ f s+--   +--   can be replaced with+--   +--   > getLift f+getLift :: Monad m => (s -> m ()) -> StateT s m ()+getLift f = get >>= lift . f >> return ()  rotate :: [a] -> [a] rotate [] = []
test/ALife/Creatur/Genetics/BRGCBoolQC.hs view
@@ -18,6 +18,7 @@  import Prelude hiding (read) import ALife.Creatur.Genetics.BRGCBool+import ALife.Creatur.Genetics.Analysis (Analysable) import Control.Applicative ((<$>), (<*>)) import Data.Word (Word8, Word16) import GHC.Generics (Generic)@@ -27,7 +28,7 @@   oneof, property, sized, vectorOf)  prop_round_trippable :: (Eq g, Genetic g) => g -> Property-prop_round_trippable g = property $ g' == Just g+prop_round_trippable g = property $ g' == Right g   where x = write g         g' = read x @@ -35,6 +36,7 @@   deriving (Show, Eq, Generic)  instance Genetic TestStructure+instance Analysable TestStructure  sizedArbTestStructure :: Int -> Gen TestStructure sizedArbTestStructure 0 =@@ -52,19 +54,19 @@    instance Arbitrary TestStructure where   arbitrary = sized sizedArbTestStructure-              + test :: Test test = testGroup "ALife.Creatur.Genetics.BRGCBoolQC"   [-    testProperty "prop_encoding_round_trippable - Bool"+    testProperty "prop_round_trippable - Bool"       (prop_round_trippable :: Bool -> Property),-    testProperty "prop_encoding_round_trippable - Char"+    testProperty "prop_round_trippable - Char"       (prop_round_trippable :: Char -> Property),-    testProperty "prop_encoding_round_trippable - Word8"+    testProperty "prop_round_trippable - Word8"       (prop_round_trippable :: Word8 -> Property),-    testProperty "prop_encoding_round_trippable - Word16"+    testProperty "prop_round_trippable - Word16"       (prop_round_trippable :: Word16 -> Property),-    testProperty "prop_encoding_round_trippable - TestStructure"+    testProperty "prop_round_trippable - TestStructure"       (prop_round_trippable :: TestStructure -> Property)   ]
test/ALife/Creatur/Genetics/BRGCWord8QC.hs view
@@ -18,6 +18,7 @@  import Prelude hiding (read) import ALife.Creatur.Genetics.BRGCWord8+import ALife.Creatur.Genetics.Analysis (Analysable) import Control.Applicative ((<$>), (<*>)) import Data.Word (Word8, Word16) import GHC.Generics (Generic)@@ -27,7 +28,7 @@   oneof, property, sized, vectorOf)  prop_round_trippable :: (Eq g, Genetic g) => g -> Property-prop_round_trippable g = property $ g' == Just g+prop_round_trippable g = property $ g' == Right g   where x = write g         g' = read x @@ -35,6 +36,7 @@   deriving (Show, Eq, Generic)  instance Genetic TestStructure+instance Analysable TestStructure  sizedArbTestStructure :: Int -> Gen TestStructure sizedArbTestStructure 0 =@@ -52,19 +54,19 @@    instance Arbitrary TestStructure where   arbitrary = sized sizedArbTestStructure-              + test :: Test test = testGroup "ALife.Creatur.Genetics.BRGCWord8QC"   [-    testProperty "prop_encoding_round_trippable - Bool"+    testProperty "prop_round_trippable - Bool"       (prop_round_trippable :: Bool -> Property),-    testProperty "prop_encoding_round_trippable - Char"+    testProperty "prop_round_trippable - Char"       (prop_round_trippable :: Char -> Property),-    testProperty "prop_encoding_round_trippable - Word8"+    testProperty "prop_round_trippable - Word8"       (prop_round_trippable :: Word8 -> Property),-    testProperty "prop_encoding_round_trippable - Word16"+    testProperty "prop_round_trippable - Word16"       (prop_round_trippable :: Word16 -> Property),-    testProperty "prop_encoding_round_trippable - TestStructure"+    testProperty "prop_round_trippable - TestStructure"       (prop_round_trippable :: TestStructure -> Property)   ]