------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Genetics.BRGCBool
-- 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
-- bits, 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.BRGCBool
  (
    Genetic(..),
    Sequence,
    Writer,
    write,
    runWriter,
    Reader,
    read,
    runReader,
    copy,
    consumed,
    DiploidSequence,
    DiploidReader,
    readAndExpress,
    runDiploidReader,
    getAndExpress,
    getAndExpressWithDefault,
    copy2,
    consumed2
  ) 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.Char (ord, chr, intToDigit)
import Data.Functor.Identity (Identity)
import Data.Word (Word8, Word16)
import GHC.Generics
import Numeric (showIntAtBase)

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

type Sequence = [Bool]

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) = Bool -> State Sequence ()
forall g. Genetic g => g -> State Sequence ()
put Bool
True 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) = Bool -> State Sequence ()
forall g. Genetic g => g -> State Sequence ()
put Bool
False 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] Bool
a <- Reader (Either [String] Bool)
forall g. Genetic g => Reader (Either [String] g)
get
    case Either [String] Bool
a of
      Right Bool
True  -> (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
      Right Bool
False -> (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 ([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
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]
++ [Bool
x])
  get :: Reader (Either [String] Bool)
get = 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] Bool -> Reader (Either [String] Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Bool -> Reader (Either [String] Bool))
-> Either [String] Bool -> Reader (Either [String] Bool)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] Bool
forall a b. a -> Either a b
Left [String
"End of sequence"]
       else do
         let x :: Bool
x = Sequence -> Bool
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] Bool -> Reader (Either [String] Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] Bool -> Reader (Either [String] Bool))
-> Either [String] Bool -> Reader (Either [String] Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Either [String] Bool
forall a b. b -> Either a b
Right Bool
x

instance Genetic Char where
  put :: Char -> State Sequence ()
put Char
c = do
    let bs :: Sequence
bs = (Char -> Bool) -> String -> Sequence
forall a b. (a -> b) -> [a] -> [b]
map (\Char
b -> Char
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'1') (String -> Sequence) -> String -> Sequence
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Char) -> Int -> String -> String
forall a.
(Integral a, Show a) =>
a -> (Int -> Char) -> a -> String -> String
showIntAtBase Int
2 Int -> Char
intToDigit (Char -> Int
ord Char
c) String
""
    Sequence -> State Sequence ()
forall g. Genetic g => g -> State Sequence ()
put Sequence
bs
  get :: Reader (Either [String] Char)
get = do
    Either [String] Sequence
bs <- Reader (Either [String] Sequence)
forall g. Genetic g => Reader (Either [String] g)
get
    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] Int -> Either [String] Char)
-> Either [String] Int
-> Reader (Either [String] Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Char) -> Either [String] Int -> Either [String] Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
chr (Either [String] Int -> Reader (Either [String] Char))
-> Either [String] Int -> Reader (Either [String] Char)
forall a b. (a -> b) -> a -> b
$ (Sequence -> Int)
-> Either [String] Sequence -> Either [String] Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Sequence -> Int
forall a. Integral a => Sequence -> a
boolsToInt Either [String] Sequence
bs

instance Genetic Word8 where
  put :: Word8 -> State Sequence ()
put = Sequence -> State Sequence ()
putRawBoolArray (Sequence -> State Sequence ())
-> (Word8 -> Sequence) -> Word8 -> State Sequence ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8 -> Sequence
forall a. (Integral a, Show a) => Int -> a -> Sequence
intToBools Int
8 (Word8 -> Sequence) -> (Word8 -> Word8) -> Word8 -> Sequence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word8
forall a. Bits a => a -> a
integralToGray
  get :: Reader (Either [String] Word8)
get = (Either [String] Sequence -> Either [String] Word8)
-> Reader (Either [String] Sequence)
-> Reader (Either [String] Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Sequence -> Word8)
-> Either [String] Sequence -> Either [String] Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word8 -> Word8
forall a. (Num a, Bits a) => a -> a
grayToIntegral (Word8 -> Word8) -> (Sequence -> Word8) -> Sequence -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence -> Word8
forall a. Integral a => Sequence -> a
boolsToInt)) (Int -> Reader (Either [String] Sequence)
getRawBoolArray Int
8)

instance Genetic Word16 where
  put :: Word16 -> State Sequence ()
put = Sequence -> State Sequence ()
putRawBoolArray (Sequence -> State Sequence ())
-> (Word16 -> Sequence) -> Word16 -> State Sequence ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word16 -> Sequence
forall a. (Integral a, Show a) => Int -> a -> Sequence
intToBools Int
16 (Word16 -> Sequence) -> (Word16 -> Word16) -> Word16 -> 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] Sequence -> Either [String] Word16)
-> Reader (Either [String] Sequence)
-> Reader (Either [String] Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Sequence -> Word16)
-> Either [String] Sequence -> 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 (Word16 -> Word16) -> (Sequence -> Word16) -> Sequence -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sequence -> Word16
forall a. Integral a => Sequence -> a
boolsToInt)) (Int -> Reader (Either [String] Sequence)
getRawBoolArray Int
16)

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
--

-- Useful when we know exactly how many bits there should be.
putRawBoolArray :: [Bool] -> Writer ()
putRawBoolArray :: Sequence -> State Sequence ()
putRawBoolArray = (Bool -> State Sequence ()) -> Sequence -> State Sequence ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Bool -> State Sequence ()
forall g. Genetic g => g -> State Sequence ()
put

getRawBoolArray :: Int -> Reader (Either [String] [Bool])
getRawBoolArray :: Int -> Reader (Either [String] Sequence)
getRawBoolArray Int
n = do
  [Either [String] Bool]
xs <- Int
-> Reader (Either [String] Bool)
-> StateT (Sequence, Int) Identity [Either [String] Bool]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Reader (Either [String] Bool)
forall g. Genetic g => Reader (Either [String] g)
get
  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
$ [Either [String] Bool] -> Either [String] Sequence
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either [String] Bool]
xs

intToBools :: (Integral a, Show a) => Int -> a -> [Bool]
intToBools :: Int -> a -> Sequence
intToBools Int
nBits a
x =
  (Char -> Bool) -> String -> Sequence
forall a b. (a -> b) -> [a] -> [b]
map (\Char
b -> Char
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'1') (String -> Sequence) -> (String -> String) -> String -> Sequence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail (String -> Sequence) -> String -> Sequence
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Char) -> Int -> String -> String
forall a.
(Integral a, Show a) =>
a -> (Int -> Char) -> a -> String -> String
showIntAtBase Int
2 Int -> Char
intToDigit Int
x' String
""
  where x' :: Int
x' = Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
nBits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Int

boolsToInt :: Integral a => [Bool] -> a
boolsToInt :: Sequence -> a
boolsToInt Sequence
bs = a -> [a] -> a
forall t. Num t => t -> [t] -> t
f a
0 [a]
ns
  where ns :: [a]
ns = (Bool -> a) -> Sequence -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> if Bool
x then a
1 else a
0) Sequence
bs
        f :: t -> [t] -> t
f t
i [] = t
i
        f t
i (t
j:[t]
js) = t -> [t] -> t
f (t
it -> t -> t
forall a. Num a => a -> a -> a
*t
2t -> t -> t
forall a. Num a => a -> a -> a
+t
j) [t]
js

--
-- 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)