{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{- |

Binary genetic algorithms. Candidates solutions are represented as bit-strings.

Choose Gray code if sudden changes to the variable value after a point
mutation are undesirable, choose binary code otherwise.  In Gray code
two successive variable values differ in only one bit, it may help to
prevent premature convergence.

To apply binary genetic algorithms to real-valued problems, the real
variable may be discretized ('encodeGrayReal' and
'decodeGrayReal'). Another approach is to use continuous genetic
algorithms, see "Moo.GeneticAlgorithm.Continuous".

To encode more than one variable, just concatenate their codes.


-}

module Moo.GeneticAlgorithm.Binary (
  -- * Types

    module Moo.GeneticAlgorithm.Types

  -- * Encoding

  , encodeGray
  , decodeGray
  , encodeBinary
  , decodeBinary
  , encodeGrayReal
  , decodeGrayReal
  , bitsNeeded
  , splitEvery

  -- * Initialization

  , getRandomBinaryGenomes

  -- * Selection

  , rouletteSelect
  , stochasticUniversalSampling
  , tournamentSelect
  -- ** Scaling and niching

  , withPopulationTransform
  , withScale
  , rankScale
  , withFitnessSharing
  , hammingDistance
  -- ** Sorting

  , bestFirst


  -- * Crossover

  , module Moo.GeneticAlgorithm.Crossover

  -- * Mutation

  , pointMutate
  , asymmetricMutate
  , constFrequencyMutate

  -- * Control

  , module Moo.GeneticAlgorithm.Random
  , module Moo.GeneticAlgorithm.Run
) where

import Codec.Binary.Gray.List
import Data.Bits
import Data.List (genericLength)

import Moo.GeneticAlgorithm.Crossover
import Moo.GeneticAlgorithm.Random
import Moo.GeneticAlgorithm.Selection
import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.Run
import Moo.GeneticAlgorithm.Random
import Moo.GeneticAlgorithm.Utilities (getRandomGenomes)

-- | How many bits are needed to represent a range of integer numbers

-- @(from, to)@ (inclusive).

bitsNeeded :: (Integral a, Integral b) => (a, a) -> b
bitsNeeded :: (a, a) -> b
bitsNeeded (a
from, a
to) =
    let from' :: a
from' = a -> a -> a
forall a. Ord a => a -> a -> a
min a
from a
to
        to' :: a
to'= a -> a -> a
forall a. Ord a => a -> a -> a
max a
from a
to
    in  Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> b) -> (a -> Double) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase (Double
2::Double) (Double -> Double) -> (a -> Double) -> a -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ (a
to' a -> a -> a
forall a. Num a => a -> a -> a
- a
from' a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)

-- | Encode an integer number in the range @(from, to)@ (inclusive) as

-- binary sequence of minimal length. Use of Gray code means that a

-- single point mutation leads to incremental change of the encoded

-- value.

#if MIN_VERSION_base(4, 7, 0)
encodeGray :: (FiniteBits b, Bits b, Integral b) => (b, b) -> b -> [Bool]
#else
encodeGray :: (Bits b, Integral b) => (b, b) -> b -> [Bool]
#endif
encodeGray :: (b, b) -> b -> [Bool]
encodeGray = ([Bool] -> [Bool]) -> (b, b) -> b -> [Bool]
forall b.
(FiniteBits b, Bits b, Integral b) =>
([Bool] -> [Bool]) -> (b, b) -> b -> [Bool]
encodeWithCode [Bool] -> [Bool]
gray

-- | Decode a binary sequence using Gray code to an integer in the

-- range @(from, to)@ (inclusive). This is an inverse of 'encodeGray'.

-- Actual value returned may be greater than @to@.

#if MIN_VERSION_base(4, 7, 0)
decodeGray :: (FiniteBits b, Bits b, Integral b) => (b, b) -> [Bool] -> b
#else
decodeGray :: (Bits b, Integral b) => (b, b) -> [Bool] -> b
#endif
decodeGray :: (b, b) -> [Bool] -> b
decodeGray = ([Bool] -> [Bool]) -> (b, b) -> [Bool] -> b
forall b.
(FiniteBits b, Bits b, Integral b) =>
([Bool] -> [Bool]) -> (b, b) -> [Bool] -> b
decodeWithCode [Bool] -> [Bool]
binary

-- | Encode an integer number in the range @(from, to)@ (inclusive)

-- as a binary sequence of minimal length. Use of binary encoding

-- means that a single point mutation may lead to sudden big change

-- of the encoded value.

#if MIN_VERSION_base(4, 7, 0)
encodeBinary :: (FiniteBits b, Bits b, Integral b) => (b, b) -> b -> [Bool]
#else
encodeBinary :: (Bits b, Integral b) => (b, b) -> b -> [Bool]
#endif
encodeBinary :: (b, b) -> b -> [Bool]
encodeBinary = ([Bool] -> [Bool]) -> (b, b) -> b -> [Bool]
forall b.
(FiniteBits b, Bits b, Integral b) =>
([Bool] -> [Bool]) -> (b, b) -> b -> [Bool]
encodeWithCode [Bool] -> [Bool]
forall a. a -> a
id

-- | Decode a binary sequence to an integer in the range @(from, to)@

-- (inclusive). This is an inverse of 'encodeBinary'.  Actual value

-- returned may be greater than @to@.

#if MIN_VERSION_base(4, 7, 0)
decodeBinary :: (FiniteBits b, Bits b, Integral b) => (b, b) -> [Bool] -> b
#else
decodeBinary :: (Bits b, Integral b) => (b, b) -> [Bool] -> b
#endif
decodeBinary :: (b, b) -> [Bool] -> b
decodeBinary = ([Bool] -> [Bool]) -> (b, b) -> [Bool] -> b
forall b.
(FiniteBits b, Bits b, Integral b) =>
([Bool] -> [Bool]) -> (b, b) -> [Bool] -> b
decodeWithCode [Bool] -> [Bool]
forall a. a -> a
id

-- | Encode a real number in the range @(from, to)@ (inclusive)

-- with @n@ equally spaced discrete values in binary Gray code.

encodeGrayReal :: (RealFrac a) => (a, a) -> Int -> a -> [Bool]
encodeGrayReal :: (a, a) -> Int -> a -> [Bool]
encodeGrayReal (a, a)
range Int
n = (Int, Int) -> Int -> [Bool]
forall b.
(FiniteBits b, Bits b, Integral b) =>
(b, b) -> b -> [Bool]
encodeGray (Int
0, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int -> [Bool]) -> (a -> Int) -> a -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> Int -> a -> Int
forall a. RealFrac a => (a, a) -> Int -> a -> Int
toDiscreteR (a, a)
range Int
n

-- | Decode a binary sequence using Gray code to a real value in the

-- range @(from, to)@, assuming it was discretized with @n@ equally

-- spaced values (see 'encodeGrayReal').

decodeGrayReal :: (RealFrac a) => (a, a) -> Int -> [Bool] -> a
decodeGrayReal :: (a, a) -> Int -> [Bool] -> a
decodeGrayReal (a, a)
range Int
n = (a, a) -> Int -> Int -> a
forall a. RealFrac a => (a, a) -> Int -> Int -> a
fromDiscreteR (a, a)
range Int
n (Int -> a) -> ([Bool] -> Int) -> [Bool] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> [Bool] -> Int
forall b.
(FiniteBits b, Bits b, Integral b) =>
(b, b) -> [Bool] -> b
decodeGray (Int
0, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

-- | Represent a range @(from, to)@ of real numbers with @n@ equally

-- spaced values.  Use it to discretize a real number @val@.

toDiscreteR :: (RealFrac a)
         => (a, a) -- ^ @(from, to)@, the range to be encoded

         -> Int    -- ^ @n@, how many discrete numbers from the range to consider

         -> a      -- ^ a real number in the range @(from, to)@  to discretize

         -> Int    -- ^ a discrete value (normally in the range @(0, n-1)@)

toDiscreteR :: (a, a) -> Int -> a -> Int
toDiscreteR (a, a)
range Int
n a
val =
    let from :: a
from = (a -> a -> a) -> (a, a) -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> a
forall a. Ord a => a -> a -> a
min (a, a)
range
        to :: a
to = (a -> a -> a) -> (a, a) -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> a
forall a. Ord a => a -> a -> a
max (a, a)
range
        dx :: a
dx = (a
to a -> a -> a
forall a. Num a => a -> a -> a
- a
from) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
    in  a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ (a
val a -> a -> a
forall a. Num a => a -> a -> a
- a
from) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
dx

-- | Take a range @(from, to)@ of real numbers with @n@ equally spaced values.

-- Convert @i@-th value to a real number. This is an inverse of 'toDiscreteR'.

fromDiscreteR :: (RealFrac a)
       => (a, a)  -- ^ @(from, to)@, the encoded range

       -> Int     -- ^ @n@, how many discrete numbers from the range to consider

       -> Int     -- ^ a discrete value in the range @(0, n-1)@

       -> a       -- ^ a real number from the range

fromDiscreteR :: (a, a) -> Int -> Int -> a
fromDiscreteR (a, a)
range Int
n Int
i =
    let from :: a
from = (a -> a -> a) -> (a, a) -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> a
forall a. Ord a => a -> a -> a
min (a, a)
range
        to :: a
to = (a -> a -> a) -> (a, a) -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> a
forall a. Ord a => a -> a -> a
max (a, a)
range
        dx :: a
dx = (a
to a -> a -> a
forall a. Num a => a -> a -> a
- a
from) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
    in  a
from a -> a -> a
forall a. Num a => a -> a -> a
+ (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) a -> a -> a
forall a. Num a => a -> a -> a
* a
dx

-- | Split a list into pieces of size @n@. This may be useful to split

-- the genome into distinct equally sized “genes” which encode

-- distinct properties of the solution.

splitEvery :: Int -> [a] -> [[a]]
splitEvery :: Int -> [a] -> [[a]]
splitEvery Int
_ [] = []
splitEvery Int
n [a]
xs = let ([a]
nxs,[a]
rest) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs in [a]
nxs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
splitEvery Int
n [a]
rest

#if MIN_VERSION_base(4, 7, 0)
encodeWithCode :: (FiniteBits b, Bits b, Integral b) => ([Bool] -> [Bool]) -> (b, b) -> b -> [Bool]
#else
encodeWithCode :: (Bits b, Integral b) => ([Bool] -> [Bool]) -> (b, b) -> b -> [Bool]
#endif
encodeWithCode :: ([Bool] -> [Bool]) -> (b, b) -> b -> [Bool]
encodeWithCode [Bool] -> [Bool]
code (b
from, b
to) b
n =
    let from' :: b
from' = b -> b -> b
forall a. Ord a => a -> a -> a
min b
from b
to
        to' :: b
to' = b -> b -> b
forall a. Ord a => a -> a -> a
max b
from b
to
        nbits :: Int
nbits = (b, b) -> Int
forall a b. (Integral a, Integral b) => (a, a) -> b
bitsNeeded (b
from', b
to')
    in  [Bool] -> [Bool]
code ([Bool] -> [Bool]) -> ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take Int
nbits ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ b -> [Bool]
forall b. (Bits b, Num b) => b -> [Bool]
toList (b
n b -> b -> b
forall a. Num a => a -> a -> a
- b
from') [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ (Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False)

#if MIN_VERSION_base(4, 7, 0)
decodeWithCode :: (FiniteBits b, Bits b, Integral b) => ([Bool] -> [Bool]) -> (b, b) -> [Bool] -> b
#else
decodeWithCode :: (Bits b, Integral b) => ([Bool] -> [Bool]) -> (b, b) -> [Bool] -> b
#endif
decodeWithCode :: ([Bool] -> [Bool]) -> (b, b) -> [Bool] -> b
decodeWithCode [Bool] -> [Bool]
decode (b
from, b
to) [Bool]
bits =
    let from' :: b
from' = b -> b -> b
forall a. Ord a => a -> a -> a
min b
from b
to
    in  (b
from' b -> b -> b
forall a. Num a => a -> a -> a
+) (b -> b) -> ([Bool] -> b) -> [Bool] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> b
forall b. (Bits b, Num b) => [Bool] -> b
fromList ([Bool] -> b) -> ([Bool] -> [Bool]) -> [Bool] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [Bool]
decode ([Bool] -> b) -> [Bool] -> b
forall a b. (a -> b) -> a -> b
$ [Bool]
bits


-- | Generate @n@ random binary genomes of length @len@.

-- Return a list of genomes.

getRandomBinaryGenomes :: Int -- ^ how many genomes to generate

                       -> Int -- ^ genome length

                       -> Rand ([Genome Bool])
getRandomBinaryGenomes :: Int -> Int -> Rand [[Bool]]
getRandomBinaryGenomes Int
n Int
len = Int -> [(Bool, Bool)] -> Rand [[Bool]]
forall a. (Random a, Ord a) => Int -> [(a, a)] -> Rand [Genome a]
getRandomGenomes Int
n (Int -> (Bool, Bool) -> [(Bool, Bool)]
forall a. Int -> a -> [a]
replicate Int
len (Bool
False,Bool
True))


-- |Flips a random bit along the length of the genome with probability @p@.

-- With probability @(1 - p)@ the genome remains unaffected.

pointMutate :: Double -> MutationOp Bool
pointMutate :: Double -> MutationOp Bool
pointMutate Double
p = Double -> MutationOp Bool -> MutationOp Bool
forall a. Double -> (a -> Rand a) -> a -> Rand a
withProbability Double
p (MutationOp Bool -> MutationOp Bool)
-> MutationOp Bool -> MutationOp Bool
forall a b. (a -> b) -> a -> b
$ \[Bool]
bits -> do
       Int
r <- (Int, Int) -> Rand Int
forall a. Random a => (a, a) -> Rand a
getRandomR (Int
0, [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
       let ([Bool]
before, (Bool
bit:[Bool]
after)) = Int -> [Bool] -> ([Bool], [Bool])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
r [Bool]
bits
       MutationOp Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bool]
before [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ (Bool -> Bool
not Bool
bitBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:[Bool]
after))


-- |Flip @1@s and @0@s with different probabilities. This may help to control

-- the relative frequencies of @1@s and @0@s in the genome.

asymmetricMutate :: Double   -- ^ probability of a @False@ bit to become @True@

                 -> Double   -- ^ probability of a @True@ bit to become @False@

                 -> MutationOp Bool
asymmetricMutate :: Double -> Double -> MutationOp Bool
asymmetricMutate Double
prob0to1 Double
prob1to0 = (Bool -> RandT PureMT Identity Bool) -> MutationOp Bool
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Bool -> RandT PureMT Identity Bool
flipbit
    where
      flipbit :: Bool -> RandT PureMT Identity Bool
flipbit Bool
False = Double
-> (Bool -> RandT PureMT Identity Bool)
-> Bool
-> RandT PureMT Identity Bool
forall a. Double -> (a -> Rand a) -> a -> Rand a
withProbability Double
prob0to1 (Bool -> RandT PureMT Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> RandT PureMT Identity Bool)
-> (Bool -> Bool) -> Bool -> RandT PureMT Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not) Bool
False
      flipbit Bool
True  = Double
-> (Bool -> RandT PureMT Identity Bool)
-> Bool
-> RandT PureMT Identity Bool
forall a. Double -> (a -> Rand a) -> a -> Rand a
withProbability Double
prob1to0 (Bool -> RandT PureMT Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> RandT PureMT Identity Bool)
-> (Bool -> Bool) -> Bool -> RandT PureMT Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not) Bool
True


-- Preserving the relative frequencies of ones and zeros:

--

-- ones' = p0*(n-ones) + (1-p1)*ones

-- ones + p0*ones + (p1 - 1)*ones = p0*n

-- p0 + p1 = p0 * n / ones

--

-- zeros' = (1-p0)*zeros + p1*(n-zeros)

-- zeros + (p0 - 1)*zeros + p1*zeros = n*p1

-- p0 + p1 = p1 * n / zeros

--

-- => p0 * zeros = p1 * ones

--

-- Average number of changed bits:

--

-- m = p0*zeros + p1*ones

--

-- => p0 = m / (2*zeros)

--    p1 = m / (2*ones)

--

-- Probability of changing a bit:

--

-- p = m / n

--


-- |Flip @m@ bits on average, keeping the relative frequency of @0@s

-- and @1@s in the genome constant.

constFrequencyMutate :: Real a
                     => a                -- ^ average number of bits to change

                     -> MutationOp Bool
constFrequencyMutate :: a -> MutationOp Bool
constFrequencyMutate a
m [Bool]
bits =
    let (Rational
ones, Rational
zeros) = (Bool -> (Rational, Rational) -> (Rational, Rational))
-> (Rational, Rational) -> [Bool] -> (Rational, Rational)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Bool
b (Rational
o,Rational
z) -> if Bool
b then (Rational
oRational -> Rational -> Rational
forall a. Num a => a -> a -> a
+Rational
1,Rational
z) else (Rational
o,Rational
zRational -> Rational -> Rational
forall a. Num a => a -> a -> a
+Rational
1)) (Rational
0,Rational
0) [Bool]
bits
        p0to1 :: Double
p0to1 = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Rational
0.5 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (a -> Rational
forall a. Real a => a -> Rational
toRational a
m) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
zeros
        p1to0 :: Double
p1to0 = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Rational
0.5 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (a -> Rational
forall a. Real a => a -> Rational
toRational a
m) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
ones
    in  Double -> Double -> MutationOp Bool
asymmetricMutate Double
p0to1 Double
p1to0 [Bool]
bits


-- | Hamming distance between @x@ and @y@ is the number of coordinates

-- for which @x_i@ and @y_i@ are different.

--

-- Reference: Hamming, Richard W. (1950), “Error detecting and error

-- correcting codes”, Bell System Technical Journal 29 (2): 147–160,

-- MR 0035935.

hammingDistance :: (Eq a, Num i) => [a] -> [a] -> i
hammingDistance :: [a] -> [a] -> i
hammingDistance [a]
xs [a]
ys = [Bool] -> i
forall i a. Num i => [a] -> i
genericLength ([Bool] -> i) -> ([Bool] -> [Bool]) -> [Bool] -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter Bool -> Bool
forall a. a -> a
id ([Bool] -> i) -> [Bool] -> i
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> [a] -> [a] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(/=) [a]
xs [a]
ys