View difference between Paste ID: 1SySYR3s and
SHOW:
|
|
- or go back to the newest paste.
1 | - | |
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 |