------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Genetics.BRGCWord8
-- Copyright   :  (c) 2013-2021 Amy de Buitléir
-- 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 #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
module ALife.Creatur.Genetics.BRGCWord8
  (
    Genetic(..),
    Sequence,
    Writer,
    write,
    runWriter,
    Reader,
    read,
    runReader,
    copy,
    consumed,
    DiploidSequence,
    DiploidReader,
    readAndExpress,
    runDiploidReader,
    getAndExpress,
    getAndExpressWithDefault,
    copy2,
    consumed2,
    putAndReport,
    getAndReport,
    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.Monad (replicateM)
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.Either (partitionEithers)
import Data.Functor.Identity (Identity)
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Generics

#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative
#endif

type Sequence = [Word8]

type Writer = StateT (Sequence, [String]) Identity

write :: Genetic x => x -> Sequence
write :: x -> Sequence
write x
x = (Sequence, [String]) -> Sequence
forall a b. (a, b) -> a
fst ((Sequence, [String]) -> Sequence)
-> (Sequence, [String]) -> Sequence
forall a b. (a -> b) -> a -> b
$ Writer () -> (Sequence, [String])
runWriter (x -> Writer ()
forall g. Genetic g => g -> Writer ()
put x
x)

runWriter :: Writer () -> (Sequence, [String])
runWriter :: Writer () -> (Sequence, [String])
runWriter Writer ()
w = Writer () -> (Sequence, [String]) -> (Sequence, [String])
forall s a. State s a -> s -> s
execState (Writer ()
w Writer () -> Writer () -> Writer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Writer ()
finalise) ([], [])

type Reader = StateT (Sequence, Int, [String]) Identity

read :: Genetic g => Sequence -> Either [String] g
read :: Sequence -> Either [String] g
read Sequence
s = (Either [String] g, [String]) -> Either [String] g
forall a b. (a, b) -> a
fst ((Either [String] g, [String]) -> Either [String] g)
-> (Either [String] g, [String]) -> Either [String] g
forall a b. (a -> b) -> a -> b
$ Reader (Either [String] g)
-> Sequence -> (Either [String] g, [String])
forall g.
Reader (Either [String] g)
-> Sequence -> (Either [String] g, [String])
runReader Reader (Either [String] g)
forall g. Genetic g => Reader (Either [String] g)
get Sequence
s

runReader
  :: Reader (Either [String] g) -> Sequence
    -> (Either [String] g, [String])
runReader :: Reader (Either [String] g)
-> Sequence -> (Either [String] g, [String])
runReader Reader (Either [String] g)
r Sequence
s = (Either [String] g
x, [String] -> [String]
forall a. [a] -> [a]
reverse [String]
msgs)
  where (Either [String] g
x, (Sequence
_, Int
_, [String]
msgs)) = Reader (Either [String] g)
-> (Sequence, Int, [String])
-> (Either [String] g, (Sequence, Int, [String]))
forall s a. State s a -> s -> (a, s)
runState Reader (Either [String] g)
r (Sequence
s, Int
0, [])

-- | Return the entire genome.
copy :: Reader Sequence
copy :: Reader Sequence
copy = ((Sequence, Int, [String]) -> Sequence) -> Reader Sequence
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (\(Sequence
x, Int
_, [String]
_) -> Sequence
x)

-- | Return the portion of the genome that has been read.
consumed :: Reader Sequence
consumed :: Reader Sequence
consumed = do
  (Sequence
xs, Int
i, [String]
_) <- StateT (Sequence, Int, [String]) Identity (Sequence, Int, [String])
forall s (m :: * -> *). MonadState s m => m s
S.get
  Sequence -> Reader Sequence
forall (m :: * -> *) a. Monad m => a -> m a
return (Sequence -> Reader Sequence) -> Sequence -> Reader Sequence
forall a b. (a -> b) -> a -> b
$ Int -> Sequence -> Sequence
forall a. Int -> [a] -> [a]
take Int
i Sequence
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 = Rep g Any -> Writer ()
forall (f :: * -> *) a. GGenetic f => f a -> Writer ()
gput (Rep g Any -> Writer ()) -> (g -> Rep g Any) -> g -> Writer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g -> Rep g Any
forall a x. Generic a => a -> Rep a x
from

  -- | Reads the next gene in a sequence.
  get :: Reader (Either [String] g)

  default get :: (Generic g, GGenetic (Rep g)) => Reader (Either [String] g)
  get = do
    Either [String] (Rep g Any)
a <- Reader (Either [String] (Rep g Any))
forall (f :: * -> *) a.
GGenetic f =>
Reader (Either [String] (f a))
gget
    Either [String] g -> Reader (Either [String] g)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] g -> Reader (Either [String] g))
-> Either [String] g -> Reader (Either [String] g)
forall a b. (a -> b) -> a -> b
$ (Rep g Any -> g)
-> Either [String] (Rep g Any) -> Either [String] g
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep g Any -> g
forall a x. Generic a => Rep a x -> a
to Either [String] (Rep g Any)
a

  getWithDefault :: g -> Reader g
  getWithDefault g
d = (Either [String] g -> g) -> Reader (Either [String] g) -> Reader g
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (g -> Either [String] g -> g
forall a e. a -> Either e a -> a
fromEither g
d) Reader (Either [String] g)
forall g. Genetic g => Reader (Either [String] g)
get

class GGenetic f where
  gput :: f a -> Writer ()
  gget :: Reader (Either [String] (f a))

-- | Unit: used for constructors without arguments
instance GGenetic U1 where
  gput :: U1 a -> Writer ()
