Created
April 15, 2011 17:24
-
-
Save acowley/922071 to your computer and use it in GitHub Desktop.
Haskell variation of https://github.com/jsvazic/GAHelloWorld
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE NamedFieldPuns, TupleSections #-} | |
-- |A Haskell program that demonstrates a simple "Hello, world!" | |
-- application using genetic algorithms. Based on code by John Svazic. | |
-- | |
-- Author: Anthony Cowley | |
import Control.Applicative | |
import Control.Arrow (second) | |
import Control.Monad (liftM, replicateM) | |
import Control.Monad.Random | |
import Data.Function (on) | |
import Data.List (minimumBy, sortBy, nub, (\\)) | |
import Data.Ord (comparing) | |
import Text.Printf (printf) | |
import Test.QuickCheck | |
import Test.QuickCheck.Monadic | |
import Test.HUnit hiding (assert) | |
type Gene = String | |
target :: Gene | |
target = "Hello, world!" | |
-- |Two 'Gene's mate to produce two new 'Gene's. | |
mate :: RandomGen g => Gene -> Gene -> Rand g Gene | |
mate g1 g2 = (++) <$> flip take g1 <*> flip drop g2 <$> pivot | |
where pivot = getRandomR (0, length g1 - 1) | |
-- |Change a random character in a 'Gene'. | |
mutate :: RandomGen g => Gene -> Rand g Gene | |
mutate g = (uncurry (++) .) . second . (:) <$> delta <*> parts | |
where delta = getRandomR (' ', 'z') | |
idx = getRandomR (0, length g - 1) | |
parts = second tail . flip splitAt g <$> idx | |
-- |A 'Gene''s fitness is a measure of its distance from the 'target'. | |
fitness :: Gene -> Int | |
fitness = sum . map abs . zipWith ((-) `on` fromEnum) target | |
-- |Utility to produce a random 'Gene'. | |
randomGene :: RandomGen g => Rand g Gene | |
randomGene = replicateM (length target) $ getRandomR (' ', 'z') | |
data PopInfo = PopInfo { size :: Int | |
, crossover :: Float | |
, elitism :: Float | |
, mutation :: Float } | |
-- |A 'Population' is a pair of a record describing the population, | |
-- and how it evolves, and a collection of 'Gene's. | |
type Population = (PopInfo, [Gene]) | |
-- |Default 'PopInfo'. | |
defaultPop :: PopInfo | |
defaultPop = PopInfo 1024 0.8 0.1 0.03 | |
tournamentSize :: Int | |
tournamentSize = 3 | |
-- |Helper to produce a randomized initial population. | |
randomPop :: RandomGen g => PopInfo -> Rand g Population | |
randomPop = liftA2 (,) <$> pure <*> flip replicateM randomGene . size | |
-- |Tournament selection method to select a 'Gene' from a 'Population'. | |
tournamentSelection :: RandomGen g => Population -> Rand g Gene | |
tournamentSelection (info, genes) = | |
minimumBy (comparing fitness) . map (genes !!) <$> | |
replicateM tournamentSize (getRandomR (0, size info - 1)) | |
-- Utility for executing a monadic action twice. | |
twoM :: Monad m => m a -> m (a, a) | |
twoM = liftM (\[x,y] -> (x,y)) . replicateM 2 | |
-- |Select two parents from a 'Population'. | |
selectParents :: RandomGen g => Population -> Rand g (Gene, Gene) | |
selectParents = twoM . tournamentSelection | |
-- |Run one generation of evolution for a 'Population'. | |
evolve :: RandomGen g => Population -> Rand g Population | |
evolve p@(info@(PopInfo {size, crossover, elitism, mutation}), genes) = | |
(info,) . sortBy (comparing fitness) . (take idx genes ++) <$> | |
replicateM (size - idx) (twoM getRandom >>= go) | |
where idx = round (fromIntegral size * elitism) | |
go (r1,r2) | r1 <= crossover = | |
selectParents p >>= uncurry mate >>= addChild r2 | |
| otherwise = addMutation r2 | |
addChild r c | |
| r <= mutation = mutate c | |
| otherwise = return c | |
addMutation r | |
| r <= mutation = mutate . (genes !!) =<< getRandomR (idx, size - 1) | |
| otherwise = (genes !!) <$> getRandomR (idx, size - 1) | |
-- Utility for iterating a monadic function on a seed until the seed | |
-- passes a predicate. | |
iterateUntil :: Monad m => (a -> Bool) -> (a -> m a) -> a -> m a | |
iterateUntil stop f = go | |
where go x | stop x = return x | |
| otherwise = f x >>= go | |
maxGenerations :: Int | |
maxGenerations = 16384 | |
-- Run the genetic algorithm | |
main = evalRandIO (randomPop defaultPop >>= iterateUntil done step . (, 0)) | |
>>= result | |
where step (p,gen) = (,) <$> evolve p <*> pure (gen+1) | |
done ((_, g:_), generation) = | |
generation == maxGenerations || fitness g == 0 | |
result ((_, g:_), generation) | |
| generation == maxGenerations = | |
putStrLn "Maximum generations reached without success." | |
| fitness g == 0 = printf "Reached target (%d): %s\n" generation g | |
| otherwise = putStrLn "Evolution is hard. Let's go shopping." | |
--------------------------------- TESTS ---------------------------------------- | |
testGen = run (evalRandIO randomGene) >>= assert . check | |
where check g = and $ map ($ g) [ (>= 0) . fitness | |
, (== 13) . length | |
, all (between 32 122 . fromEnum) ] | |
between l r x = l <= x && x <= r | |
testMut = run (evalRandIO $ randomGene >>= pairWithMutant) >>= assert . check | |
where pairWithMutant = liftA2 (,) <$> pure <*> mutate | |
check (g,m) = length g == length m && length (nub g \\ nub m) <= 1 | |
testMate = run (evalRandIO $ twoM randomGene >>= pairWithChild) >>= | |
assert . check | |
where pairWithChild (mom,dad) = (mom,dad,) <$> mate mom dad | |
check (m,d,c) = length c == 13 && | |
(and . map (\(_,y,z) -> y == z) . | |
dropWhile (\(x,y,_) -> x == y) $ zip3 m c d) | |
unitTests = test [ "fitness1" ~: 0 ~=? fitness "Hello, world!" | |
, "fitness2" ~: 399 ~=? fitness "H5p&J;!l<X\\7l" | |
, "fitness3" ~: 297 ~=? fitness "Vc;fx#QRP8V\\$" | |
, "fitness4" ~: 415 ~=? fitness "t\\O`E_Jx$n=NF" ] | |
runTests = do mapM_ (quickCheck . monadicIO) [testGen, testMut, testMate] | |
runTestTT unitTests |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment