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,
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.Either (partitionEithers)
import Data.Functor.Identity (Identity)
import Data.Word (Word8, Word16)
import GHC.Generics
type Sequence = [Word8]
type Writer = StateT Sequence Identity
write :: Genetic x => x -> Sequence
write x = runWriter (put x)
runWriter :: Writer () -> Sequence
runWriter w = execState (w >> finalise) []
type Reader = StateT (Sequence, Int) Identity
read :: Genetic g => Sequence -> Either [String] g
read s = evalState get (s, 0)
runReader :: Reader g -> Sequence -> g
runReader r s = evalState r (s, 0)
copy :: Reader Sequence
copy = S.gets fst
consumed :: Reader Sequence
consumed = do
(xs, i) <- S.get
return $ take i xs
class Genetic g where
put :: g -> Writer ()
default put :: (Generic g, GGenetic (Rep g)) => g -> Writer ()
put = gput . from
get :: Reader (Either [String] 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 (fromEither d) get
class GGenetic f where
gput :: f a -> Writer ()
gget :: Reader (Either [String] (f a))
instance GGenetic U1 where
gput U1 = return ()
gget = return (Right U1)
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
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
Right x -> do
if even x
then fmap (fmap L1) gget
else fmap (fmap R1) gget
Left s -> return $ Left s
instance (GGenetic a) => GGenetic (M1 i c a) where
gput (M1 x) = gput x
gget = fmap (fmap M1) gget
instance (Genetic a) => GGenetic (K1 i a) where
gput (K1 x) = put x
gget = do
a <- get
return $ fmap K1 a
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 (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] where
put xs = put n' >> 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' -> 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)
finalise :: Writer ()
finalise = do
xs <- S.get
S.put (reverse xs)
getList :: Genetic a => Int -> Reader (Either [String] [a])
getList n = do
cs <- sequence $ replicate n get
let (mss, xs) = partitionEithers cs
if null mss
then return $ Right xs
else return $ Left (head mss)
putRawWord8 :: Word8 -> Writer ()
putRawWord8 x = do
xs <- S.get
S.put (x:xs)
getRawWord8 :: Reader (Either [String] Word8)
getRawWord8 = do
(xs, i) <- 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)
return $ Right x
putRawWord8s :: [Word8] -> Writer ()
putRawWord8s ys = do
xs <- S.get
S.put (reverse ys ++ xs)
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
type DiploidSequence = (Sequence, Sequence)
type DiploidReader = StateT ((Sequence, Int), (Sequence, Int)) Identity
readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Either [String] 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))
copy2 :: DiploidReader DiploidSequence
copy2 = do
(ra, rb) <- S.get
let as = evalState copy ra
let bs = evalState copy rb
return (as, bs)
consumed2 :: DiploidReader DiploidSequence
consumed2 = do
(ra, rb) <- S.get
let as = evalState consumed ra
let bs = evalState consumed rb
return (as, bs)
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 $ expressEither a b
getAndExpressWithDefault :: (Genetic g, Diploid g) => g -> DiploidReader g
getAndExpressWithDefault d = fmap (fromEither d) getAndExpress
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)