gput U1 a
U1 = () -> Writer ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  gget :: Reader (Either [String] (U1 a))
gget = Either [String] (U1 a) -> Reader (Either [String] (U1 a))
forall (m :: * -> *) a. Monad m => a -> m a
return (U1 a -> Either [String] (U1 a)
forall a b. b -> Either a b
Right U1 a
forall k (p :: k). U1 p
U1)

-- | Constants, additional parameters and recursion of kind *
instance (GGenetic a, GGenetic b) => GGenetic (a :*: b) where
  gput :: (:*:) a b a -> Writer ()
gput (a a
a :*: b a
b) = a a -> Writer ()
forall (f :: * -> *) a. GGenetic f => f a -> Writer ()
gput a a
a Writer () -> Writer () -> Writer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b a -> Writer ()
forall (f :: * -> *) a. GGenetic f => f a -> Writer ()
gput b a
b
  gget :: Reader (Either [String] ((:*:) a b a))
gget = do
    Either [String] (a a)
a <- Reader (Either [String] (a a))
forall (f :: * -> *) a.
GGenetic f =>
Reader (Either [String] (f a))
gget
    Either [String] (b a)
b <- Reader (Either [String] (b a))
forall (f :: * -> *) a.
GGenetic f =>
Reader (Either [String] (f a))
gget
    Either [String] ((:*:) a b a)
-> Reader (Either [String] ((:*:) a b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] ((:*:) a b a)
 -> Reader (Either [String] ((:*:) a b a)))
-> Either [String] ((:*:) a b a)
-> Reader (Either [String] ((:*:) a b a))
forall a b. (a -> b) -> a -> b
$ a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> Either [String] (a a) -> Either [String] (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [String] (a a)
a Either [String] (b a -> (:*:) a b a)
-> Either [String] (b a) -> Either [String] ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either [String] (b a)
b

-- | Meta-information (constructor names, etc.)
instance (GGenetic a, GGenetic b) => GGenetic (a :+: b) where
  gput :: (:+:) a b a -> Writer ()
gput (L1 a a
x) = Sequence -> String -> Writer ()
putAndReport [Word8
0] String
"L1" Writer () -> Writer () -> Writer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a a -> Writer ()
forall (f :: * -> *) a. GGenetic f => f a -> Writer ()
gput a a
x
  gput (R1 b a
x) = Sequence -> String -> Writer ()
putAndReport [Word8
1] String
"R1" Writer () -> Writer () -> Writer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b a -> Writer ()
forall (f :: * -> *) a. GGenetic f => f a -> Writer ()
gput b a
x
  gget :: Reader (Either [String] ((:+:) a b a))
gget = do
    Either [String] LR
a <- Int
-> (Sequence -> Either String (LR, String))
-> Reader (Either [String] LR)
forall g.
Int
-> (Sequence -> Either String (g, String))
-> Reader (Either [String] g)
getAndReport Int
1 Sequence -> Either String (LR, String)
convertLR
    case Either [String] LR
a of
      Right LR
L -> (Either [String] (a a) -> Either [String] ((:+:) a b a))
-> StateT
     (Sequence, Int, [String]) Identity (Either [String] (a a))
-> Reader (Either [String] ((:+:) a b a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a a -> (:+:) a b a)
-> Either [String] (a a) -> Either [String] ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) StateT (Sequence, Int, [String]) Identity (Either [String] (a a))
forall (f :: * -> *) a.
GGenetic f =>
Reader (Either [String] (f a))
gget
      Right LR
R -> (Either [String] (b a) -> Either [String] ((:+:) a b a))
-> StateT
     (Sequence, Int, [String]) Identity (Either [String] (b a))
-> Reader (Either [String] ((:+:) a b a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b a -> (:+:) a b a)
-> Either [String] (b a) -> Either [String] ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) StateT (Sequence, Int, [String]) Identity (Either [String] (b a))
forall (f :: * -> *) a.
GGenetic f =>
Reader (Either [String] (f a))
gget
      Left [String]
s  -> Either [String] ((:+:) a b a)
-> Reader (Either [String] ((:+:) a b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] ((:+:) a b a)
 -> Reader (Either [String] ((:+:) a b a)))
-> Either [String] ((:+:) a b a)
-> Reader (Either [String] ((:+:) a b a))
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] ((:+:) a b a)
forall a b. a -> Either a b
Left [String]
s

data LR = L | R

convertLR :: [Word8] -> Either String (LR, String)
convertLR :: Sequence -> Either String (LR, String)
convertLR (Word8
x:[]) = if Word8 -> Bool
forall a. Integral a => a -> Bool
even Word8
x -- Only care about the last bit
                     then (LR, String) -> Either String (LR, String)
forall a b. b -> Either a b
Right (LR
L, String
"L1")
                     else (LR, String) -> Either String (LR, String)
forall a b. b -> Either a b
Right (LR
R, String
"R1")
convertLR Sequence
_ = String -> Either String (LR, String)
forall a b. a -> Either a b
Left String
"logic error"

-- | Sums: encode choice between constructors
instance (GGenetic a) => GGenetic (M1 i c a) where
  gput :: M1 i c a a -> Writer ()
gput (M1 a a
x) = a a -> Writer ()
forall (f :: * -> *) a. GGenetic f => f a -> Writer ()
gput a a
x
  gget :: Reader (Either [String] (M1 i c a a))
gget = (Either [String] (a a) -> Either [String] (M1 i c a a))
-> StateT
     (Sequence, Int, [String]) Identity (Either [String] (a a))
