module AI.HNN.GeneticAlgorithm
where
import Random
type Genome = [Double]
-- | Defines a context for Genome alterations
-- FIXME: perturb should be a range, or perhaps a RNG
data Context = Context {
perturb :: Double,
crossover :: Double,
mutation :: Double
}
-- | Creates a Context
mkContext :: Double -> Double -> Double -> Context
mkContext p c m = Context { perturb = p, crossover = c, mutation = m}
-- | This function gives other functions advice
shouldYou :: (RandomGen r) => r -> (Bool, r)
shouldYou r = if n < half then (False, r') else (True, r')
where (n, r') = randomR (0.0, 1.0) r
-- Haskell doesn't like comparing in the above
half :: Double
half = 0.5
-- | Mutates the Genome according to the mutation rate in the Context
mutate :: (RandomGen r) => r -> Context -> Genome -> Genome
mutate _ _ [] = []
mutate r c (g:gs) = x:(mutate r' c gs)
where
(n, r') = randomR (0.0, 1.0) r
x = if n > (mutation c) then g else g + (perturb c)
-- | Creates a singleton child from parents with random crossover
crossoverRS :: (RandomGen r) => r -> Context -> Genome -> Genome -> Genome
crossoverRS _ _ [] [] = []
crossoverRS r c (m:ms) (d:ds) = x:(crossoverRS r' c ms ds)
where
(n, r') = randomR (0.0, 1.0) r
x = if n > (crossover c) then m else d
-- For convenience and consistency with other crossover flavors to follow:
-- (This may be a Bad Idea, and if so will go away)
crossoverR :: (RandomGen r) => r -> Context -> Genome -> Genome ->
(Genome, Genome)
crossoverR r c m d = (crossoverRS r c m d, crossoverRS r c d m)
-- | Creates a pair of children by copying part of one parent into each,
-- | then swapping and copying the rest
crossoverS :: (RandomGen r) => r -> Genome -> Genome ->
(Genome, Genome)
crossoverS r m d = ((take x m) ++ (drop x d), (take x d) ++ (drop x m))
where (x, _) = randomR (0, min (length m) (length d)) r
-- | Creates a pair of children using Partially-Mapped Crossover
-- | N.B.: doesn't permute much if lists are shorter than 10 or so
crossoverPMX :: (RandomGen r) => r -> Genome -> Genome ->
(Genome, Genome)
crossoverPMX r m d =
((take x m) ++ (take y (drop x d)) ++ (drop (x+y) m),
(take x d) ++ (take y (drop x m)) ++ (drop (x+y) d))
where
l = min (length m) (length d)
(x, r') = randomR (0, l) r
(y, _) = randomR (0, l `div` 3) r'
-- These functions stand a chance of doing the implied operation,
-- but they may just give you back what you gave them
maybeMutate :: (RandomGen r) => r -> Context -> Genome -> Genome
maybeMutate r c g = let (pred, r') = shouldYou r in
case pred of
True -> mutate r' c g
False -> g
-- N.B.: there is no maybeCrossoverRP. Should there be?
maybeCrossoverR :: (RandomGen r) => r -> Context -> Genome -> Genome ->
(Genome, Genome)
maybeCrossoverR r c m d = let (pred, r') = shouldYou r in
case pred of
True -> crossoverR r' c m d
False -> (m, d)
maybeCrossoverS :: (RandomGen r) => r -> Genome -> Genome ->
(Genome, Genome)
maybeCrossoverS r m d = let (pred, r') = shouldYou r in
case pred of
True -> crossoverS r' m d
False -> (m, d)
maybeCrossoverPMX :: (RandomGen r) => r -> Genome -> Genome ->
(Genome, Genome)
maybeCrossoverPMX r m d = let (pred, r') = shouldYou r in
case pred of
True -> crossoverPMX r' m d
False -> (m, d)