{- |

Common utility functions.

-}

module Moo.GeneticAlgorithm.Utilities
  (
  -- * Non-deterministic functions

    getRandomGenomes
  , doCrossovers
  , doNCrossovers
) where

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


import Control.Monad (replicateM)


-- | Generate @n@ random genomes made of elements in the

-- hyperrectangle ranges @[(from_i,to_i)]@. Return a list of genomes

-- and a new state of random number generator.

randomGenomes :: (Random a, Ord a)
              => PureMT  -- ^ random number generator

              -> Int     -- ^ n, number of genomes to generate

              -> [(a, a)]  -- ^ ranges for individual genome elements

              ->  ([Genome a], PureMT)
randomGenomes :: PureMT -> Int -> [(a, a)] -> ([Genome a], PureMT)
randomGenomes PureMT
rng Int
n [(a, a)]
ranges =
    let sortRange :: (b, b) -> (b, b)
sortRange (b
r1,b
r2) = (b -> b -> b
forall a. Ord a => a -> a -> a
min b
r1 b
r2, b -> b -> b
forall a. Ord a => a -> a -> a
max b
r1 b
r2)
        ranges' :: [(a, a)]
ranges' = ((a, a) -> (a, a)) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> (a, a)
forall b. Ord b => (b, b) -> (b, b)
sortRange [(a, a)]
ranges
    in  (Rand PureMT [Genome a] -> PureMT -> ([Genome a], PureMT))
-> PureMT -> Rand PureMT [Genome a] -> ([Genome a], PureMT)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rand PureMT [Genome a] -> PureMT -> ([Genome a], PureMT)
forall g a. Rand g a -> g -> (a, g)
runRand PureMT
rng (Rand PureMT [Genome a] -> ([Genome a], PureMT))
-> Rand PureMT [Genome a] -> ([Genome a], PureMT)
forall a b. (a -> b) -> a -> b
$
        Int -> RandT PureMT Identity (Genome a) -> Rand PureMT [Genome a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (RandT PureMT Identity (Genome a) -> Rand PureMT [Genome a])
-> RandT PureMT Identity (Genome a) -> Rand PureMT [Genome a]
forall a b. (a -> b) -> a -> b
$ ((a, a) -> RandT PureMT Identity a)
-> [(a, a)] -> RandT PureMT Identity (Genome 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
forall a. Random a => (a, a) -> Rand a
getRandomR [(a, a)]
ranges'


-- | Generate @n@ uniform random genomes with individual genome

-- elements bounded by @ranges@. This corresponds to random uniform

-- sampling of points (genomes) from a hyperrectangle with a bounding

-- box @ranges@.

getRandomGenomes :: (Random a, Ord a)
                         => Int  -- ^ @n@, how many genomes to generate

                         -> [(a, a)]  -- ^ ranges for individual genome elements

                         -> Rand [Genome a]  -- ^ random genomes

getRandomGenomes :: Int -> [(a, a)] -> Rand [Genome a]
getRandomGenomes Int
n [(a, a)]
ranges =
    (PureMT -> ([Genome a], PureMT)) -> Rand [Genome a]
forall g a. (g -> (a, g)) -> Rand g a
liftRand ((PureMT -> ([Genome a], PureMT)) -> Rand [Genome a])
-> (PureMT -> ([Genome a], PureMT)) -> Rand [Genome a]
forall a b. (a -> b) -> a -> b
$ \PureMT
rng -> PureMT -> Int -> [(a, a)] -> ([Genome a], PureMT)
forall a.
(Random a, Ord a) =>
PureMT -> Int -> [(a, a)] -> ([Genome a], PureMT)
randomGenomes PureMT
rng Int
n [(a, a)]
ranges


-- | Crossover all available parents. Parents are not repeated.

doCrossovers :: [Genome a] -> CrossoverOp a -> Rand [Genome a]
doCrossovers :: [Genome a] -> CrossoverOp a -> Rand [Genome a]
doCrossovers []      CrossoverOp a
_     = [Genome a] -> Rand [Genome a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
doCrossovers [Genome a]
parents CrossoverOp a
xover = do
  ([Genome a]
children', [Genome a]
parents') <- CrossoverOp a
xover [Genome a]
parents
  if [Genome a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Genome a]
children'
     then [Genome a] -> Rand [Genome a]
forall (m :: * -> *) a. Monad m => a -> m a
return [Genome a]
parents'
     else do
       [Genome a]
rest <- [Genome a] -> CrossoverOp a -> Rand [Genome a]
forall a. [Genome a] -> CrossoverOp a -> Rand [Genome a]
doCrossovers [Genome a]
parents' CrossoverOp a
xover
       [Genome a] -> Rand [Genome a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Genome a] -> Rand [Genome a]) -> [Genome a] -> Rand [Genome a]
forall a b. (a -> b) -> a -> b
$ [Genome a]
children' [Genome a] -> [Genome a] -> [Genome a]
forall a. [a] -> [a] -> [a]
++ [Genome a]
rest


-- | Produce exactly @n@ offsprings by repeatedly running the @crossover@

-- operator between randomly selected parents (possibly repeated).

doNCrossovers :: Int   -- ^ @n@, number of offsprings to generate

              -> [Genome a]  -- ^ @parents@' genomes

              -> CrossoverOp a  -- ^ @crossover@ operator

              -> Rand [Genome a]
doNCrossovers :: Int -> [Genome a] -> CrossoverOp a -> Rand [Genome a]
doNCrossovers Int
_ [] CrossoverOp a
_ = [Genome a] -> Rand [Genome a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
doNCrossovers Int
n [Genome a]
parents CrossoverOp a
xover =
    Int -> [[Genome a]] -> Rand [Genome a]
doAnotherNCrossovers Int
n []
  where
    doAnotherNCrossovers :: Int -> [[Genome a]] -> Rand [Genome a]
doAnotherNCrossovers Int
i [[Genome a]]
children
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0     = [Genome a] -> Rand [Genome a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Genome a] -> Rand [Genome a])
-> ([[Genome a]] -> [Genome a]) -> [[Genome a]] -> Rand [Genome a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Genome a] -> [Genome a]
forall a. Int -> [a] -> [a]
take Int
n ([Genome a] -> [Genome a])
-> ([[Genome a]] -> [Genome a]) -> [[Genome a]] -> [Genome a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Genome a]] -> [Genome a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Genome a]] -> Rand [Genome a])
-> [[Genome a]] -> Rand [Genome a]
forall a b. (a -> b) -> a -> b
$ [[Genome a]]
children
        | Bool
otherwise  = do
      ([Genome a]
children', [Genome a]
_) <- CrossoverOp a
xover CrossoverOp a
-> Rand [Genome a]
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Genome a] -> Rand [Genome a]
forall a. [a] -> Rand [a]
shuffle [Genome a]
parents
      if [Genome a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Genome a]
children'
        then Int -> [[Genome a]] -> Rand [Genome a]
doAnotherNCrossovers Int
0 [[Genome a]]
children  -- no more children

        else Int -> [[Genome a]] -> Rand [Genome a]
doAnotherNCrossovers (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Genome a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Genome a]
children') ([Genome a]
children'[Genome a] -> [[Genome a]] -> [[Genome a]]
forall a. a -> [a] -> [a]
:[[Genome a]]
children)