fork download
copy 
  1. import Control.Monad
  2. import Data.List
  3. import System.Random
  4.  
  5. data Args = Args { _symbols :: String, _numSymbols :: Int
  6.                  , _states  :: String, _numStates :: Int }
  7.  
  8. runFlib :: Args -> (Char, String) -> Char -> ((Char, String), Char)
  9. runFlib (Args smbs nsmbs sts _) (s, m) input = ((s',m), out) where
  10.     (out:s':_) = drop (2 * (nsmbs * index s sts + index input smbs)) m
  11.     index x    = head . elemIndices x
  12.  
  13. score :: Int -> Args -> String -> String -> Int
  14. score run args flib input = length . filter id . zipWith (==) (tail input') .
  15.     snd . mapAccumL (runFlib args) (head $ _states args,flib) $ init input'
  16.     where input' = take (run + 1) $ cycle input
  17.  
  18. oneOf :: [a] -> IO a
  19. oneOf xs = fmap (xs !!) $ randomRIO (0, length xs - 1)
  20.  
  21. replace :: Int -> a -> [a] -> [a]
  22. replace i v xs = take i xs ++ v : drop (i + 1) xs
  23.  
  24. randomFlib :: Args -> IO String
  25. randomFlib (Args smbs nsmbs sts nsts) = fmap concat $
  26.     replicateM (nsmbs * nsts) (sequence [oneOf smbs, oneOf sts])
  27.  
  28. crossover :: Args -> String -> String -> IO String
  29. crossover (Args _ nsmbs _ nsts) a b = do
  30.     start <- randomRIO (0,         2 * nsmbs * nsts - 2)
  31.     end   <- randomRIO (start + 1, 2 * nsmbs * nsts - 1)
  32.     return $ take start a ++ take (end - start) (drop start b) ++ drop end a
  33.  
  34. mutate :: Args -> String -> IO String
  35. mutate (Args smbs nsmbs sts nsts) flib = do
  36.     i <- randomRIO (0, 2 * nsmbs * nsts - 1)
  37.     c <- oneOf $ if mod i 2 == 0 then smbs else sts
  38.     return $ replace i c flib
  39.  
  40. evolve :: String -> Int -> Float -> Int -> String -> IO ()
  41. evolve states popSize breedChance run input =
  42.     nextGen (0, "") =<< replicateM popSize (randomFlib args) where
  43.     args = Args (map head symbols) (length symbols)
  44.                 states  (length . group $ sort states)
  45.                 where symbols = group $ sort input
  46.     nextGen (top,_) _ | top == run = return ()
  47.     nextGen best pop = do
  48.         let scored = sort $ map (\flib -> (score run args flib input, flib)) pop
  49.         let top = last scored
  50.         breed <- fmap (< breedChance) $ randomRIO (0, 1)
  51.         mix <- crossover args (snd $ head scored) (snd top)
  52.         let newPop = (if breed then replace 0 mix else id) (map snd scored)
  53.         mutIndex <- randomRIO (0, popSize - 1)
  54.         mutant <- mutate args (newPop !! mutIndex)
  55.         when (fst top > fst best) (print top)
  56.         nextGen (max best top) $ replace mutIndex mutant newPop
  57.  
  58. main :: IO ()
  59. main = evolve "ABCD" 10 0.3 100 "010011"
Success #stdin #stdout 1.19s 4748KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(65,"0C0A0A0B1A1D1D0D")
(66,"0C0D0A0A0D0A0C1C")
(80,"0B1D1A0B0C0D0B0C")
(99,"0C0D0B0B1D0A1C1A")
(100,"1C0A0C1D1B0B1C0A")
https://ideone.com/rkJaf
language:
Haskell (ghc 8.4.4)
created:
11 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!