{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Moo.GeneticAlgorithm.Binary (
module Moo.GeneticAlgorithm.Types
, encodeGray
, decodeGray
, encodeBinary
, decodeBinary
, encodeGrayReal
, decodeGrayReal
, bitsNeeded
, splitEvery
, getRandomBinaryGenomes
, rouletteSelect
, stochasticUniversalSampling
, tournamentSelect
, withPopulationTransform
, withScale
, rankScale
, withFitnessSharing
, hammingDistance
, bestFirst
, module Moo.GeneticAlgorithm.Crossover
, pointMutate
, asymmetricMutate
, constFrequencyMutate
, 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)
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)
#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
#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
#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
#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
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
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)
toDiscreteR :: (RealFrac a)
=> (a, a)
-> Int
-> a
-> Int
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
fromDiscreteR :: (RealFrac a)
=> (a, a)
-> Int
-> Int
-> a
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
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
getRandomBinaryGenomes :: Int
-> Int
-> 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))
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))
asymmetricMutate :: Double
-> Double
-> 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
constFrequencyMutate :: Real a
=> a
-> 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
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