-> Reader (Either [String] (M1 i c a a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a a -> M1 i c a a)
-> Either [String] (a a) -> Either [String] (M1 i c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) StateT (Sequence, Int, [String]) Identity (Either [String] (a a))
forall (f :: * -> *) a.
GGenetic f =>
Reader (Either [String] (f a))
gget

-- | Products: encode multiple arguments to constructors
instance (Genetic a) => GGenetic (K1 i a) where
  gput :: K1 i a a -> Writer ()
gput (K1 a
x) = a -> Writer ()
forall g. Genetic g => g -> Writer ()
put a
x
  gget :: Reader (Either [String] (K1 i a a))
gget = do
    Either [String] a
a <- Reader (Either [String] a)
forall g. Genetic g => Reader (Either [String] g)
get
    Either [String] (K1 i a a) -> Reader (Either [String] (K1 i a a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] (K1 i a a) -> Reader (Either [String] (K1 i a a)))
-> Either [String] (K1 i a a)
-> Reader (Either [String] (K1 i a a))
forall a b. (a -> b) -> a -> b
$ (a -> K1 i a a) -> Either [String] a -> Either [String] (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 Either [String] a
a

--
-- Instances
--

instance Genetic Bool where
  put :: Bool -> Writer ()
put Bool
b = Sequence -> String -> Writer ()
putAndReport [Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
b] (Bool -> String
forall a. Show a => a -> String
show Bool
b)
  get :: Reader (Either [String] Bool)
get = Int
-> (Sequence -> Either String (Bool, String))
-> Reader (Either [String] Bool)
forall g.
Int
-> (Sequence -> Either String (g, String))
-> Reader (Either [String] g)
getAndReport Int
1 Sequence -> Either String (Bool, String)
convert
    where convert :: Sequence -> Either String (Bool, String)
convert (Word8
x:[]) = (Bool, String) -> Either String (Bool, String)
forall a b. b -> Either a b
Right (Bool
g, Bool -> String
forall a. Show a => a -> String
show Bool
g)
            where g :: Bool
g = Word8 -> Bool
word8ToBool Word8
x
          convert Sequence
_ = String -> Either String (Bool, String)
forall a b. a -> Either a b
Left String
"logic error"

word8ToBool :: Word8 -> Bool
word8ToBool :: Word8 -> Bool
word8ToBool Word8
x = if Word8 -> Bool
forall a. Integral a => a -> Bool
even Word8
x then Bool
False else Bool
True

instance Genetic Char where
  put :: Char -> Writer ()
put Char
c = do
    Int -> Writer ()
forall g. Genetic g => g -> Writer ()
put (Int -> Writer ()) -> (Char -> Int) -> Char -> Writer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Writer ()) -> Char -> Writer ()
forall a b. (a -> b) -> a -> b
$ Char
c
    String -> Writer ()
replaceReportW [Char
c]
  get :: Reader (Either [String] Char)
get = do
    Either [String] Int
x <- Reader (Either [String] Int)
forall g. Genetic g => Reader (Either [String] g)
get
    case Either [String] Int
x of
      Right Int
x' -> do let c :: Char
c = Int -> Char
chr Int
x'
                     String -> Reader ()
replaceReportR [Char
c]
                     Either [String] Char -> Reader (Either [String] Char)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Char -> Reader (Either [String] Char))
-> Either [String] Char -> Reader (Either [String] Char)
forall a b. (a -> b) -> a -> b
$ Char -> Either [String] Char
forall a b. b -> Either a b
Right Char
c
      Left [String]
s   -> Either [String] Char -> Reader (Either [String] Char)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Char -> Reader (Either [String] Char))
-> Either [String] Char -> Reader (Either [String] Char)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Char
forall a b. a -> Either a b
Left [String]
s

instance Genetic Word8 where
  put :: Word8 -> Writer ()
