{- |

Common crossover operators for genetic algorithms.

-}

module Moo.GeneticAlgorithm.Crossover
  (
  -- ** Discrete operators

    onePointCrossover
  , twoPointCrossover
  , uniformCrossover
  , noCrossover
  -- ** Application

  , doCrossovers
  , doNCrossovers
) where

import Moo.GeneticAlgorithm.Random
import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.Utilities

import Control.Monad (liftM)

-- | Crossover two lists in exactly @n@ random points.

nPointCrossover :: Int -> ([a], [a]) -> Rand ([a], [a])
nPointCrossover :: Int -> ([a], [a]) -> Rand ([a], [a])
nPointCrossover Int
n ([a]
xs,[a]
ys)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ([a], [a]) -> Rand ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs,[a]
ys)
    | Bool
otherwise =
  let len :: Int
len = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys)
  in  do
    Int
pos <- (Int, Int) -> Rand Int
forall a. Random a => (a, a) -> Rand a
getRandomR (Int
0, Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n)
    let ([a]
hxs, [a]
txs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos [a]
xs
    let ([a]
hys, [a]
tys) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos [a]
ys
    ([a]
rxs, [a]
rys) <- Int -> ([a], [a]) -> Rand ([a], [a])
forall a. Int -> ([a], [a]) -> Rand ([a], [a])
nPointCrossover (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ([a]
tys, [a]
txs) -- FIXME: not tail recursive

    ([a], [a]) -> Rand ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
hxs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rxs, [a]
hys [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rys)

-- |Select a random point in two genomes, and swap them beyond this point.

-- Apply with probability @p@.

onePointCrossover :: Double -> CrossoverOp a
onePointCrossover :: Double -> CrossoverOp a
onePointCrossover Double
_ []  = ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[])
onePointCrossover Double
_ [Genome a
celibate] = ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[Genome a
celibate])
onePointCrossover Double
p (Genome a
g1:Genome a
g2:[Genome a]
rest) = do
  (Genome a
h1,Genome a
h2) <- Double
-> ((Genome a, Genome a) -> Rand (Genome a, Genome a))
-> (Genome a, Genome a)
-> Rand (Genome a, Genome a)
forall a. Double -> (a -> Rand a) -> a -> Rand a
withProbability Double
p (Int -> (Genome a, Genome a) -> Rand (Genome a, Genome a)
forall a. Int -> ([a], [a]) -> Rand ([a], [a])
nPointCrossover Int
1) (Genome a
g1, Genome a
g2)
  ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Genome a
h1,Genome a
h2], [Genome a]
rest)

-- |Select two random points in two genomes, and swap everything in between.

-- Apply with probability @p@.

twoPointCrossover :: Double -> CrossoverOp a
twoPointCrossover :: Double -> CrossoverOp a
twoPointCrossover Double
_ []  = ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
twoPointCrossover Double
_ [Genome a
celibate] = ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[Genome a
celibate])
twoPointCrossover Double
p (Genome a
g1:Genome a
g2:[Genome a]
rest) = do
  (Genome a
h1,Genome a
h2) <- Double
-> ((Genome a, Genome a) -> Rand (Genome a, Genome a))
-> (Genome a, Genome a)
-> Rand (Genome a, Genome a)
forall a. Double -> (a -> Rand a) -> a -> Rand a
withProbability Double
p (Int -> (Genome a, Genome a) -> Rand (Genome a, Genome a)
forall a. Int -> ([a], [a]) -> Rand ([a], [a])
nPointCrossover Int
2) (Genome a
g1,Genome a
g2)
  ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Genome a
h1,Genome a
h2], [Genome a]
rest)

-- |Swap individual bits of two genomes with probability @p@.

uniformCrossover :: Double -> CrossoverOp a
uniformCrossover :: Double -> CrossoverOp a
uniformCrossover Double
_ []  = ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
uniformCrossover Double
_ [Genome a
celibate] = ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[Genome a
celibate])
uniformCrossover Double
p (Genome a
g1:Genome a
g2:[Genome a]
rest) = do
  (Genome a
h1, Genome a
h2) <- [(a, a)] -> (Genome a, Genome a)
forall a b. [(a, b)] -> ([a], [b])
unzip ([(a, a)] -> (Genome a, Genome a))
-> RandT PureMT Identity [(a, a)]
-> RandT PureMT Identity (Genome a, Genome a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ((a, a) -> RandT PureMT Identity (a, a))
-> [(a, a)] -> RandT PureMT Identity [(a, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (a, a) -> RandT PureMT Identity (a, a)
forall b. (b, b) -> Rand (b, b)
swap (Genome a -> Genome a -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip Genome a
g1 Genome a
g2)
  ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Genome a
h1,Genome a
h2], [Genome a]
rest)
  where
    swap :: (b, b) -> Rand (b, b)
swap = Double -> ((b, b) -> Rand (b, b)) -> (b, b) -> Rand (b, b)
forall a. Double -> (a -> Rand a) -> a -> Rand a
withProbability Double
p (\(b
a,b
b) -> (b, b) -> Rand (b, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b,b
a))