module AI.GeneticAlgorithm.Simple (
Chromosome(..),
runGA,
runGAIO,
zeroGeneration,
nextGeneration
) where
import System.Random
import qualified Data.List as L
import Control.Parallel.Strategies
import Control.Monad.Random
import Control.Monad
import Control.Monad.IO.Class (liftIO)
class NFData a => Chromosome a where
crossover :: RandomGen g => a -> a -> Rand g [a]
mutation :: RandomGen g => a -> Rand g a
fitness :: a -> Double
runGA :: (RandomGen g, Chromosome a)
=> g
-> Int
-> Double
-> Rand g a
-> (a -> Int -> Bool)
-> a
runGA gen ps mp rnd stopf = evalRand go gen
where
go = do
pop <- zeroGeneration rnd ps
runGA' pop ps mp stopf 0
runGA' pop ps mp stopf gnum = do
let best = head pop
if stopf best gnum
then return best
else do
pop' <- nextGeneration pop ps mp
runGA' pop' ps mp stopf (gnum+1)
runGAIO :: Chromosome a
=> Int
-> Double
-> RandT StdGen IO a
-> (a -> Int -> IO Bool)
-> IO a
runGAIO ps mp rnd stopf = do
gen <- getStdGen
evalRandT go gen
where
go = do
pop <- zeroGeneration rnd ps
runGAIO' pop ps mp stopf 0
runGAIO' :: (RandomGen g, Chromosome a) => [a] -> Int -> Double -> (a -> Int -> IO Bool) -> Int -> RandT g IO a
runGAIO' pop ps mp stopf gnum = do
let best = head pop
stop <- liftIO $ stopf best gnum
if stop
then return best
else do
pop' <- nextGeneration pop ps mp
runGAIO' pop' ps mp stopf (gnum+1)
zeroGeneration :: (Monad m,RandomGen g, Chromosome a)
=> RandT g m a
-> Int
-> RandT g m [a]
zeroGeneration rnd ps = do
zp <- replicateM ps rnd
let pF = map (\p->(p,fitness p)) zp
lst = take ps $ L.sortBy (\(_, fx) (_, fy) -> fy `compare` fx) pF
return $ map fst lst
nextGeneration :: (Monad m,RandomGen g, Chromosome a)
=> [a]
-> Int
-> Double
-> RandT g m [a]
nextGeneration pop ps mp = do
gen <- getSplit
let gens = L.unfoldr (Just . split) gen
chunks = L.zip gens $ init $ L.tails pop
results = map (\(g, x : ys) -> [ (t,fitness t) | t <- evalRand (nextGeneration' [ (x, y) | y <- ys ] mp []) g ]) chunks
`using` evalList rdeepseq
let lst = take ps $ L.sortBy (\(_, fx) (_, fy) -> fy `compare` fx) $ concat results
return $ map fst lst
nextGeneration' [] _ acc = return acc
nextGeneration' ((p1,p2):ps) mp acc = do
children0 <- crossover p1 p2
children1 <- mapM (`mutate` mp) children0
nextGeneration' ps mp (children1 ++ acc)
mutate :: (RandomGen g, Chromosome a) => a -> Double -> Rand g a
mutate x mp = do
r <- getRandomR (0.0, 1.0)
if r <= mp then mutation x
else return x
normalize :: [(a,Double)] -> [(a,Double)]
normalize xs =
let
ws = map snd xs
mi = minimum ws
df = if mi < 0 then (mi) else 0
--(w-mi)/df)
in map (\(a,w)->(a,(w+df)**4)) xs
roulette :: (MonadRandom m) => Int -> [(a,Double)] -> m [(a,Double)]
roulette _ [] = error "roulette called with empty list"
roulette _ [a] = return [a]
roulette l xs = do
snd <$> foldM go (xs,[]) [1..l]
where
go (xs0,xsaccum) _ = do
(xs1,xs2) <- fromList' xs0
return (xs2,xs1:xsaccum)
fromList' :: (MonadRandom m) => [(a,Double)] -> m ((a,Double),[(a,Double)])
fromList' [] = error "fromList' called with empty list"
fromList' [a] = return (a,[])
fromList' xs = do
let s = sum (map snd xs)
xs2 = map (\(a,b)->(a,b,b)) xs
cs = scanl1 (\(_,_,q) (y,b,s') -> (y, b,s'+q)) xs2
p <- getRandomR (0.0,s)
let l1 = takeWhile (\(_,_,q) -> q < p) cs
let (r:l2) = drop (length l1) cs
return (fst' r,map fst' $ l1++l2)
where fst' (a,b,_)=(a,b)