put Word8
x = Sequence -> String -> Writer ()
putAndReport [Word8 -> Word8
forall a. Bits a => a -> a
integralToGray Word8
x] (Word8 -> String
forall a. Show a => a -> String
show Word8
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Word8")
  get :: Reader (Either [String] Word8)
get = Int
-> (Sequence -> Either String (Word8, String))
-> Reader (Either [String] Word8)
forall g.
Int
-> (Sequence -> Either String (g, String))
-> Reader (Either [String] g)
getAndReport Int
1 Sequence -> Either String (Word8, String)
forall a.
(Num a, Bits a, Show a) =>
[a] -> Either String (a, String)
convert
    where convert :: [a] -> Either String (a, String)
convert (a
x:[]) = (a, String) -> Either String (a, String)
forall a b. b -> Either a b
Right (a
g, a -> String
forall a. Show a => a -> String
show a
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Word8")
            where g :: a
g = a -> a
forall a. (Num a, Bits a) => a -> a
grayToIntegral a
x
          convert [a]
_ = String -> Either String (a, String)
forall a b. a -> Either a b
Left String
"logic error"

instance Genetic Word16 where
  put :: Word16 -> Writer ()
put Word16
g = Sequence -> String -> Writer ()
putAndReport (Int -> Word16 -> Sequence
forall t. Integral t => Int -> t -> Sequence
integralToBytes Int
2 Word16
x) (Word16 -> String
forall a. Show a => a -> String
show Word16
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Word16")
    where x :: Word16
x = Word16 -> Word16
forall a. Bits a => a -> a
integralToGray Word16
g
  get :: Reader (Either [String] Word16)
get = Int
-> (Sequence -> Either String (Word16, String))
-> Reader (Either [String] Word16)
forall g.
Int
-> (Sequence -> Either String (g, String))
-> Reader (Either [String] g)
getAndReport Int
2 Sequence -> Either String (Word16, String)
grayWord16

instance Genetic Word32 where
  put :: Word32 -> Writer ()
put Word32
g = Sequence -> String -> Writer ()
putAndReport (Int -> Word32 -> Sequence
forall t. Integral t => Int -> t -> Sequence
integralToBytes Int
4 Word32
x) (Word32 -> String
forall a. Show a => a -> String
show Word32
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Word32")
    where x :: Word32
x = Word32 -> Word32
forall a. Bits a => a -> a
integralToGray Word32
g
  get :: Reader (Either [String] Word32)
get = Int
-> (Sequence -> Either String (Word32, String))
-> Reader (Either [String] Word32)
forall g.
Int
-> (Sequence -> Either String (g, String))
-> Reader (Either [String] g)
getAndReport Int
4 Sequence -> Either String (Word32, String)
grayWord32

instance Genetic Word64 where
  put :: Word64 -> Writer ()
put Word64
g = Sequence -> String -> Writer ()
putAndReport (Int -> Word64 -> Sequence
forall t. Integral t => Int -> t -> Sequence
integralToBytes Int
8 Word64
x) (Word64 -> String
forall a. Show a => a -> String
show Word64
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Word64")
    where x :: Word64
x = Word64 -> Word64
forall a. Bits a => a -> a
integralToGray Word64
g
  get :: Reader (Either [String] Word64)
get = Int
-> (Sequence -> Either String (Word64, String))
-> Reader (Either [String] Word64)
forall g.
Int
-> (Sequence -> Either String (g, String))
-> Reader (Either [String] g)
getAndReport Int
8 Sequence -> Either String (Word64, String)
grayWord64

instance Genetic Int where
  put :: Int -> Writer ()
put Int
g = Sequence -> Writer ()
forall g. Genetic g => g -> Writer ()
put ((Word8 -> Word8) -> Sequence -> Sequence
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word8
forall a. Bits a => a -> a
integralToGray (Sequence -> Sequence) -> (Int -> Sequence) -> Int -> Sequence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Sequence
forall t. (Integral t, Binary t) => t -> Sequence
integralToByteArray (Int -> Sequence) -> Int -> Sequence
forall a b. (a -> b) -> a -> b
$ Int
g)
  get :: Reader (Either [String] Int)
get = do
    Either [String] Sequence
x <- Reader (Either [String] Sequence)
forall g. Genetic g => Reader (Either [String] g)
get
    case Either [String] Sequence
x of
      Right Sequence
xs -> Either [String] Int -> Reader (Either [String] Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Int -> Reader (Either [String] Int))
-> Either [String] Int -> Reader (Either [String] Int)
forall a b. (a -> b) -> a -> b
$ Int -> Either [String] Int
forall a b. b -> Either a b
Right (Sequence -> Int
forall t. (Integral t, Binary t) => Sequence -> t
byteArrayToIntegral (Sequence -> Int) -> (Sequence -> Sequence) -> Sequence -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8) -> Sequence -> Sequence
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word8
forall a. (Num a, Bits a) => a -> a
grayToIntegral (Sequence -> Int) -> Sequence -> Int
forall a b. (a -> b) -> a -> b
$ Sequence
xs)
      Left [String]
s   -> Either [String] Int -> Reader (Either [String] Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Int -> Reader (Either [String] Int))
-> Either [String] Int -> Reader (Either [String] Int)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Int
forall a b. a -> Either a b
Left [String]
s

instance Genetic Integer where
  put :: Integer -> Writer ()
put Integer
g = Sequence -> Writer ()
forall g. Genetic g => g -> Writer ()
put ((Word8 -> Word8) -> Sequence -> Sequence
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word8
forall a. Bits a => a -> a
integralToGray (Sequence -> Sequence)
-> (Integer -> Sequence) -> Integer -> Sequence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Sequence
forall t. (Integral t, Binary t) => t -> Sequence
integralToByteArray (Integer -> Sequence) -> Integer -> Sequence
forall a b. (a -> b) -> a -> b
$ Integer
g)
  get :: Reader (Either [String] Integer)
get = do
    Either [String] Sequence
x <- Reader (Either [String] Sequence)
forall g. Genetic g => Reader (Either [String] g)
get
    case Either [String] Sequence
x of
      Right Sequence
xs -> Either [String] Integer -> Reader (Either [String] Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Integer -> Reader (Either [String] Integer))
-> Either [String] Integer -> Reader (Either [String] Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Either [String] Integer
forall a b. b -> Either a b
Right (Sequence -> Integer
forall t. (Integral t, Binary t) => Sequence -> t
byteArrayToIntegral (Sequence -> Integer)
-> (Sequence -> Sequence) -> Sequence -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8) -> Sequence -> Sequence
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word8
forall a. (Num a, Bits a) => a -> a
grayToIntegral (Sequence -> Integer) -> Sequence -> Integer
forall a b. (a -> b) -> a -> b
$ Sequence
xs)
      Left [String]
s   -> Either [String] Integer -> Reader (Either [String] Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Integer -> Reader (Either [String] Integer))
-> Either [String] Integer -> Reader (Either [String] Integer)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Integer
forall a b. a -> Either a b
Left [String]
s

instance Genetic Double where
  put :: Double -> Writer ()
put Double
g = Integer -> Writer ()
forall g. Genetic g => g -> Writer ()
put Integer
m Writer () -> Writer () -> Writer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Writer ()
forall g. Genetic g => g -> Writer ()
put Int
n
    where (Integer
m, Int
n) = Double -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat Double
g
  get :: Reader (Either [String] Double)
get = do
    Either [String] Integer
m <- Reader (Either [String] Integer)
forall g. Genetic g => Reader (Either [String] g)
get
    case Either [String] Integer
m of
      Right Integer
m' -> do Either [String] Int
n <- Reader (Either [String] Int)
forall g. Genetic g => Reader (Either [String] g)
get
                     case Either [String] Int
n of
                       Right Int
n' -> Either [String] Double -> Reader (Either [String] Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Double -> Reader (Either [String] Double))
-> Either [String] Double -> Reader (Either [String] Double)
forall a b. (a -> b) -> a -> b
$ Double -> Either [String] Double
forall a b. b -> Either a b
Right (Integer -> Int -> Double
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
m' Int
n')
                       Left [String]
s'  -> Either [String] Double -> Reader (Either [String] Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Double -> Reader (Either [String] Double))
-> Either [String] Double -> Reader (Either [String] Double)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Double
forall a b. a -> Either a b
Left [String]
s'
      Left [String]
s   -> Either [String] Double -> Reader (Either [String] Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Double -> Reader (Either [String] Double))
-> Either [String] Double -> Reader (Either [String] Double)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Double
forall a b. a -> Either a b
Left [String]
s

instance (Genetic a) => Genetic [a] where
  put :: [a] -> Writer ()
put [a]
xs = do
    Word16 -> Writer ()
forall g. Genetic g => g -> Writer ()
put Word16
n'
    String -> Writer ()
replaceReportW (Word16 -> String
forall a. Show a => a -> String
show Word16
n' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" list length")
    (a -> Writer ()) -> [a] -> Writer ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Writer ()
forall g. Genetic g => g -> Writer ()
put [a]
xs
    where n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
          n' :: Word16
n' = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16)
                 then Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
                 else String -> Word16
forall a. HasCallStack => String -> a
error String
"List too long" :: Word16
  get :: Reader (Either [String] [a])
get = do
    Either [String] Word16
n <- Reader (Either [String] Word16)
forall g. Genetic g => Reader (Either [String] g)
get :: Reader (Either [String] Word16)
    case Either [String] Word16
n of
      Right Word16
n' -> do String -> Reader ()
replaceReportR (Word16 -> String
forall a. Show a => a -> String
show Word16
n' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" list length")
                     Int -> Reader (Either [String] [a])
forall a. Genetic a => Int -> Reader (Either [String] [a])
getList (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n')
      Left [String]
s   -> Either [String] [a] -> Reader (Either [String] [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] [a] -> Reader (Either [String] [a]))
-> Either [String] [a] -> Reader (Either [String] [a])
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] [a]
forall a b. a -> Either a b
Left [String]
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 :: Sequence -> Either String (Word16, String)
grayWord16 Sequence
bs = (Word16, String) -> Either String (Word16, String)
forall a b. b -> Either a b
Right (Word16
g, Word16 -> String
forall a. Show a => a -> String
show Word16
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Word16")
  where g :: Word16
g = Word16 -> Word16
forall a. (Num a, Bits a) => a -> a
grayToIntegral (Word16 -> Word16) -> (Sequence -> Word16) -> Sequence -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence -> Word16
forall t. Integral t => Sequence -> t
bytesToIntegral (Sequence -> Word16) -> Sequence -> Word16
forall a b. (a -> b) -> a -> b
$ Sequence
bs

grayWord32 :: [Word8] -> Either String (Word32, String)
grayWord32 :: Sequence -> Either String (Word32, String)
grayWord32 Sequence
bs = (Word32, String) -> Either String (Word32, String)
forall a b. b -> Either a b
Right (Word32
g, Word32 -> String
forall a. Show a => a -> String
show Word32
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Word32")
  where g :: Word32
g = Word32 -> Word32
forall a. (Num a, Bits a) => a -> a
grayToIntegral (Word32 -> Word32) -> (Sequence -> Word32) -> Sequence -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence -> Word32
forall t. Integral t => Sequence -> t
bytesToIntegral (Sequence -> Word32) -> Sequence -> Word32
forall a b. (a -> b) -> a -> b
$ Sequence
bs

grayWord64 :: [Word8] -> Either String (Word64, String)
grayWord64 :: Sequence -> Either String (Word64, String)
grayWord64 Sequence
bs = (Word64, String) -> Either String (Word64, String)
forall a b. b -> Either a b
Right (Word64
g, Word64 -> String
forall a. Show a => a -> String
show Word64
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Word64")
  where g :: Word64
g = Word64 -> Word64
forall a. (Num a, Bits a) => a -> a
grayToIntegral (Word64 -> Word64) -> (Sequence -> Word64) -> Sequence -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence -> Word64
forall t. Integral t => Sequence -> t
bytesToIntegral (Sequence -> Word64) -> Sequence -> Word64
forall a b. (a -> b) -> a -> b
$ Sequence
bs

integralToBytes :: Integral t => Int -> t -> [Word8]
integralToBytes :: Int -> t -> Sequence
integralToBytes Int
n t
x = Int -> t -> Sequence -> Sequence
forall t t a.
(Integral t, Num t, Num a, Eq t) =>
t -> t -> [a] -> [a]
f Int
n t
x []
  where f :: t -> t -> [a] -> [a]
f t
0 t
_ [a]
bs = [a]
bs
        f t
m t
y [a]
bs = t -> t -> [a] -> [a]
f (t
mt -> t -> t
forall a. Num a => a -> a -> a
-t
1) t
y' (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs)
          where y' :: t
y' = t
y t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
0x100
                b :: a
b = t -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t -> a) -> t -> a
forall a b. (a -> b) -> a -> b
$ t
y t -> t -> t
forall a. Integral a => a -> a -> a
`mod` t
0x100

bytesToIntegral :: Integral t => [Word8] -> t
bytesToIntegral :: Sequence -> t
bytesToIntegral Sequence
bs = (Sequence, t) -> t
forall a b. (Integral a, Num b) => ([a], b) -> b
f (Sequence
bs, t
0)
  where f :: ([a], b) -> b
f ([], b
n) = b
n
        f (a
k:[a]
ks, b
n) = ([a], b) -> b
f ([a]
ks, b
nb -> b -> b
forall a. Num a => a -> a -> a
*b
0x100 b -> b -> b
forall a. Num a => a -> a -> a
+ a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
k)

integralToByteArray :: (Integral t, Binary t) => t -> [Word8]
integralToByteArray :: t -> Sequence
integralToByteArray = ByteString -> Sequence
unpack (ByteString -> Sequence) -> (t -> ByteString) -> t -> Sequence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ByteString
forall a. Binary a => a -> ByteString
encode

byteArrayToIntegral :: (Integral t, Binary t) => [Word8] -> t
byteArrayToIntegral :: Sequence -> t
byteArrayToIntegral = ByteString -> t
forall a. Binary a => ByteString -> a
decode (ByteString -> t) -> (Sequence -> ByteString) -> Sequence -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence -> ByteString
pack

finalise :: Writer ()
finalise :: Writer ()
finalise = do
  (Sequence
xs, [String]
msgs) <- StateT (Sequence, [String]) Identity (Sequence, [String])
forall s (m :: * -> *). MonadState s m => m s
S.get
  (Sequence, [String]) -> Writer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence -> Sequence
forall a. [a] -> [a]
reverse Sequence
xs, [String] -> [String]
forall a. [a] -> [a]
reverse [String]
msgs)

getList :: Genetic a => Int -> Reader (Either [String] [a])
getList :: Int -> Reader (Either [String] [a])
getList Int
0 = Either [String] [a] -> Reader (Either [String] [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] [a] -> Reader (Either [String] [a]))
-> Either [String] [a] -> Reader (Either [String] [a])
forall a b. (a -> b) -> a -> b
$ [a] -> Either [String] [a]
forall a b. b -> Either a b
Right []
getList Int
n = do
  [Either [String] a]
cs <- [StateT (Sequence, Int, [String]) Identity (Either [String] a)]
-> StateT (Sequence, Int, [String]) Identity [Either [String] a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([StateT (Sequence, Int, [String]) Identity (Either [String] a)]
 -> StateT (Sequence, Int, [String]) Identity [Either [String] a])
-> [StateT (Sequence, Int, [String]) Identity (Either [String] a)]
-> StateT (Sequence, Int, [String]) Identity [Either [String] a]
forall a b. (a -> b) -> a -> b
$ Int
-> StateT (Sequence, Int, [String]) Identity (Either [String] a)
-> [StateT (Sequence, Int, [String]) Identity (Either [String] a)]
forall a. Int -> a -> [a]
replicate Int
n StateT (Sequence, Int, [String]) Identity (Either [String] a)
forall g. Genetic g => Reader (Either [String] g)
get
  let ([[String]]
mss, [a]
xs) = [Either [String] a] -> ([[String]], [a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either [String] a]
cs
  if [[String]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[String]]
mss
    then Either [String] [a] -> Reader (Either [String] [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] [a] -> Reader (Either [String] [a]))
-> Either [String] [a] -> Reader (Either [String] [a])
forall a b. (a -> b) -> a -> b
$ [a] -> Either [String] [a]
forall a b. b -> Either a b
Right [a]
xs
    else Either [String] [a] -> Reader (Either [String] [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] [a] -> Reader (Either [String] [a]))
-> Either [String] [a] -> Reader (Either [String] [a])
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] [a]
forall a b. a -> Either a b
Left ([[String]] -> [String]
forall a. [a] -> a
head [[String]]
mss)

-- | Write a Word8 value to the genome without encoding it
putRawWord8 :: Word8 -> Writer ()
putRawWord8 :: Word8 -> Writer ()
putRawWord8 Word8
x = do
  (Sequence
xs, [String]
msgs) <- StateT (Sequence, [String]) Identity (Sequence, [String])
forall s (m :: * -> *). MonadState s m => m s
S.get
  (Sequence, [String]) -> Writer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Word8
xWord8 -> Sequence -> Sequence
forall a. a -> [a] -> [a]
:Sequence
xs, [String]
msgs)

-- | Read a Word8 value from the genome without decoding it
getRawWord8 :: Reader (Either [String] Word8)
getRawWord8 :: Reader (Either [String] Word8)
getRawWord8 = do
  (Sequence
xs, Int
i, [String]
msgs) <- StateT (Sequence, Int, [String]) Identity (Sequence, Int, [String])
forall s (m :: * -> *). MonadState s m => m s
S.get
  let xs' :: Sequence
xs' = Int -> Sequence -> Sequence
forall a. Int -> [a] -> [a]
drop Int
i Sequence
xs
  if Sequence -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Sequence
xs'
     then Either [String] Word8 -> Reader (Either [String] Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Word8 -> Reader (Either [String] Word8))
-> Either [String] Word8 -> Reader (Either [String] Word8)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Word8
forall a b. a -> Either a b
Left [String
"End of sequence"]
     else do
       let x :: Word8
x = Sequence -> Word8
forall a. [a] -> a
head Sequence
xs'
       (Sequence, Int, [String]) -> Reader ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence
xs, Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, [String]
msgs)
       Either [String] Word8 -> Reader (Either [String] Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Word8 -> Reader (Either [String] Word8))
-> Either [String] Word8 -> Reader (Either [String] Word8)
forall a b. (a -> b) -> a -> b
$ Word8 -> Either [String] Word8
forall a b. b -> Either a b
Right Word8
x

-- | Write a raw sequence of Word8 values to the genome
putRawWord8s :: [Word8] -> Writer ()
putRawWord8s :: Sequence -> Writer ()
putRawWord8s Sequence
ws = (Word8 -> Writer ()) -> Sequence -> Writer ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> Writer ()
putRawWord8 Sequence
ws

-- | Read a raw sequence of Word8 values from the genome
getRawWord8s :: Int -> Reader (Either [String] [Word8])
getRawWord8s :: Int -> Reader (Either [String] Sequence)
getRawWord8s Int
n = ([Either [String] Word8] -> Either [String] Sequence)
-> StateT
     (Sequence, Int, [String]) Identity [Either [String] Word8]
-> Reader (Either [String] Sequence)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either [String] Word8] -> Either [String] Sequence
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (StateT (Sequence, Int, [String]) Identity [Either [String] Word8]
 -> Reader (Either [String] Sequence))
-> StateT
     (Sequence, Int, [String]) Identity [Either [String] Word8]
-> Reader (Either [String] Sequence)
forall a b. (a -> b) -> a -> b
$ Int
-> Reader (Either [String] Word8)
-> StateT
     (Sequence, Int, [String]) Identity [Either [String] Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Reader (Either [String] Word8)
getRawWord8

reportW :: String -> Writer ()
reportW :: String -> Writer ()
reportW String
desc = do
  (Sequence
xs, [String]
msgs) <- StateT (Sequence, [String]) Identity (Sequence, [String])
forall s (m :: * -> *). MonadState s m => m s
S.get
  let msg :: String
msg = Int -> String
forall a. Show a => a -> String
show (Sequence -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sequence
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": wrote " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc
  (Sequence, [String]) -> Writer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence
xs, String
msgString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
msgs)

putAndReport :: [Word8] -> String -> Writer ()
putAndReport :: Sequence -> String -> Writer ()
putAndReport Sequence
bytes String
msg = Sequence -> Writer ()
putRawWord8s Sequence
bytes Writer () -> Writer () -> Writer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Writer ()
reportW String
msg

replaceReportW :: String -> Writer ()
replaceReportW :: String -> Writer ()
replaceReportW String
desc = do
  ~(Sequence
xs, String
_:[String]
msgs) <- StateT (Sequence, [String]) Identity (Sequence, [String])
forall s (m :: * -> *). MonadState s m => m s
S.get
  let msg :: String
msg = Int -> String
forall a. Show a => a -> String
show (Sequence -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sequence
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": wrote " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc
  (Sequence, [String]) -> Writer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence
xs, String
msgString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
msgs)

reportR :: String -> Reader ()
reportR :: String -> Reader ()
reportR String
desc = do
  (Sequence
xs, Int
i, [String]
msgs) <- StateT (Sequence, Int, [String]) Identity (Sequence, Int, [String])
forall s (m :: * -> *). MonadState s m => m s
S.get
  let msg :: String
msg = Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc
  (Sequence, Int, [String]) -> Reader ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence
xs, Int
i, String
msgString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
msgs)

getAndReport :: Int -> ([Word8] -> (Either String (g, String))) -> Reader (Either [String] g)
getAndReport :: Int
-> (Sequence -> Either String (g, String))
-> Reader (Either [String] g)
getAndReport Int
n Sequence -> Either String (g, String)
parse = do
  Either [String] Sequence
a <- Int -> Reader (Either [String] Sequence)
getRawWord8s Int
n
  case Either [String] Sequence
a of
   Right Sequence
xs    -> case Sequence -> Either String (g, String)
parse Sequence
xs of
                    Right (g
g, String
msg) -> String -> Reader ()
reportR String
msg Reader ()
-> Reader (Either [String] g) -> Reader (Either [String] g)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either [String] g -> Reader (Either [String] g)
forall (m :: * -> *) a. Monad m => a -> m a
return (g -> Either [String] g
forall a b. b -> Either a b
Right g
g)
                    Left String
errMsg2   -> Either [String] g -> Reader (Either [String] g)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] g -> Reader (Either [String] g))
-> Either [String] g -> Reader (Either [String] g)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] g
forall a b. a -> Either a b
Left [String
errMsg2]
   Left [String]
errMsg -> Either [String] g -> Reader (Either [String] g)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] g -> Reader (Either [String] g))
-> Either [String] g -> Reader (Either [String] g)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] g
forall a b. a -> Either a b
Left [String]
errMsg

