module GA.Simple (
Chromosome(..),
runGA,
runGAIO,
zeroGeneration,
nextGeneration
) where
import System.Random
import qualified Data.List as L
import Control.Parallel.Strategies
class NFData a => Chromosome a where
crossover :: RandomGen g => g -> a -> a -> ([a],g)
mutation :: RandomGen g => g -> a -> (a,g)
fitness :: a -> Double
runGA :: (RandomGen g, Chromosome a)
=> g
-> Int
-> Double
-> (g -> (a, g))
-> (a -> Int -> Bool)
-> a
runGA gen ps mp rnd stopf =
let (pop, gen') = zeroGeneration gen rnd ps in
runGA' gen' pop ps mp stopf 0
runGA' gen pop ps mp stopf gnum =
let best = head pop in
if stopf best gnum
then best
else
let (pop', gen') = nextGeneration gen pop ps mp in
runGA' gen' pop' ps mp stopf (gnum+1)
runGAIO :: Chromosome a
=> Int
-> Double
-> (StdGen -> (a, StdGen))
-> (a -> Int -> IO Bool)
-> IO a
runGAIO ps mp rnd stopf = do
gen <- newStdGen
let (pop, gen') = zeroGeneration gen rnd ps
runGAIO' gen' pop ps mp stopf 0
runGAIO' gen pop ps mp stopf gnum = do
let best = head pop
stop <- stopf best gnum
if stop
then return best
else do
let (pop', gen') = nextGeneration gen pop ps mp
runGAIO' gen' pop' ps mp stopf (gnum+1)
zeroGeneration :: (RandomGen g)
=> g
-> (g -> (a, g))
-> Int
-> ([a],g)
zeroGeneration initGen rnd ps =
L.foldl'
(\(xs,gen) _ -> let (c, gen') = rnd gen in ((c:xs),gen'))
([], initGen) [1..ps]
nextGeneration :: (RandomGen g, Chromosome a)
=> g
-> [a]
-> Int
-> Double
-> ([a], g)
nextGeneration gen pop ps mp =
let (gen':gens) = L.unfoldr (Just . split) gen
chunks = L.zip gens $ init $ L.tails pop
results = map (\(g, (x:ys)) -> [ (t, fitness t) | t <- nextGeneration' [ (x, y) | y <- ys ] g mp [] ]) chunks
`using` parList rdeepseq
lst = take ps $ L.sortBy (\(_, fx) (_, fy) -> fy `compare` fx) $ concat results
in ( map fst lst, gen' )
nextGeneration' [] _ _ acc = acc
nextGeneration' ((p1,p2):ps) g0 mp acc =
let (children0, g1) = crossover g0 p1 p2
(children1, g2) = L.foldl'
(\(xs, g) x -> let (x', g') = mutate g x mp in (x':xs, g'))
([],g1) children0
in
nextGeneration' ps g2 mp (children1 ++ acc)
mutate :: (RandomGen g, Chromosome a) => g -> a -> Double -> (a, g)
mutate gen x mp =
let (r, gen') = randomR (0.0, 1.0) gen in
if r <= mp then mutation gen' x
else (x, gen')