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)