replaceReportR :: String -> Reader ()
replaceReportR :: String -> Reader ()
replaceReportR String
desc = do
  ~(Sequence
xs, Int
i, String
_:[String]
msgs) <- StateT (Sequence, Int, [String]) Identity (Sequence, Int, [String])
forall s (m :: * -> *). MonadState s m => m s
S.get
  let msg :: String
msg = Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc
  (Sequence, Int, [String]) -> Reader ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence
xs, Int
i, String
msgString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
msgs)

--
-- Diploid genes
--

type DiploidSequence = (Sequence, Sequence)

type DiploidReader = StateT ((Sequence, Int, [String]), (Sequence, Int, [String])) Identity

readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Either [String] g
readAndExpress :: DiploidSequence -> Either [String] g
readAndExpress (Sequence
s1, Sequence
s2) = State
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
  (Either [String] g)
-> ((Sequence, Int, [String]), (Sequence, Int, [String]))
-> Either [String] g
forall s a. State s a -> s -> a
evalState State
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
  (Either [String] g)
forall g.
(Genetic g, Diploid g) =>
DiploidReader (Either [String] g)
getAndExpress ((Sequence
s1, Int
0, []), (Sequence
s2, Int
0, []))

runDiploidReader :: DiploidReader g -> DiploidSequence -> g
runDiploidReader :: DiploidReader g -> DiploidSequence -> g
runDiploidReader DiploidReader g
r (Sequence
s1, Sequence
s2) = DiploidReader g
-> ((Sequence, Int, [String]), (Sequence, Int, [String])) -> g
forall s a. State s a -> s -> a
evalState DiploidReader g
r ((Sequence
s1, Int
0, []), (Sequence
s2, Int
0, []))

