------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Genetics.BRGCWord16
-- Copyright   :  (c) 2014-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
-- 16-bit words, 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 TypeOperators #-}
{-# LANGUAGE CPP #-}
module ALife.Creatur.Genetics.BRGCWord16
  (
    Genetic(..),
    Sequence,
    Writer,
    write,
    runWriter,
    Reader,
    read,
    runReader,
    copy,
    consumed,
    DiploidSequence,
    DiploidReader,
    readAndExpress,
    runDiploidReader,
    getAndExpress,
    getAndExpressWithDefault,
    copy2,
    consumed2,
    putRawWord16,
    getRawWord16,
    putRawWord16s,
    getRawWord16s
  ) 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.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)
import GHC.Generics

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

type Sequence = [Word16]

type Writer = StateT Sequence Identity

write :: Genetic x => x -> Sequence
write :: x -> Sequence
write x
x = State Sequence () -> Sequence -> Sequence
forall s a. State s a -> s -> s
execState (x -> State Sequence ()
forall g. Genetic g => g -> State Sequence ()
put x
x) []

runWriter :: Writer () -> Sequence
runWriter :: State Sequence () -> Sequence
runWriter State Sequence ()
w = State Sequence () -> Sequence -> Sequence
forall s a. State s a -> s -> s
execState State Sequence ()
w []

type Reader = StateT (Sequence, Int) Identity

read :: Genetic g => Sequence -> Either [String] g
read :: Sequence -> Either [String] g
read Sequence
s = State (Sequence, Int) (Either [String] g)
-> (Sequence, Int) -> Either [String] g
forall s a. State s a -> s -> a
evalState State (Sequence, Int) (Either [String] g)
forall g. Genetic g => Reader (Either [String] g)
get (Sequence
s, Int
0)

runReader :: Reader g -> Sequence -> g
runReader :: Reader g -> Sequence -> g
runReader Reader g
r Sequence
s = Reader g -> (Sequence, Int) -> g
forall s a. State s a -> s -> a
evalState Reader g
r (Sequence
s, Int
0)

-- | Return the entire genome.
copy :: Reader Sequence
copy :: Reader Sequence
copy = ((Sequence, Int) -> Sequence) -> Reader Sequence
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (Sequence, Int) -> Sequence
forall a b. (a, b) -> a
fst

-- | Return the portion of the genome that has been read.
consumed :: Reader Sequence
consumed :: Reader Sequence
consumed = do
  (Sequence
xs, Int
i) <- StateT (Sequence, Int) Identity (Sequence, Int)
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 -> State Sequence ()
forall (f :: * -> *) a. GGenetic f => f a -> State Sequence ()
gput (Rep g Any -> State Sequence ())
-> (g -> Rep g Any) -> g -> State Sequence ()
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

  getWithName :: String -> Reader (Either [String] g)
  getWithName String
s = do
    Either [String] g
g0 <- Reader (Either [String] g)
forall g. Genetic g => Reader (Either [String] g)
get
    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
$ case Either [String] g
g0 of
               (Left [String]
xs) -> [String] -> Either [String] g
forall a b. a -> Either a b
Left ((String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":")String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
               (Right g
g1) -> g -> Either [String] g
forall a b. b -> Either a b
Right g
g1

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 -> State Sequence ()
gput U1 a
U1 = () -> State Sequence ()
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 -> State Sequence ()
gput (a a
a :*: b a
b) = a a -> State Sequence ()
forall (f :: * -> *) a. GGenetic f => f a -> State Sequence ()
gput a a
a State Sequence () -> State Sequence () -> State Sequence ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b a -> State Sequence ()
forall (f :: * -> *) a. GGenetic f => f a -> State Sequence ()
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 -> State Sequence ()
gput (L1 a a
x) = Word16 -> State Sequence ()
putRawWord16 Word16
0 State Sequence () -> State Sequence () -> State Sequence ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a a -> State Sequence ()
forall (f :: * -> *) a. GGenetic f => f a -> State Sequence ()
gput a a
x
  gput (R1 b a
x) = Word16 -> State Sequence ()
putRawWord16 Word16
1 State Sequence () -> State Sequence () -> State Sequence ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b a -> State Sequence ()
forall (f :: * -> *) a. GGenetic f => f a -> State Sequence ()
gput b a
x
  gget :: Reader (Either [String] ((:+:) a b a))
gget = do
    Either [String] Word16
a <- Reader (Either [String] Word16)
getRawWord16
    case Either [String] Word16
a of
      Right Word16
x -> do
        if Word16 -> Bool
forall a. Integral a => a -> Bool
even Word16
x -- Only care about the last bit
          then (Either [String] (a a) -> Either [String] ((:+:) a b a))
-> StateT (Sequence, Int) 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) Identity (Either [String] (a a))
forall (f :: * -> *) a.
GGenetic f =>
Reader (Either [String] (f a))
gget
          else (Either [String] (b a) -> Either [String] ((:+:) a b a))
-> StateT (Sequence, Int) 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) 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

-- | Sums: encode choice between constructors
instance (GGenetic a) => GGenetic (M1 i c a) where
  gput :: M1 i c a a -> State Sequence ()
