SHARE
TWEET

SomeChanges

a guest Oct 19th, 2010 11 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  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
RAW Paste Data
Pastebin PRO Summer Special!
Get 40% OFF on Pastebin PRO accounts!
Top