diff --git a/creatur.cabal b/creatur.cabal --- a/creatur.cabal +++ b/creatur.cabal @@ -1,5 +1,5 @@ name: creatur -version: 5.9.19 +version: 5.9.20 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -58,27 +58,27 @@ ALife.Creatur.Task ALife.Creatur.Util build-depends: - array >=0.5.1.1 && <0.6, - base ==4.9.* || ==4.10.*, - binary >=0.8.3.0 && <0.9, - bytestring >=0.10.8.1 && <0.11, + array >=0.5.2.0 && <0.6, + base >=4.10.0.0 && <4.11, + binary >=0.8.5.1 && <0.9, + bytestring >=0.10.8.2 && <0.11, cond >=0.4.1.1 && <0.5, cereal >=0.5.4.0 && <0.6, - directory >=1.3.0.0 && <1.4, + directory >=1.3.0.2 && <1.4, exceptions >=0.8.3 && <0.9, - filepath >=1.4.1.1 && <1.5, + filepath >=1.4.1.2 && <1.5, gray-extended >=1.5.2 && <1.6, hdaemonize >=0.5.4 && <0.6, hsyslog >=5.0.1 && <5.1, MonadRandom >=0.5.1 && <0.6, mtl >=2.2.1 && <2.3, old-locale >=1.0.0.7 && <1.1, - process >=1.4.3.0 && <1.5, + process >=1.6.1.0 && <1.7, random ==1.1.*, split >=0.2.3.2 && <0.3, - time >=1.6.0.1 && <1.7, + time >=1.8.0.2 && <1.9, transformers >=0.5.2.0 && <0.6, - unix >=2.7.2.1 && <2.8, + unix >=2.7.2.2 && <2.8, zlib >=0.6.1.2 && <0.7 hs-source-dirs: src other-modules: @@ -89,32 +89,30 @@ type: exitcode-stdio-1.0 main-is: TestAll.hs build-depends: - array >=0.5.1.1 && <0.6, - base ==4.9.* || ==4.10.*, - binary >=0.8.3.0 && <0.9, + array >=0.5.2.0 && <0.6, + base >=4.10.0.0 && <4.11, + binary >=0.8.5.1 && <0.9, cereal >=0.5.4.0 && <0.6, creatur, - directory >=1.3.0.0 && <1.4, - filepath >=1.4.1.1 && <1.5, + directory >=1.3.0.2 && <1.4, + filepath >=1.4.1.2 && <1.5, hsyslog >=5.0.1 && <5.1, - HUnit >=1.5.0.0 && <1.6, + HUnit >=1.6.0.0 && <1.7, MonadRandom >=0.5.1 && <0.6, mtl >=2.2.1 && <2.3, - temporary >=1.2.1 && <1.3, + temporary >=1.2.1.1 && <1.3, test-framework >=0.8.1.1 && <0.9, test-framework-hunit >=0.3.0.2 && <0.4, test-framework-quickcheck2 >=0.3.0.4 && <0.4, - QuickCheck >=2.9.2 && <2.10 + QuickCheck >=2.10.0.1 && <2.11 hs-source-dirs: test other-modules: ALife.Creatur.ChecklistQC ALife.Creatur.CounterQC ALife.Creatur.Database.CachedFileSystemQC ALife.Creatur.Database.FileSystemQC - ALife.Creatur.Genetics.BRGCBoolBench ALife.Creatur.Genetics.BRGCBoolQC ALife.Creatur.Genetics.BRGCWord16QC - ALife.Creatur.Genetics.BRGCWord8Bench ALife.Creatur.Genetics.BRGCWord8QC ALife.Creatur.Genetics.DiploidQC ALife.Creatur.Genetics.RecombinationQC 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 @@ -184,9 +184,11 @@ return $ Right x instance Genetic Char where - put = putRawBoolArray . intToBools 8 . ord + put c = do + let bs = map (\b -> b == '1') $ showIntAtBase 2 intToDigit (ord c) "" + put bs get = do - bs <- getRawBoolArray 8 + bs <- get return . fmap chr $ fmap boolsToInt bs instance Genetic Word8 where 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 @@ -58,6 +58,8 @@ import Codec.Gray (integralToGray, grayToIntegral) import Control.Monad.State.Lazy (StateT, runState, execState, evalState) import qualified Control.Monad.State.Lazy as S (put, get, gets) +import Data.Binary (Binary, encode, decode) +import Data.ByteString.Lazy (pack, unpack) import Data.Char (ord, chr) import Data.Functor.Identity (Identity) import Data.Word (Word8, Word16) @@ -182,8 +184,8 @@ word16ToBool x = if even x then False else True instance Genetic Char where - put = putRawWord16 . fromIntegral . ord - get = fmap (fmap (chr . fromIntegral)) getRawWord16 + put = put . ord + get = fmap (fmap chr) get instance Genetic Word8 where put x = put (fromIntegral x :: Word16) @@ -195,6 +197,14 @@ put = putRawWord16 . integralToGray get = fmap (fmap grayToIntegral) getRawWord16 +instance Genetic Int where + put g = put (map integralToGray . integralToByteArray $ g) + get = do + x <- get + case x of + Right xs -> return $ Right (byteArrayToIntegral . map grayToIntegral $ xs) + Left s -> return $ Left s + instance (Genetic a) => Genetic [a] instance (Genetic a) => Genetic (Maybe a) @@ -207,6 +217,12 @@ -- -- Utilities -- + +integralToByteArray :: (Integral t, Binary t) => t -> [Word8] +integralToByteArray = unpack . encode + +byteArrayToIntegral :: (Integral t, Binary t) => [Word8] -> t +byteArrayToIntegral = decode . pack -- | Write a Word16 value to the genome without encoding it putRawWord16 :: Word16 -> Writer () 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 @@ -193,11 +193,16 @@ word8ToBool x = if even x then False else True instance Genetic Char where - 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" + put c = do + put . ord $ c + replaceReportW [c] + get = do + x <- get + case x of + Right x' -> do let c = chr x' + replaceReportR [c] + return $ Right c + Left s -> return $ Left s instance Genetic Word8 where put x = putAndReport [integralToGray x] (show x ++ " Word8") @@ -249,6 +254,33 @@ Left s' -> return $ Left s' Left s -> return $ Left s +instance (Genetic a) => Genetic [a] where + 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 + else error "List too long" :: Word16 + get = do + n <- get :: Reader (Either [String] Word16) + case n of + Right n' -> do replaceReportR (show n' ++ " list length") + getList (fromIntegral n') + Left s -> return $ Left s + +instance (Genetic a) => Genetic (Maybe a) + +instance (Genetic a, Genetic b) => Genetic (a, b) + +instance (Genetic a, Genetic b) => Genetic (Either a b) + + +-- +-- Utilities +-- + grayWord16 :: [Word8] -> Either String (Word16, String) grayWord16 bs = Right (g, show g ++ " Word16") where g = grayToIntegral . bytesToIntegral $ bs @@ -278,33 +310,6 @@ byteArrayToIntegral :: (Integral t, Binary t) => [Word8] -> t byteArrayToIntegral = decode . pack - -instance (Genetic a) => Genetic [a] where - 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 - else error "List too long" :: Word16 - get = do - n <- get :: Reader (Either [String] Word16) - case n of - Right n' -> do replaceReportR (show n' ++ " list length") - getList (fromIntegral n') - Left s -> return $ Left s - -instance (Genetic a) => Genetic (Maybe a) - -instance (Genetic a, Genetic b) => Genetic (a, b) - -instance (Genetic a, Genetic b) => Genetic (Either a b) - - --- --- Utilities --- finalise :: Writer () finalise = do diff --git a/test/ALife/Creatur/Genetics/BRGCBoolBench.hs b/test/ALife/Creatur/Genetics/BRGCBoolBench.hs deleted file mode 100644 --- a/test/ALife/Creatur/Genetics/BRGCBoolBench.hs +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------- --- | --- Module : ALife.Creatur.Genetics.BRGCBoolBench --- Copyright : (c) Amy de Buitléir 2014-2016 --- License : BSD-style --- Maintainer : amy@nualeargais.ie --- Stability : experimental --- Portability : portable --- --- Benchmarks. --- ------------------------------------------------------------------------- -{-# LANGUAGE DeriveGeneric, FlexibleInstances #-} -module ALife.Creatur.Genetics.BRGCBoolBench - ( - benchmark - ) where - -import Prelude hiding (read) -import ALife.Creatur.Genetics.BRGCBool -import Data.Word (Word8) -import Criterion.Main (Benchmark, Pure, nf, bgroup, bench) - -word8 :: Word8 -word8 = 0 - -word8Encoded :: [Bool] -word8Encoded = write word8 - -putWord8Benchmark :: Pure -putWord8Benchmark = nf write word8 - -getWord8Benchmark :: Pure -getWord8Benchmark = nf (read :: Sequence -> Either [String] Word8) word8Encoded - -word8s :: [Word8] -word8s = [0..255] - -word8sEncoded :: [Bool] -word8sEncoded = write word8s - -putWord8sBenchmark :: Pure -putWord8sBenchmark = nf write word8s - -getWord8sBenchmark :: Pure -getWord8sBenchmark = nf (read :: Sequence -> Either [String] [Word8]) word8sEncoded - -benchmark :: Benchmark -benchmark = bgroup "ALife.Creatur.Genetics.BRGCBoolBench" - [ - bench "put Word8" putWord8Benchmark, - bench "get Word8" getWord8Benchmark, - bench "put [Word8]" putWord8sBenchmark, - bench "get [Word8]" getWord8sBenchmark - ] - - diff --git a/test/ALife/Creatur/Genetics/BRGCWord8Bench.hs b/test/ALife/Creatur/Genetics/BRGCWord8Bench.hs deleted file mode 100644 --- a/test/ALife/Creatur/Genetics/BRGCWord8Bench.hs +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------- --- | --- Module : ALife.Creatur.Genetics.BRGCWord8Bench --- Copyright : (c) Amy de Buitléir 2014-2016 --- License : BSD-style --- Maintainer : amy@nualeargais.ie --- Stability : experimental --- Portability : portable --- --- Benchmarks. --- ------------------------------------------------------------------------- -{-# LANGUAGE DeriveGeneric, FlexibleInstances #-} -module ALife.Creatur.Genetics.BRGCWord8Bench - ( - benchmark - ) where - -import Prelude hiding (read) -import ALife.Creatur.Genetics.BRGCWord8 -import Data.Word (Word8) -import Criterion.Main (Benchmark, Pure, nf, bgroup, bench) - -word8 :: Word8 -word8 = 0 - -word8Encoded :: [Word8] -word8Encoded = write word8 - -putWord8Benchmark :: Pure -putWord8Benchmark = nf write word8 - -getWord8Benchmark :: Pure -getWord8Benchmark = nf (read :: Sequence -> Either [String] Word8) word8Encoded - -word8s :: [Word8] -word8s = concatMap (replicate 10) [0..255] - -word8sEncoded :: [Word8] -word8sEncoded = write word8s - -putWord8sBenchmark :: Pure -putWord8sBenchmark = nf write word8s - -getWord8sBenchmark :: Pure -getWord8sBenchmark = nf (read :: Sequence -> Either [String] [Word8]) word8sEncoded - --- putRawWord8sBenchmark :: Pure --- putRawWord8sBenchmark = nf (runWriter putRawWord8s) word8s - --- getRawWord8sBenchmark :: Pure --- getRawWord8sBenchmark = nf (runReader getRawWord8sBenchmark) word8sEncoded - -benchmark :: Benchmark -benchmark = bgroup "ALife.Creatur.Genetics.BRGCWord8Bench" - [ - bench "put Word8" putWord8Benchmark, - bench "get Word8" getWord8Benchmark, - bench "put [Word8]" putWord8sBenchmark, - bench "get [Word8]" getWord8sBenchmark - -- bench "putRaw [Word8]" putRawWord8sBenchmark, - -- bench "getRaw [Word8]" getRawWord8sBenchmark - ] - -