diff --git a/creatur.cabal b/creatur.cabal --- a/creatur.cabal +++ b/creatur.cabal @@ -1,22 +1,22 @@ Name: creatur -Version: 5.9.6 +Version: 5.9.7 Stability: experimental Synopsis: Framework for artificial life experiments. Description: A software framework for automating experiments with artificial life. It provides a daemon which - maintains its own "clock", schedules events, - provides logging, and ensures that each agent gets - its turn to use the CPU. You can use other + maintains its own "clock", schedules events, + provides logging, and ensures that each agent gets + its turn to use the CPU. You can use other applications on the computer at the same time without fear of interfering with experiments; they - will run normally, just more slowly. See the - tutorial at + will run normally, just more slowly. See the + tutorial at for examples on how to use the Créatúr framework. . About the name: \"Créatúr\" (pronounced kray-toor) - is an Irish word meaning animal, creature, or an + is an Irish word meaning animal, creature, or an unfortunate person. Category: AI License: BSD3 @@ -36,12 +36,12 @@ source-repository this type: git location: https://github.com/mhwombat/creatur.git - tag: 5.9.6 + tag: 5.9.7 library GHC-Options: -Wall -fno-warn-orphans Hs-source-dirs: src - exposed-modules: + exposed-modules: ALife.Creatur, ALife.Creatur.Checklist, ALife.Creatur.Clock, @@ -68,7 +68,7 @@ ALife.Creatur.Task, ALife.Creatur.Util Other-modules: Paths_creatur - Build-Depends: + Build-Depends: array ==0.5.*, base ==4.*, bytestring ==0.10.*, @@ -95,7 +95,7 @@ Main-is: TestAll.hs GHC-Options: -Wall Hs-source-dirs: test - Build-Depends: + Build-Depends: array ==0.5.*, base ==4.*, binary ==0.7.*, @@ -126,17 +126,16 @@ ALife.Creatur.PersistentQC ALife.Creatur.UniverseQC ALife.Creatur.UtilQC - + -- Benchmark creatur-bench -- Type: exitcode-stdio-1.0 -- Main-is: BenchAll.hs -- GHC-Options: -Wall -- Hs-source-dirs: test --- Build-Depends: +-- Build-Depends: -- base ==4.*, -- creatur, -- criterion ==0.8.*, -- test-framework ==0.8.* -- Other-modules: ALife.Creatur.Genetics.BRGCWord8Bench - diff --git a/src/ALife/Creatur/Genetics/BRGCBool.hs b/src/ALife/Creatur/Genetics/BRGCBool.hs --- a/src/ALife/Creatur/Genetics/BRGCBool.hs +++ b/src/ALife/Creatur/Genetics/BRGCBool.hs @@ -118,6 +118,13 @@ getWithDefault :: g -> Reader g getWithDefault d = fmap (fromEither d) get + getWithName :: String -> Reader (Either [String] g) + getWithName s = do + g0 <- get + return $ case g0 of + (Left xs) -> Left ((s ++ ":"):xs) + (Right g1) -> Right g1 + class GGenetic f where gput :: f a -> Writer () gget :: Reader (Either [String] (f a)) diff --git a/src/ALife/Creatur/Genetics/BRGCWord16.hs b/src/ALife/Creatur/Genetics/BRGCWord16.hs --- a/src/ALife/Creatur/Genetics/BRGCWord16.hs +++ b/src/ALife/Creatur/Genetics/BRGCWord16.hs @@ -120,6 +120,13 @@ getWithDefault :: g -> Reader g getWithDefault d = fmap (fromEither d) get + getWithName :: String -> Reader (Either [String] g) + getWithName s = do + g0 <- get + return $ case g0 of + (Left xs) -> Left ((s ++ ":"):xs) + (Right g1) -> Right g1 + class GGenetic f where gput :: f a -> Writer () gget :: Reader (Either [String] (f a)) diff --git a/src/ALife/Creatur/Genetics/BRGCWord8.hs b/src/ALife/Creatur/Genetics/BRGCWord8.hs --- a/src/ALife/Creatur/Genetics/BRGCWord8.hs +++ b/src/ALife/Creatur/Genetics/BRGCWord8.hs @@ -24,6 +24,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} module ALife.Creatur.Genetics.BRGCWord8 @@ -46,6 +47,8 @@ getAndExpressWithDefault, copy2, consumed2, + putAndReport, + getAndReport, putRawWord8, getRawWord8, putRawWord8s, @@ -56,6 +59,7 @@ import ALife.Creatur.Genetics.Diploid (Diploid, express) import ALife.Creatur.Util (fromEither) import Codec.Gray (integralToGray, grayToIntegral) +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) @@ -71,30 +75,33 @@ type Sequence = [Word8] -type Writer = StateT Sequence Identity +type Writer = StateT (Sequence, [String]) Identity write :: Genetic x => x -> Sequence -write x = runWriter (put x) +write x = fst $ runWriter (put x) -runWriter :: Writer () -> Sequence -runWriter w = execState (w >> finalise) [] +runWriter :: Writer () -> (Sequence, [String]) +runWriter w = execState (w >> finalise) ([], []) -type Reader = StateT (Sequence, Int) Identity +type Reader = StateT (Sequence, Int, [String]) Identity read :: Genetic g => Sequence -> Either [String] g -read s = evalState get (s, 0) +read s = fst $ runReader get s -runReader :: Reader g -> Sequence -> g -runReader r s = evalState r (s, 0) +runReader + :: Reader (Either [String] g) -> Sequence + -> (Either [String] g, [String]) +runReader r s = (x, reverse msgs) + where (x, (_, _, msgs)) = runState r (s, 0, []) -- | Return the entire genome. copy :: Reader Sequence -copy = S.gets fst +copy = S.gets (\(x, _, _) -> x) -- | Return the portion of the genome that has been read. consumed :: Reader Sequence consumed = do - (xs, i) <- S.get + (xs, i, _) <- S.get return $ take i xs -- | A class representing anything which is represented in, and @@ -140,17 +147,23 @@ -- | 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 + gput (L1 x) = putAndReport [0] "L1" >> gput x + gput (R1 x) = putAndReport [1] "R1" >> gput x gget = do - a <- getRawWord8 + a <- getAndReport 1 convertLR case a of - Right x -> do - if even x -- Only care about the last bit - then fmap (fmap L1) gget - else fmap (fmap R1) gget - Left s -> return $ Left s + Right L -> fmap (fmap L1) gget + Right R -> fmap (fmap R1) gget + Left s -> return $ Left s +data LR = L | R + +convertLR :: [Word8] -> Either String (LR, String) +convertLR (x:[]) = if even x -- Only care about the last bit + then Right (L, "L1") + else Right (R, "R1") +convertLR _ = Left "logic error" + -- | Sums: encode choice between constructors instance (GGenetic a) => GGenetic (M1 i c a) where gput (M1 x) = gput x @@ -168,35 +181,48 @@ -- instance Genetic Bool where - put False = putRawWord8 0 - put True = putRawWord8 1 - get = fmap (fmap word8ToBool) getRawWord8 + put b = putAndReport [fromIntegral $ fromEnum b] (show b) + get = getAndReport 1 convert + where convert (x:[]) = Right (g, show g) + where g = word8ToBool x + convert _ = Left "logic error" 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 + put x = putAndReport [fromIntegral . ord $ x] (show x) + get = getAndReport 1 convert + where convert (x:[]) = Right (g, show g) + where g = (chr . fromIntegral) x + convert _ = Left "logic error" instance Genetic Word8 where - put = putRawWord8 . integralToGray - get = fmap (fmap grayToIntegral) getRawWord8 + put x = putAndReport [integralToGray x] (show x ++ " Word8") + get = getAndReport 1 convert + where convert (x:[]) = Right (g, show g ++ " Word8") + where g = grayToIntegral x + convert _ = Left "logic error" instance Genetic Word16 where - put g = putRawWord8 high >> putRawWord8 low + put g = putAndReport + [fromIntegral $ x `div` 0x100, fromIntegral $ x `mod` 0x100] + (show g ++ " Word16") where x = integralToGray g - high = fromIntegral (x `div` 0x100) - low = fromIntegral (x `mod` 0x100) - get = do - 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 + get = getAndReport 2 grayWord16 +grayWord16 :: [Word8] -> Either String (Word16, String) +grayWord16 (x:y:[]) = Right (g, show g ++ " Word16") + where g = grayToIntegral (high + low) :: Word16 + high = fromIntegral x * 0x100 + low = fromIntegral y +grayWord16 _ = Left "logic error" + instance (Genetic a) => Genetic [a] where - put xs = put n' >> mapM_ put xs + put xs = do + put n' + replaceReportW (show n' ++ " list length") + mapM_ put xs where n = length xs n' = if n <= fromIntegral (maxBound :: Word16) then fromIntegral n @@ -204,7 +230,8 @@ get = do n <- get :: Reader (Either [String] Word16) case n of - Right n' -> getList (fromIntegral n') + Right n' -> do replaceReportR (show n' ++ " list length") + getList (fromIntegral n') Left s -> return $ Left s instance (Genetic a) => Genetic (Maybe a) @@ -220,10 +247,11 @@ finalise :: Writer () finalise = do - xs <- S.get - S.put (reverse xs) + (xs, msgs) <- S.get + S.put (reverse xs, reverse msgs) getList :: Genetic a => Int -> Reader (Either [String] [a]) +getList 0 = return $ Right [] getList n = do cs <- sequence $ replicate n get let (mss, xs) = partitionEithers cs @@ -234,55 +262,78 @@ -- | Write a Word8 value to the genome without encoding it putRawWord8 :: Word8 -> Writer () putRawWord8 x = do - xs <- S.get - S.put (x:xs) + (xs, msgs) <- S.get + S.put (x:xs, msgs) -- | Read a Word8 value from the genome without decoding it getRawWord8 :: Reader (Either [String] Word8) getRawWord8 = do - (xs, i) <- S.get + (xs, i, msgs) <- S.get let xs' = drop i xs if null xs' then return $ Left ["End of sequence"] else do let x = head xs' - S.put (xs, i+1) + S.put (xs, i+1, msgs) return $ Right x -- | Write a raw sequence of Word8 values to the genome putRawWord8s :: [Word8] -> Writer () -putRawWord8s ys = do - xs <- S.get - S.put (reverse ys ++ xs) +putRawWord8s ws = mapM_ putRawWord8 ws -- | 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 +getRawWord8s n = fmap sequence $ replicateM n getRawWord8 +reportW :: String -> Writer () +reportW desc = do + (xs, msgs) <- S.get + let msg = show (length xs) ++ ": wrote " ++ desc + S.put (xs, msg:msgs) + +putAndReport :: [Word8] -> String -> Writer () +putAndReport bytes msg = putRawWord8s bytes >> reportW msg + +replaceReportW :: String -> Writer () +replaceReportW desc = do + (xs, _:msgs) <- S.get + let msg = show (length xs) ++ ": wrote " ++ desc + S.put (xs, msg:msgs) + +reportR :: String -> Reader () +reportR desc = do + (xs, i, msgs) <- S.get + let msg = show i ++ ": read " ++ desc + S.put (xs, i, msg:msgs) + +getAndReport :: Int -> ([Word8] -> (Either String (g, String))) -> Reader (Either [String] g) +getAndReport n parse = do + a <- getRawWord8s n + case a of + Right xs -> case parse xs of + Right (g, msg) -> reportR msg >> return (Right g) + Left errMsg2 -> return $ Left [errMsg2] + Left errMsg -> return $ Left errMsg + +replaceReportR :: String -> Reader () +replaceReportR desc = do + (xs, i, _:msgs) <- S.get + let msg = show i ++ ": read " ++ desc + S.put (xs, i, msg:msgs) + -- -- Diploid genes -- type DiploidSequence = (Sequence, Sequence) -type DiploidReader = StateT ((Sequence, Int), (Sequence, Int)) Identity +type DiploidReader = StateT ((Sequence, Int, [String]), (Sequence, Int, [String])) Identity readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Either [String] g -readAndExpress (s1, s2) = evalState getAndExpress ((s1, 0), (s2, 0)) +readAndExpress (s1, s2) = evalState getAndExpress ((s1, 0, []), (s2, 0, [])) runDiploidReader :: DiploidReader g -> DiploidSequence -> g -runDiploidReader r (s1, s2) = evalState r ((s1, 0), (s2, 0)) +runDiploidReader r (s1, s2) = evalState r ((s1, 0, []), (s2, 0, [])) -- | Return the entire genome. copy2 :: DiploidReader DiploidSequence diff --git a/test/ALife/Creatur/Genetics/BRGCWord8QC.hs b/test/ALife/Creatur/Genetics/BRGCWord8QC.hs --- a/test/ALife/Creatur/Genetics/BRGCWord8QC.hs +++ b/test/ALife/Creatur/Genetics/BRGCWord8QC.hs @@ -41,9 +41,9 @@ prop_rawWord8s_round_trippable :: [Word8] -> Property prop_rawWord8s_round_trippable g = property $ g' == g - where x = runWriter (putRawWord8s g) + where x = fst $ runWriter (putRawWord8s g) g' = fromEither (error "read returned Nothing") . - runReader (getRawWord8s n) $ x + fst . runReader (getRawWord8s n) $ x n = length g data TestStructure = A | B Bool | C Word8 | D Word16 Char | E [TestStructure]