gput (M1 a a
x) = a a -> State Sequence ()
forall (f :: * -> *) a. GGenetic f => f a -> State Sequence ()
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) 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) 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 -> State Sequence ()
gput (K1 a
x) = a -> State Sequence ()
forall g. Genetic g => g -> State Sequence ()
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 -> State Sequence ()
put Bool
False = Word16 -> State Sequence ()
putRawWord16 Word16
0
  put Bool
True  = Word16 -> State Sequence ()
putRawWord16 Word16
1
  get :: Reader (Either [String] Bool)
get = (Either [String] Word16 -> Either [String] Bool)
-> Reader (Either [String] Word16) -> Reader (Either [String] Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Word16 -> Bool) -> Either [String] Word16 -> Either [String] Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word16 -> Bool
word16ToBool) Reader (Either [String] Word16)
getRawWord16

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

instance Genetic Char where
  put :: Char -> State Sequence ()
put = Int -> State Sequence ()
forall g. Genetic g => g -> State Sequence ()
put (Int -> State Sequence ())
-> (Char -> Int) -> Char -> State Sequence ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
  get :: Reader (Either [String] Char)
get = (Either [String] Int -> Either [String] Char)
-> StateT (Sequence, Int) Identity (Either [String] Int)
-> Reader (Either [String] Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Char) -> Either [String] Int -> Either [String] Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
chr) StateT (Sequence, Int) Identity (Either [String] Int)
forall g. Genetic g => Reader (Either [String] g)
get

instance Genetic Word8 where
  put :: Word8 -> State Sequence ()
put Word8
x = Word16 -> State Sequence ()
forall g. Genetic g => g -> State Sequence ()
put (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x :: Word16)
  get :: Reader (Either [String] Word8)
get = do
    Either [String] Word16
x <- Reader (Either [String] Word16)
forall g. Genetic g => Reader (Either [String] g)
get :: Reader (Either [String] Word16)
    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
$ (Word16 -> Word8)
-> Either [String] Word16 -> Either [String] Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Either [String] Word16
x

instance Genetic Word16 where
  put :: Word16 -> State Sequence ()
put = Word16 -> State Sequence ()
putRawWord16 (Word16 -> State Sequence ())
-> (Word16 -> Word16) -> Word16 -> State Sequence ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Word16
forall a. Bits a => a -> a
integralToGray
  get :: Reader (Either [String] Word16)
get = (Either [String] Word16 -> Either [String] Word16)
-> Reader (Either [String] Word16)
-> Reader (Either [String] Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Word16 -> Word16)
-> Either [String] Word16 -> Either [String] Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word16 -> Word16
forall a. (Num a, Bits a) => a -> a
grayToIntegral) Reader (Either [String] Word16)
getRawWord16

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

integralToByteArray :: (Integral t, Binary t) => t -> [Word8]
integralToByteArray :: t -> [Word8]
integralToByteArray = ByteString -> [Word8]
unpack (ByteString -> [Word8]) -> (t -> ByteString) -> t -> [Word8]
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 :: [Word8] -> t
byteArrayToIntegral = ByteString -> t
forall a. Binary a => ByteString -> a
decode (ByteString -> t) -> ([Word8] -> ByteString) -> [Word8] -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
pack

-- | Write a Word16 value to the genome without encoding it
putRawWord16 :: Word16 -> Writer ()
putRawWord16 :: Word16 -> State Sequence ()
putRawWord16 Word16
x = do
  Sequence
xs <- StateT Sequence Identity Sequence
forall s (m :: * -> *). MonadState s m => m s
S.get
  Sequence -> State Sequence ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence
xs Sequence -> Sequence -> Sequence
forall a. [a] -> [a] -> [a]
++ [Word16
x])

-- | Read a Word16 value from the genome without decoding it
getRawWord16 :: Reader (Either [String] Word16)
getRawWord16 :: Reader (Either [String] Word16)
getRawWord16 = do
  (Sequence
xs, Int
i) <- StateT (Sequence, Int) Identity (Sequence, Int)
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] Word16 -> Reader (Either [String] Word16)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Word16 -> Reader (Either [String] Word16))
-> Either [String] Word16 -> Reader (Either [String] Word16)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Word16
forall a b. a -> Either a b
Left [String
"End of sequence"]
     else do
       let x :: Word16
x = Sequence -> Word16
forall a. [a] -> a
head Sequence
xs'
       (Sequence, Int) -> StateT (Sequence, Int) Identity ()
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)
       Either [String] Word16 -> Reader (Either [String] Word16)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Word16 -> Reader (Either [String] Word16))
-> Either [String] Word16 -> Reader (Either [String] Word16)
forall a b. (a -> b) -> a -> b
$ Word16 -> Either [String] Word16
forall a b. b -> Either a b
Right Word16
x

-- | Write a raw sequence of Word16 values to the genome
putRawWord16s :: [Word16] -> Writer ()
putRawWord16s :: Sequence -> State Sequence ()
putRawWord16s Sequence
ys = do
  Sequence
