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