Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- module Main (main) where
- import Data.Char
- import Data.List
- import System.Random
- targetStr = "Methinks it is like a weasel"
- targetLen = 28
- populationSize = 500
- replaceProbability = (1 / fromIntegral targetLen)
- -- Sum the "difference" of two strings' chars.
- strDiff :: String -> Int
- strDiff input = sum $ zipWith (\a b -> if a == b then 0 else 1) input targetStr
- -- Generate a string of random chars
- -- (in the range 32d - 127d)
- rndString :: IO String
- rndString = do
- gen <- newStdGen
- return $ take targetLen (randomRs (' ', '~') gen)
- -- Generate a random char (in the range 32d - 127d)
- rndChar :: IO Char
- rndChar = do
- gen <- newStdGen
- return . fst $ randomR (' ', '~') gen
- -- Replace the input character with a random
- -- new character with a probability of (1/length of target)
- rndMutateChar :: Char -> IO Char
- rndMutateChar input = do
- gen <- newStdGen
- let probability = fst $ randomR (0,1) gen :: Double
- if probability <= replaceProbability then rndChar else return input
- mutateChars :: Char -> IO String -> IO String
- mutateChars char str = do
- newChar <- rndMutateChar char
- s <- str
- return $ newChar : s
- -- Randomly mutate the chars of a String
- rndMutateStr :: String -> IO String
- rndMutateStr str = foldr mutateChars (return []) str
- -- Pick either character and append it to the passed string.
- crossoverChar :: (Char, Char) -> IO String -> IO String
- crossoverChar chars str = do
- gen <- newStdGen
- s <- str
- let probability = fst $ (randomR (0, 1) gen) :: Double
- return $ (if probability <= 0.5 then fst else snd) chars : s
- -- Take 2 strings and return a new string that is
- -- created by randomly picking each char from either
- -- string
- crossoverStrings :: String -> String -> IO String
- crossoverStrings parentA parentB = foldr crossoverChar (return []) $ zip parentA parentB
- -- Generate a list (of the given length) of mutually unique random elements with
- -- in the given bounds, using the given generator.
- uniqueRandoms :: (Eq a) => (Random a) => (a, a) -> StdGen -> Int -> [a] -> IO [a]
- uniqueRandoms bounds gen targetLen acc = do
- let (randVal, newGen) = randomR bounds gen
- if length acc == targetLen
- then return acc
- else if randVal `notElem` acc
- then uniqueRandoms bounds newGen targetLen (randVal : acc)
- else uniqueRandoms bounds newGen targetLen acc
- -- Take two individuals, unpack and pass some property to a compare
- -- function, returning the property accessed using another accessor function.
- chooseIndividual :: (a -> a -> Bool) -> (b -> a) -> (b -> c) -> b -> b -> c
- chooseIndividual cmp access returnAccess individualA individualB = returnAccess $ if cmp (access individualA) (access individualB)
- then individualA
- else individualB
- withoutCrossover :: [(String, Int)] -> Int -> IO (String, Int)
- withoutCrossover population count = do
- gen <- newStdGen
- -- pick two random individuals
- indices <- uniqueRandoms (0, populationSize - 1) gen 2 []
- let individuals = map (population !!) indices
- -- If we've not evolved the target string yet, carry on
- case find ((== 0) . snd) individuals of
- Just(val) -> return (fst val, count)
- Nothing -> do
- replaceGen <- newStdGen
- -- pick the fitter individual to be the parent
- let parentStr = chooseIndividual (<=) snd fst (individuals !! 0) (individuals !! 1)
- newChildStr <- rndMutateStr parentStr
- replaceIndices <- uniqueRandoms (0, populationSize - 1) replaceGen 2 []
- -- Keep hold of the indices, so we can split/merge the population
- let replaceIndividuals = map (\i -> (i, population !! i)) replaceIndices
- -- chose the less fit individual to be replaced
- let replaceeIndex = chooseIndividual (>) (snd.snd) fst (replaceIndividuals !! 0) (replaceIndividuals !! 1)
- let splits = splitAt replaceeIndex population
- let newPopulation = fst splits ++ [(newChildStr, strDiff newChildStr)] ++ (tail . snd) splits
- withoutCrossover newPopulation (count + 1)
- withCrossover :: [(String, Int)] -> Int -> IO (String, Int)
- withCrossover population count = do
- gen <- newStdGen
- -- pick four random individuals
- indices <- uniqueRandoms (0, populationSize - 1) gen 4 []
- let individuals = map (population !!) indices
- -- If we've not evolved the target string yet, carry on
- case find ((== 0) . snd) individuals of
- Just(val) -> return (fst val, count)
- Nothing -> do
- replaceGen <- newStdGen
- -- Pick the fitter two of two pairs of individuals to be parents
- let parentA = chooseIndividual (<=) snd fst (individuals !! 0) (individuals !! 1)
- let parentB = chooseIndividual (<=) snd fst (individuals !! 2) (individuals !! 3)
- -- create the "crossover" of the two parents
- crossoverStr <- crossoverStrings parentA parentB
- newChildStr <- rndMutateStr crossoverStr
- replaceIndices <- uniqueRandoms (0, populationSize - 1) replaceGen 2 []
- -- Keep hold of the indices, so we can split/merge the population
- let replaceIndividuals = map (\i -> (i, population !! i)) replaceIndices
- -- chose the less fit individual to be replaced
- let replaceeIndex = chooseIndividual (>) (snd.snd) fst (replaceIndividuals !! 0) (replaceIndividuals !! 1)
- let splits = splitAt replaceeIndex population
- let newPopulation = fst splits ++ [(newChildStr, strDiff newChildStr)] ++ (tail . snd) splits
- withCrossover newPopulation (count + 1)
- main = do
- -- Create a list of random individuals (just strings)
- individuals <- sequence $ replicate populationSize rndString
- let individualFitnesses = map (\individual -> (individual, strDiff individual)) individuals
- -- Now evolve, first without and then with crossover
- result2 <- withoutCrossover individualFitnesses populationSize
- print result2
- result3 <- withCrossover individualFitnesses populationSize
- print result3
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement