This week only. Pastebin PRO Accounts Christmas Special! Don't miss out!Want more features on Pastebin? Sign Up, it's FREE!
Guest

Untitled

By: a guest on Oct 19th, 2010  |  syntax: Haskell  |  size: 6.53 KB  |  views: 35  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
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.  
  7. targetStr = "Methinks it is like a weasel"
  8. targetLen = 28
  9. populationSize = 500
  10. replaceProbability = (1 / fromIntegral targetLen)
  11.  
  12. -- Sum the "difference" of two strings' chars.
  13. strDiff :: String -> Int
  14. strDiff input = sum $ zipWith (\a b -> if a == b then 0 else 1) input targetStr
  15.  
  16. -- Generate a string of random chars
  17. -- (in the range 32d - 127d)
  18. rndString :: IO String
  19. rndString = do
  20.         gen <- newStdGen
  21.         return $ take targetLen (randomRs (' ', '~') gen)
  22.  
  23. -- Generate a random char (in the range 32d - 127d)
  24. rndChar :: IO Char
  25. rndChar = do
  26.         gen <- newStdGen
  27.         return . fst $ randomR (' ', '~') gen
  28.  
  29. -- Replace the input character with a random
  30. -- new character with a probability of (1/length of target)
  31. rndMutateChar :: Char -> IO Char
  32. rndMutateChar input = do
  33.         gen <- newStdGen
  34.         let probability = fst $ randomR (0,1) gen :: Double
  35.         if probability <= replaceProbability then rndChar else return input
  36.  
  37. mutateChars :: Char -> IO String -> IO String
  38. mutateChars char str = do
  39.         newChar <- rndMutateChar char
  40.         s <- str
  41.         return $ newChar : s
  42.  
  43. -- Randomly mutate the chars of a String
  44. rndMutateStr :: String -> IO String
  45. rndMutateStr str = foldr mutateChars (return []) str
  46.  
  47. -- Pick either character and append it to the passed string.
  48. crossoverChar :: (Char, Char) -> IO String -> IO String
  49. crossoverChar chars str = do
  50.     gen <- newStdGen
  51.     s <- str
  52.     let probability = fst $ (randomR (0, 1) gen) :: Double
  53.     return $ (if probability <= 0.5 then fst else snd) chars : s
  54.        
  55. -- Take 2 strings and return a new string that is
  56. -- created by randomly picking each char from either
  57. -- string      
  58. crossoverStrings :: String -> String -> IO String
  59. crossoverStrings parentA parentB = foldr crossoverChar (return []) $ zip parentA parentB
  60.  
  61. -- Generate a list (of the given length) of mutually unique random elements with
  62. -- in the given bounds, using the given generator.
  63. uniqueRandoms :: (Eq a) => (Random a) => (a, a) -> StdGen -> Int -> [a] -> IO [a]
  64. uniqueRandoms bounds gen targetLen acc = do
  65.         let (randVal, newGen) = randomR bounds gen
  66.         if length acc == targetLen
  67.           then return acc
  68.           else if randVal `notElem` acc
  69.                   then uniqueRandoms bounds newGen targetLen (randVal : acc)
  70.                   else uniqueRandoms bounds newGen targetLen acc
  71.  
  72. -- Take two individuals, unpack and pass some property to a compare
  73. -- function, returning the property accessed using another accessor function.
  74. chooseIndividual :: (a -> a -> Bool) -> (b -> a) -> (b -> c) -> b -> b -> c
  75. chooseIndividual cmp access returnAccess individualA individualB = returnAccess $ if cmp (access individualA) (access individualB)
  76.                                                                                     then individualA
  77.                                                                                     else individualB
  78.  
  79. withoutCrossover :: [(String, Int)] -> Int -> IO (String, Int)
  80. withoutCrossover population count = do
  81.         gen <- newStdGen
  82.         -- pick two random individuals
  83.         indices <- uniqueRandoms (0, populationSize - 1) gen 2 []
  84.         let individuals = map (population !!) indices
  85.         -- If we've not evolved the target string yet, carry on
  86.         case find ((== 0) . snd) individuals of
  87.             Just(val) -> return (fst val, count)
  88.             Nothing   -> do
  89.                 replaceGen <- newStdGen
  90.                 -- pick the fitter individual to be the parent
  91.                 let parentStr = chooseIndividual (<=) snd fst (individuals !! 0) (individuals !! 1)
  92.                 newChildStr <- rndMutateStr parentStr
  93.                 replaceIndices <- uniqueRandoms (0, populationSize - 1) replaceGen 2 []
  94.                 -- Keep hold of the indices, so we can split/merge the population
  95.                 let replaceIndividuals = map (\i -> (i, population !! i)) replaceIndices
  96.                 -- chose the less fit individual to be replaced
  97.                 let replaceeIndex = chooseIndividual (>) (snd.snd) fst (replaceIndividuals !! 0) (replaceIndividuals !! 1)
  98.                 let splits = splitAt replaceeIndex population
  99.                 let newPopulation = fst splits ++ [(newChildStr, strDiff newChildStr)] ++ (tail . snd) splits
  100.                 withoutCrossover newPopulation (count + 1)
  101.  
  102. withCrossover :: [(String, Int)] -> Int -> IO (String, Int)
  103. withCrossover population count = do
  104.         gen <- newStdGen
  105.         -- pick four random individuals
  106.         indices <- uniqueRandoms (0, populationSize - 1) gen 4 []
  107.         let individuals = map (population !!) indices
  108.         -- If we've not evolved the target string yet, carry on
  109.         case find ((== 0) . snd) individuals of
  110.             Just(val) -> return (fst val, count)
  111.             Nothing   -> do
  112.                 replaceGen <- newStdGen
  113.                 -- Pick the fitter two of two pairs of individuals to be parents
  114.                 let parentA = chooseIndividual (<=) snd fst (individuals !! 0) (individuals !! 1)
  115.                 let parentB = chooseIndividual (<=) snd fst (individuals !! 2) (individuals !! 3)
  116.                 -- create the "crossover" of the two parents
  117.                 crossoverStr <- crossoverStrings parentA parentB
  118.                 newChildStr <- rndMutateStr crossoverStr
  119.                 replaceIndices <- uniqueRandoms (0, populationSize - 1) replaceGen 2 []
  120.                 -- Keep hold of the indices, so we can split/merge the population
  121.                 let replaceIndividuals = map (\i -> (i, population !! i)) replaceIndices
  122.                 -- chose the less fit individual to be replaced
  123.                 let replaceeIndex = chooseIndividual (>) (snd.snd) fst (replaceIndividuals !! 0) (replaceIndividuals !! 1)
  124.                 let splits = splitAt replaceeIndex population
  125.                 let newPopulation = fst splits ++ [(newChildStr, strDiff newChildStr)] ++ (tail . snd) splits
  126.                 withCrossover newPopulation (count + 1)
  127.  
  128. main = do
  129.         -- Create a list of random individuals (just strings)
  130.         individuals <- sequence $ replicate populationSize rndString
  131.         let individualFitnesses = map (\individual -> (individual, strDiff individual)) individuals
  132.         -- Now evolve, first without and then with crossover
  133.         result2 <- withoutCrossover individualFitnesses populationSize
  134.         print result2
  135.         result3 <- withCrossover individualFitnesses populationSize
  136.         print result3
clone this paste RAW Paste Data