Initial data commit

Task/Evolutionary-algorithm/Haskell/evolutionary-algorithm-1.hs

@@ -0,0 +1,48 @@
+import System.Random
+import Control.Monad
+import Data.List
+import Data.Ord
+import Data.Array
+
+showNum :: (Num a, Show a) => Int -> a -> String
+showNum w = until ((>w-1).length) (' ':) . show
+
+replace :: Int -> a -> [a] -> [a]
+replace n c ls = take (n-1) ls ++ [c] ++ drop n ls
+
+target = "METHINKS IT IS LIKE A WEASEL"
+pfit = length target
+mutateRate = 20
+popsize = 100
+charSet = listArray (0,26) $ ' ': ['A'..'Z'] :: Array Int Char
+
+fitness = length . filter id . zipWith (==) target
+
+printRes i g = putStrLn $
+     "gen:" ++ showNum 4 i ++ "  "
+     ++ "fitn:" ++ showNum 4  (round $ 100 * fromIntegral s / fromIntegral pfit ) ++ "%  "
+     ++ show g
+    where s = fitness g
+
+mutate :: [Char] -> Int -> IO [Char]
+mutate g mr = do
+  let r = length g
+  chances <- replicateM r $ randomRIO (1,mr)
+  let pos = elemIndices 1 chances
+  chrs <- replicateM (length pos) $ randomRIO (bounds charSet)
+  let nchrs = map (charSet!) chrs
+  return $ foldl (\ng (p,c) -> replace (p+1) c ng) g (zip pos nchrs)
+
+evolve :: [Char] -> Int -> Int -> IO ()
+evolve parent gen mr = do
+  when ((gen-1) `mod` 20 == 0) $ printRes (gen-1) parent
+  children <- replicateM popsize (mutate parent mr)
+  let child = maximumBy (comparing fitness) (parent:children)
+  if fitness child == pfit then printRes gen child
+                           else evolve child (succ gen) mr
+
+main = do
+  let r = length target
+  genes <- replicateM r $ randomRIO (bounds charSet)
+  let parent = map (charSet!) genes
+  evolve parent 1 mutateRate

Task/Evolutionary-algorithm/Haskell/evolutionary-algorithm-2.hs

@@ -0,0 +1,35 @@
+import System.Random
+import Data.List
+import Data.Ord
+import Data.Array
+import Control.Monad
+import Control.Arrow
+
+target = "METHINKS IT IS LIKE A WEASEL"
+mutateRate = 0.1
+popSize = 100
+printEvery = 10
+
+alphabet = listArray (0,26) (' ':['A'..'Z'])
+
+randomChar = (randomRIO (0,26) :: IO Int) >>= return . (alphabet !)
+
+origin = mapM createChar target
+    where createChar c = randomChar
+
+fitness = length . filter id . zipWith (==) target
+
+mutate = mapM mutateChar
+    where mutateChar c = do
+            r <- randomRIO (0.0,1.0) :: IO Double
+            if r < mutateRate then randomChar else return c
+
+converge n parent = do
+    if n`mod`printEvery == 0 then putStrLn fmtd else return ()
+    if target == parent
+        then putStrLn $ "\nFinal: " ++ fmtd
+        else mapM mutate (replicate (popSize-1) parent) >>=
+                converge (n+1) . fst . maximumBy (comparing snd) . map (id &&& fitness) . (parent:)
+    where fmtd = parent ++ ": " ++ show (fitness parent) ++ " (" ++ show n ++ ")"
+
+main = origin >>= converge 0