-- | Return the entire genome.
copy2 :: DiploidReader DiploidSequence
copy2 :: DiploidReader DiploidSequence
copy2 = do
  ((Sequence, Int, [String])
ra, (Sequence, Int, [String])
rb) <- StateT
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
  Identity
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
forall s (m :: * -> *). MonadState s m => m s
S.get
  let as :: Sequence
as = Reader Sequence -> (Sequence, Int, [String]) -> Sequence
forall s a. State s a -> s -> a
evalState Reader Sequence
copy (Sequence, Int, [String])
ra
  let bs :: Sequence
bs = Reader Sequence -> (Sequence, Int, [String]) -> Sequence
forall s a. State s a -> s -> a
evalState Reader Sequence
copy (Sequence, Int, [String])
rb
  DiploidSequence -> DiploidReader DiploidSequence
forall (m :: * -> *) a. Monad m => a -> m a
return (Sequence
as, Sequence
bs)

-- | Return the portion of the genome that has been read.
consumed2 :: DiploidReader DiploidSequence
consumed2 :: DiploidReader DiploidSequence
consumed2 = do
  ((Sequence, Int, [String])
ra, (Sequence, Int, [String])
rb) <- StateT
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
  Identity
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
forall s (m :: * -> *). MonadState s m => m s
S.get
  let as :: Sequence