xs <- StateT Sequence Identity Sequence
forall s (m :: * -> *). MonadState s m => m s
S.get
  Sequence -> State Sequence ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence
xs Sequence -> Sequence -> Sequence
forall a. [a] -> [a] -> [a]
++ Sequence
ys)

-- | Read a raw sequence of Word16 values from the genome
getRawWord16s :: Int -> Reader (Either [String] [Word16])
getRawWord16s :: Int -> Reader (Either [String] Sequence)
getRawWord16s Int
n =
  if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then Either [String] Sequence -> Reader (Either [String] Sequence)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Sequence -> Reader (Either [String] Sequence))
-> Either [String] Sequence -> Reader (Either [String] Sequence)
forall a b. (a -> b) -> a -> b
$ Sequence -> Either [String] Sequence
forall a b. b -> Either a b
Right []
    else do
      (Sequence
xs, Int
i) <- StateT (Sequence, Int) Identity (Sequence, Int)
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' Bool -> Bool -> Bool
|| Sequence -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sequence
xs' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
        then Either [String] Sequence -> Reader (Either [String] Sequence)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Sequence -> Reader (Either [String] Sequence))
-> Either [String] Sequence -> Reader (Either [String] Sequence)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Sequence
forall a b. a -> Either a b
Left [String
"End of genes"]
        else do
          let ys :: Sequence
ys = Int -> Sequence -> Sequence
forall a. Int -> [a] -> [a]
take Int
n Sequence
xs'
          (Sequence, Int) -> StateT (Sequence, Int) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Sequence
xs, Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)
          Either [String] Sequence -> Reader (Either [String] Sequence)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Sequence -> Reader (Either [String] Sequence))
-> Either [String] Sequence -> Reader (Either [String] Sequence)
forall a b. (a -> b) -> a -> b
$ Sequence -> Either [String] Sequence
forall a b. b -> Either a b
Right Sequence
ys

--
-- Diploid genes
--

type DiploidSequence = (Sequence, Sequence)

type DiploidReader = StateT ((Sequence, Int), (Sequence, Int)) Identity

readAndExpress :: (Genetic g, Diploid g) => DiploidSequence -> Either [String] g
readAndExpress :: DiploidSequence -> Either [String] g
readAndExpress (Sequence
s1, Sequence
s2) = State ((Sequence, Int), (Sequence, Int)) (Either [String] g)
-> ((Sequence, Int), (Sequence, Int)) -> Either [String] g
forall s a. State s a -> s -> a
evalState State ((Sequence, Int), (Sequence, Int)) (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), (Sequence, Int)) -> 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)
ra, (Sequence, Int)
rb) <- StateT
  ((Sequence, Int), (Sequence, Int))
  Identity
  ((Sequence, Int), (Sequence, Int))
forall s (m :: * -> *). MonadState s m => m s
S.get
  let as :: Sequence
as = Reader Sequence -> (Sequence, Int) -> Sequence
forall s a. State s a -> s -> a
evalState Reader Sequence
copy (Sequence, Int)
ra
  let bs :: Sequence
bs = Reader Sequence -> (Sequence, Int) -> Sequence
forall s a. State s a -> s -> a
evalState Reader Sequence
copy (Sequence, Int)
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)
ra, (Sequence, Int)
rb) <- StateT
  ((Sequence, Int), (Sequence, Int))
  Identity
  ((Sequence, Int), (Sequence, Int))
forall s (m :: * -> *). MonadState s m => m s
S.get
  let as :: Sequence
as = Reader Sequence -> (Sequence, Int) -> Sequence
forall s a. State s a -> s -> a
evalState Reader Sequence
consumed (Sequence, Int)
ra
  let bs :: Sequence
bs = Reader Sequence -> (Sequence, Int) -> Sequence
forall s a. State s a -> s -> a
evalState Reader Sequence
consumed (Sequence, Int)
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)
sa, (Sequence, Int)
sb) <- StateT
  ((Sequence, Int), (Sequence, Int))
  Identity
  ((Sequence, Int), (Sequence, Int))
forall s (m :: * -> *). MonadState s m => m s
S.get
  let (Either [String] g
a, (Sequence, Int)
sa') = State (Sequence, Int) (Either [String] g)
-> (Sequence, Int) -> (Either [String] g, (Sequence, Int))
forall s a. State s a -> s -> (a, s)
runState State (Sequence, Int) (Either [String] g)
forall g. Genetic g => Reader (Either [String] g)
get (Sequence, Int)
sa
  let (Either [String] g
b, (Sequence, Int)
sb') = State (Sequence, Int) (Either [String] g)
-> (Sequence, Int) -> (Either [String] g, (Sequence, Int))
forall s a. State s a -> s -> (a, s)
runState State (Sequence, Int) (Either [String] g)
forall g. Genetic g => Reader (Either [String] g)
get (Sequence, Int)
sb
  ((Sequence, Int), (Sequence, Int))
-> StateT ((Sequence, Int), (Sequence, Int)) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put ((Sequence, Int)
sa', (Sequence, Int)
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), (Sequence, Int)) 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), (Sequence, Int)) 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)