Check out the Pastebin Gadgets Shop. We have thousands of fun, geeky & affordable gadgets on sale :-)Want more features on Pastebin? Sign Up, it's FREE!
tweet

# Untitled

By: a guest on Oct 19th, 2010  |  syntax: Haskell  |  size: 6.53 KB  |  views: 37  |  expires: Never
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
Top