Genetic algorithms for HNN

[Jorden Mauro]

I've started implementing GAs to plug in to HNN code. Alp has seen
this, but here it is for the folks who follow the list:

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)