as = Reader Sequence -> (Sequence, Int, [String]) -> Sequence
forall s a. State s a -> s -> a
evalState Reader Sequence
consumed (Sequence, Int, [String])
ra
  let bs :: Sequence
bs = Reader Sequence -> (Sequence, Int, [String]) -> Sequence
forall s a. State s a -> s -> a
evalState Reader Sequence
consumed (Sequence, Int, [String])
rb
  DiploidSequence -> DiploidReader DiploidSequence
forall (m :: * -> *) a. Monad m => a -> m a
return (Sequence
as, Sequence
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 (Either [String] g)
getAndExpress :: DiploidReader (Either [String] g)
getAndExpress = do
  ((Sequence, Int, [String])
sa, (Sequence, Int, [String])
sb) <- StateT
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
  Identity
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
forall s (m :: * -> *). MonadState s m => m s
S.get
  let (Either [String] g
a, (Sequence, Int, [String])
sa') = State (Sequence, Int, [String]) (Either [String] g)
-> (Sequence, Int, [String])
-> (Either [String] g, (Sequence, Int, [String]))
forall s a. State s a -> s -> (a, s)
runState State (Sequence, Int, [String]) (Either [String] g)
forall g. Genetic g => Reader (Either [String] g)
get (Sequence, Int, [String])
sa
  let (Either [String] g
b, (Sequence, Int, [String])
sb') = State (Sequence, Int, [String]) (Either [String] g)
-> (Sequence, Int, [String])
-> (Either [String] g, (Sequence, Int, [String]))
forall s a. State s a -> s -> (a, s)
runState State (Sequence, Int, [String]) (Either [String] g)
forall g. Genetic g => Reader (Either [String] g)
get (Sequence, Int, [String])
sb
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
-> StateT
     ((Sequence, Int, [String]), (Sequence, Int, [String])) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put ((Sequence, Int, [String])
sa', (Sequence, Int, [String])
sb')
  Either [String] g -> DiploidReader (Either [String] g)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] g -> DiploidReader (Either [String] g))
-> Either [String] g -> DiploidReader (Either [String] g)
forall a b. (a -> b) -> a -> b
$ Either [String] g -> Either [String] g -> Either [String] g
forall g.
Diploid g =>
Either [String] g -> Either [String] g -> Either [String] g
expressEither Either [String] g
a Either [String] g
b

getAndExpressWithDefault :: (Genetic g, Diploid g) => g -> DiploidReader g
getAndExpressWithDefault :: g -> DiploidReader g
getAndExpressWithDefault g
d = (Either [String] g -> g)
-> StateT
     ((Sequence, Int, [String]), (Sequence, Int, [String]))
     Identity
     (Either [String] g)
-> DiploidReader g
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (g -> Either [String] g -> g
forall a e. a -> Either e a -> a
fromEither g
d) StateT
  ((Sequence, Int, [String]), (Sequence, Int, [String]))
  Identity
  (Either [String] g)
forall g.
(Genetic g, Diploid g) =>
DiploidReader (Either [String] g)
getAndExpress

expressEither
  :: Diploid g
    => Either [String] g -> Either [String] g
      -> Either [String] g
expressEither :: Either [String] g -> Either [String] g -> Either [String] g
expressEither (Right g
a) (Right g
b) = g -> Either [String] g
forall a b. b -> Either a b
Right (g -> g -> g
forall g. Diploid g => g -> g -> g
express g
a g
b)
expressEither (Right g
a) (Left [String]
_)  = g -> Either [String] g
forall a b. b -> Either a b
Right g
a
expressEither (Left [String]
_)  (Right g
b) = g -> Either [String] g
forall a b. b -> Either a b
Right g
b
expressEither (Left [String]
xs) (Left [String]
ys) =
  [String] -> Either [String] g
forall a b. a -> Either a b
Left ([String] -> Either [String] g) -> [String] -> Either [String] g
forall a b. (a -> b) -> a -> b
$ ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"sequence 1: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
xs) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"sequence 2: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
ys)