SHARE
TWEET

SomeChanges

a guest Oct 27th, 2010 4 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. module Main (main) where
  2. import Data.Char
  3. import Data.List
  4. import System.Random
  5. import Control.Monad
  6. import Control.Monad.State
  7. import Data.Function (on)
  8. targetStr = "Methinks it is like a weasel"
  9. targetLen = 28
  10. populationSize = 500
  11. replaceProbability = 1 / fromIntegral targetLen
  12.  
  13. getRandom func
  14.   = do (val, gen') <- liftM func get
  15.        put gen'
  16.        return val
  17.  
  18. strDiff :: String -> Int
  19. strDiff = sum . zipWith (\ a b -> if a == b then 0 else 1) targetStr
  20.  
  21. rndString :: State StdGen String
  22. rndString = replicateM targetLen rndChar
  23.  
  24. rndChar :: State StdGen Char
  25. rndChar = getRandom (randomR (' ', '~'))
  26.  
  27. rndMutateChar :: Char -> State StdGen Char
  28. rndMutateChar input
  29.   = do roll <- getRandom (randomR (0, 1))
  30.        if (roll :: Double) <= replaceProbability then rndChar else
  31.          return input
  32.  
  33. rndMutateStr :: String -> State StdGen String
  34. rndMutateStr = mapM rndMutateChar
  35.  
  36. crossoverStrings :: String -> String -> State StdGen String
  37. crossoverStrings str1 str2
  38.   = mapM
  39.       (\ x ->
  40.          do b <- getRandom random
  41.             return (if b then fst x else snd x))
  42.       (zip str1 str2)
  43.  
  44. uniqueRandoms :: Int -> State StdGen [Int]
  45. uniqueRandoms = go []
  46.   where go acc targetLen
  47.           | length acc == targetLen = return acc
  48.           | otherwise =
  49.             do randVal <- getRandom (randomR (0, populationSize - 1))
  50.                go (if randVal `notElem` acc then randVal : acc else acc) targetLen
  51.  
  52. choose a b = fst (if on (<=) snd a b then a else b)
  53. chooseR a b = fst (if on (>) (snd . snd) a b then a else b)
  54.  
  55. withoutCrossover ::[(String, Int)] -> Int -> State StdGen (String, Int)
  56. withoutCrossover population count
  57.   = do [i1, i2] <- liftM (map (population !!)) (uniqueRandoms 2)
  58.        childStr <- rndMutateStr (choose i1 i2)
  59.        let childDiff = strDiff childStr
  60.        if childDiff == 0 then return (childStr, count) else
  61.          do [r1, r2] <- liftM (map (ap (,) (population !!))) (uniqueRandoms 2)
  62.             let (start, _ : end) = splitAt (chooseR r1 r2) population
  63.             let newPopulation = start ++ ((childStr, childDiff) : end)
  64.             withoutCrossover newPopulation (count + 1)
  65.  
  66. withCrossover ::[(String, Int)] -> Int -> State StdGen (String, Int)
  67. withCrossover population count
  68.   = do [i1, i2, i3, i4] <- liftM (map (population !!)) (uniqueRandoms 4)
  69.        let parentA = choose i1 i2
  70.        let parentB = choose i3 i4
  71.        crossoverStr <- crossoverStrings parentA parentB
  72.        childStr <- rndMutateStr crossoverStr
  73.        let childDiff = strDiff childStr
  74.        if childDiff == 0 then return (childStr, count + 1) else
  75.          do [r1, r2] <- liftM (map (ap (,) (population !!))) (uniqueRandoms 2)
  76.             let (start, _ : end) = splitAt (chooseR r1 r2) population
  77.             let newPopulation = start ++ ((childStr, childDiff) : end)
  78.             withCrossover newPopulation (count + 1)
  79.  
  80. main
  81.   = do gen <- newStdGen
  82.        let individuals = replicate populationSize (fst (runState rndString gen))
  83.        let individualFitnesses = map (ap (,) strDiff) individuals
  84.        newStdGen >>= print . fst .
  85.          runState (withoutCrossover individualFitnesses populationSize)
  86.        newStdGen >>= print . fst .
  87.          runState (withCrossover individualFitnesses populationSize)
RAW Paste Data
Top