------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Genetics.Recombination
-- Copyright   :  (c) 2011-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- Provides a mechanism to break apart and rejoin sequences of data. 
-- Inspired by DNA recombination in biology, this technique can be used
-- to recombine \"genetic\" instructions for building artificial life.
--
------------------------------------------------------------------------
module ALife.Creatur.Genetics.Recombination
  (
    crossover,
    cutAndSplice,
    mutateList,
    mutatePairedLists,
    randomOneOfList,
    randomOneOfPair,
    randomCrossover,
    randomCutAndSplice,
    repeatWithProbability,
    withProbability
  ) where

import ALife.Creatur.Util (safeReplaceElement)

import System.Random (Random)
import Control.Exception.Base (assert)
import Control.Monad.Random (Rand, RandomGen, getRandom, getRandomR)

-- | Cuts two lists at the specified locations, swaps the ends, and 
--   splices them. The resulting lists will be:
--   @
--     a[0..n-1] ++ b[m..]
--     b[0..m-1] ++ a[n..]
--   @
--   Here are some examples.
--   @
--     /Expression/                               /Result/
--     'cutAndSplice' 2 5 (\"abcdef\", \"ABCDEF\")    (\"abF\",\"ABCDEcdef\")
--     'cutAndSplice' 3 1 (\"abcd\", \"ABCDEFG\")     (\"abcBCDEFG\",\"Ad\")
--     'cutAndSplice' 4 4 (\"abcdef\", \"ABCDEF\")    (\"abcdEF\",\"ABCDef\")
--   @
--   If n <= 0 or m <= 0, the corresponding input list will be completely
--   transferred to the other.
--   @
--     /Expression/                               /Result/
--     'cutAndSplice' 0 4 (\"abcdef\", \"ABCDEF\")    (\"EF\",\"ABCDabcdef\")
--     'cutAndSplice' (-2) 4 (\"abcd\", \"ABCDEFGH\") (\"EFGH\",\"ABCDabcd\")
--     'cutAndSplice' 5 0 (\"abcdef\", \"ABCDEF\")    (\"abcdeABCDEF\",\"f\")
--   @
--   If n or m are greater than or equal to length of the corresponding list,
--   that list will not be transferred.
--   @
--     /Expression/                               /Result/
--     'cutAndSplice' 10 0 (\"abcdef\", \"ABCDEF\")   (\"abcdefABCDEF\",\"\")
--     'cutAndSplice' 0 0 (\"\", \"ABCDEF\")          (\"ABCDEF\",\"\")
--   @
cutAndSplice :: Int -> Int -> ([a], [a]) -> ([a], [a])
cutAndSplice :: Int -> Int -> ([a], [a]) -> ([a], [a])
cutAndSplice Int
n Int
m ([a]
as, [a]
bs) = ([a]
cs, [a]
ds)
    where cs :: [a]
cs = [a]
as1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
bs2
          ds :: [a]
ds = [a]
bs1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
as2
          ([a]
as1, [a]
as2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
as
          ([a]
bs1, [a]
bs2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
m [a]
bs

-- | Same as @'cutAndSplice'@, except that the two locations are
--   chosen at random.
randomCutAndSplice :: RandomGen g => ([a], [a]) -> Rand g ([a], [a])
randomCutAndSplice :: ([a], [a]) -> Rand g ([a], [a])
randomCutAndSplice ([a]
as, [a]
bs) = do
    Int
n <- (Int, Int) -> RandT g Identity Int
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
0,[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Int
m <- (Int, Int) -> RandT g Identity Int
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
0,[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    ([a], [a]) -> Rand g ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> ([a], [a]) -> ([a], [a])
forall a. Int -> Int -> ([a], [a]) -> ([a], [a])
cutAndSplice Int
n Int
m ([a]
as, [a]
bs))

-- | Cuts two lists at the specified location, swaps the ends, and 
--   splices them. This is a variation of 'cutAndSplice' where n == m.
crossover :: Int -> ([a], [a]) -> ([a], [a])
crossover :: Int -> ([a], [a]) -> ([a], [a])
crossover Int
n = Int -> Int -> ([a], [a]) -> ([a], [a])
forall a. Int -> Int -> ([a], [a]) -> ([a], [a])
cutAndSplice Int
n Int
n

-- | Same as @'crossover'@, except that the location is chosen at 
--   random.
randomCrossover :: RandomGen g => ([a], [a]) -> Rand g ([a], [a])
randomCrossover :: ([a], [a]) -> Rand g ([a], [a])
randomCrossover ([a]
as, [a]
bs) = do
    Int
n <- (Int, Int) -> RandT g Identity Int
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
0,[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    ([a], [a]) -> Rand g ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ([a], [a]) -> ([a], [a])
forall a. Int -> ([a], [a]) -> ([a], [a])
crossover Int
n ([a]
as, [a]
bs))

-- | Mutates a random element in the list.
mutateList :: (Random n, RandomGen g) => [n] -> Rand g [n]
mutateList :: [n] -> Rand g [n]
mutateList [n]
xs = do
  (Int
i, n
_) <- [n] -> Rand g (Int, n)
forall g a. RandomGen g => [a] -> Rand g (Int, a)
randomListSelection [n]
xs
  n
x <- RandT g Identity n
forall (m :: * -> *) a. (MonadRandom m, Random a) => m a
getRandom
  [n] -> Rand g [n]
forall (m :: * -> *) a. Monad m => a -> m a
return ([n] -> Int -> n -> [n]
forall a. [a] -> Int -> a -> [a]
safeReplaceElement [n]
xs Int
i n
x)

-- | Mutates a random element in one list in a pair.
mutatePairedLists :: 
  (Random n, RandomGen g) => ([n], [n]) -> Rand g ([n], [n])
mutatePairedLists :: ([n], [n]) -> Rand g ([n], [n])
mutatePairedLists ([n]
xs,[n]
ys) = do
  Bool
chooseFst <- Double -> Rand g Bool
forall g. RandomGen g => Double -> Rand g Bool
weightedRandomBoolean Double
0.5
  if Bool
chooseFst 
    then do
      [n]
xs' <- [n] -> Rand g [n]
forall n g. (Random n, RandomGen g) => [n] -> Rand g [n]
mutateList [n]
xs
      ([n], [n]) -> Rand g ([n], [n])
forall (m :: * -> *) a. Monad m => a -> m a
return ([n]
xs', [n]
ys)
    else do
      [n]
ys' <- [n] -> Rand g [n]
forall n g. (Random n, RandomGen g) => [n] -> Rand g [n]
mutateList [n]
ys
      ([n], [n]) -> Rand g ([n], [n])
forall (m :: * -> *) a. Monad m => a -> m a
return ([n]
xs, [n]
ys')

-- | Performs an operation with the specified probability.
withProbability :: RandomGen g => Double -> (b -> Rand g b) -> b -> Rand g b
withProbability :: Double -> (b -> Rand g b) -> b -> Rand g b
withProbability Double
p b -> Rand g b
op b
genes = do
  Bool
doOp <- Double -> Rand g Bool
forall g. RandomGen g => Double -> Rand g Bool
weightedRandomBoolean Double
p
  if Bool
doOp then b -> Rand g b
op b
genes else b -> Rand g b
forall (m :: * -> *) a. Monad m => a -> m a
return b
genes

-- | Performs an operation a random number of times.
--   The probability of repeating the operation @n@ times is @p^n@.
repeatWithProbability :: RandomGen g => Double -> (b -> Rand g b) -> b -> Rand g b
repeatWithProbability :: Double -> (b -> Rand g b) -> b -> Rand g b
repeatWithProbability Double
p b -> Rand g b
op b
genes = do
  Bool
doOp <- Double -> Rand g Bool
forall g. RandomGen g => Double -> Rand g Bool
weightedRandomBoolean Double
p
  if Bool
doOp 
    then do
      b
genes' <- b -> Rand g b
op b
genes
      Double -> (b -> Rand g b) -> b -> Rand g b
forall g b.
RandomGen g =>
Double -> (b -> Rand g b) -> b -> Rand g b
repeatWithProbability Double
p b -> Rand g b
op b
genes'
    else b -> Rand g b
forall (m :: * -> *) a. Monad m => a -> m a
return b
genes


-- :m + ALife.Creatur.Genetics.Gene
-- let g = (replicate 10 A, replicate 10 C)
-- evalRandIO (withProbability 0.1 randomCrossover g >>= withProbability 0.01 randomCutAndSplice >>= withProbability 0.001 mutatePairedLists)
-- Any mixing of As and Cs will be the result of crossover (if the lengths are the same) or cut-and-splice (if the lengths are different).
-- Any Gs or Ts that show up are the result of mutation.
-- evalRandIO (withProbability 0.5 randomCrossover g >>= withProbability 0.05 randomCutAndSplice >>= withProbability 0.5 mutatePairedLists >>= randomOneOfPair)


-- | Randomly select a boolean, but weighted to return True with probability 
--   p.
weightedRandomBoolean :: RandomGen g => Double -> Rand g Bool
weightedRandomBoolean :: Double -> Rand g Bool
weightedRandomBoolean Double
p = do
  Double
x <- (Double, Double) -> RandT g Identity Double
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Double
0.0,Double
1.0)
  Bool -> Rand g Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
p)

randomOneOfPair :: RandomGen g => (a, a) -> Rand g a
randomOneOfPair :: (a, a) -> Rand g a
randomOneOfPair (a, a)
pair = do
  Bool
chooseFst <- Double -> Rand g Bool
forall g. RandomGen g => Double -> Rand g Bool
weightedRandomBoolean Double
0.5
  if Bool
chooseFst 
    then a -> Rand g a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Rand g a) -> a -> Rand g a
forall a b. (a -> b) -> a -> b
$ (a, a) -> a
forall a b. (a, b) -> a
fst (a, a)
pair
    else a -> Rand g a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Rand g a) -> a -> Rand g a
forall a b. (a -> b) -> a -> b
$ (a, a) -> a
forall a b. (a, b) -> b
snd (a, a)
pair

randomOneOfList :: RandomGen g => [a] -> Rand g a
randomOneOfList :: [a] -> Rand g a
randomOneOfList [a]
xs = do
  (Int
_, a
z) <- [a] -> Rand g (Int, a)
forall g a. RandomGen g => [a] -> Rand g (Int, a)
randomListSelection [a]
xs
  a -> Rand g a
forall (m :: * -> *) a. Monad m => a -> m a
return a
z

---- | Sample a random element from a weighted list.
----   The total weight of all elements must not be 0.
---- Adapted from the code in MonadRandom
--randomWeightedChoice :: RandomGen g => [(a, Double)] -> Rand g a
--randomWeightedChoice [] = error "randomFromList called with empty list"
--randomWeightedChoice [(x,_)] = return x
--randomWeightedChoice xs = do
--  let s = sum $ map snd xs -- total weight
--  let cs = scanl1 (\(_,q) (y,s') -> (y, s'+q)) xs     -- cumulative weight
--  p <- getRandomR (0.0,s)
--  return (fst (head (dropWhile (\(_,q) -> q < p) cs)))

-- | Choose an element at random from a list and return the element and its 
--   index
randomListSelection :: RandomGen g => [a] -> Rand g (Int, a)
randomListSelection :: [a] -> Rand g (Int, a)
randomListSelection [a]
xs = Bool -> Rand g (Int, a) -> Rand g (Int, a)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ [a]
xs) (Rand g (Int, a) -> Rand g (Int, a))
-> Rand g (Int, a) -> Rand g (Int, a)
forall a b. (a -> b) -> a -> b
$ do
  Int
i <- (Int, Int) -> RandT g Identity Int
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Int
0,[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  (Int, a) -> Rand g (Int, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, [a]
xs [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
i)