Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

SomeChanges

By: a guest on Oct 19th, 2010  |  syntax: Haskell  |  size: 4.67 KB  |  views: 6  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
This paste has a previous version, view the difference. Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. module Main (main) where
  2.  
  3. import Data.Char
  4. import Data.List
  5. import System.Random
  6. import Control.Monad
  7. import Control.Monad.State
  8.  
  9. targetStr = "Methinks it is like a weasel"
  10. targetLen = 28
  11. populationSize = 500
  12. replaceProbability = 1 / fromIntegral targetLen
  13.  
  14. getRandom func = do
  15.     (val, gen') <- liftM func get
  16.     put gen'
  17.     return val
  18.  
  19. -- Sum the "difference" of two strings' chars.
  20. strDiff :: String -> Int
  21. strDiff inp = sum $ zipWith (\a b -> if a == b then 0 else 1) targetStr inp
  22.  
  23. -- Generate a string of random chars
  24. -- (in the range 32d - 127d)
  25. rndString :: State StdGen String
  26. rndString = replicateM targetLen rndChar
  27.  
  28. -- Generate a random char (in the range 32d - 127d)
  29. rndChar :: State StdGen Char
  30. rndChar = getRandom (randomR (' ', '~'))
  31.  
  32. -- Replace the input character with a random
  33. -- new character with a probability of (1/length of target)
  34. rndMutateChar :: Char -> State StdGen Char
  35. rndMutateChar input = do
  36.         roll  <- getRandom (randomR (0,1))
  37.         if (roll :: Double) <= replaceProbability then rndChar else return input
  38.  
  39. -- Randomly mutate the chars of a String
  40. rndMutateStr :: String -> State StdGen String
  41. rndMutateStr = mapM rndMutateChar
  42.  
  43. -- Take 2 strings and return a new string that is
  44. -- created by randomly picking each char from either
  45. -- string      
  46. crossoverStrings :: String -> String -> State StdGen String
  47. crossoverStrings str1 str2 = mapM
  48.                 (\x -> do { b <- getRandom random ; return (if b then fst x else snd x)})
  49.                     (zip str1 str2)
  50.  
  51. -- Generate a list (of the given length) of mutually unique random elements with
  52. -- in the given bounds, using the given generator.
  53. uniqueRandoms :: (Eq a , Random a) => Int -> (a, a) -> State StdGen [a]
  54. uniqueRandoms = go []
  55.     where go acc targetLen bounds
  56.                     | length acc == targetLen = return acc
  57.                     | otherwise = do
  58.                                     randVal <- getRandom (randomR bounds)
  59.                                     go (if randVal `notElem` acc then randVal : acc else acc)
  60.                                         targetLen bounds
  61.  
  62. choose a b = fst $ if snd a <= snd b then a else b
  63. chooseR a b = if snd (snd a) > snd (snd b) then fst a else fst b
  64.  
  65. withoutCrossover :: [(String, Int)] -> Int -> State StdGen (String, Int)
  66. withoutCrossover population count = do
  67.         -- pick two random individuals
  68.         [i1,i2] <- liftM (map (population !!)) (uniqueRandoms 2 (0, populationSize - 1))
  69.         -- If we've not evolved the target string yet, carry on
  70.         case find ((== 0) . snd) [i1,i2] of
  71.             Just val -> return (fst val, count)
  72.             Nothing   -> do
  73.                 newChildStr <- rndMutateStr (choose i1 i2)
  74.                 [r1,r2] <- liftM (map (\i ->(i,population !!i))) (uniqueRandoms 2 (0, populationSize - 1))
  75.                 let (start,_:end) = splitAt (chooseR r1 r2) population
  76.                 let newPopulation = start ++ ((newChildStr, strDiff newChildStr) : end)
  77.                 withoutCrossover newPopulation (count + 1)
  78.  
  79. withCrossover :: [(String, Int)] -> Int -> State StdGen (String,Int)
  80. withCrossover population count = do
  81.         -- pick four random individuals
  82.         [i1,i2,i3,i4] <- liftM (map (population !!)) (uniqueRandoms 4 (0, populationSize - 1))
  83.         -- If we've not evolved the target string yet, carry on
  84.         case find ((== 0) . snd) [i1,i2,i3,i4] of
  85.             Just val -> return (fst val, count)
  86.             Nothing   -> do
  87.                 -- Pick the fitter two of two pairs of individuals to be parents
  88.                 let parentA = choose i1 i2
  89.                 let parentB = choose i3 i4
  90.                 -- create the "crossover" of the two parents
  91.                 crossoverStr <- crossoverStrings parentA parentB
  92.                 newChildStr <- rndMutateStr crossoverStr
  93.                 [r1,r2] <- liftM (map (\i-> (i,population !!i))) (uniqueRandoms 2 (0, populationSize - 1))
  94.                 let (start,_:end) = splitAt (chooseR r1 r2) population
  95.                 let newPopulation = start ++ ((newChildStr, strDiff newChildStr):end)
  96.                 withCrossover newPopulation (count + 1)
  97.  
  98. main = do
  99.         -- Create a list of random individuals (just strings)
  100.         gen <- newStdGen
  101.         let individuals = replicate populationSize (fst (runState rndString gen))
  102.         let individualFitnesses = map (\individual -> (individual, strDiff individual)) individuals
  103.         -- Now evolve, first without and then with crossover
  104.         newGen <- newStdGen
  105.         print $ fst $ runState (withoutCrossover individualFitnesses populationSize) newGen
  106.         print $ fst $ runState (withCrossover individualFitnesses populationSize) newGen
clone this paste RAW Paste Data