import Data.List
import System.Random
data Args
= Args
{ _symbols
:: String, _numSymbols
:: Int
runFlib (Args smbs nsmbs sts _) (s, m) input = ((s',m), out) where
(out:s':
_) = drop (2 * (nsmbs
* index s sts
+ index input smbs
)) m
index x
= head . elemIndices x
snd . mapAccumL (runFlib args) (head $ _states args,flib) $ init input'
where input' = take (run + 1) $ cycle input
oneOf :: [a] -> IO a
oneOf xs = fmap (xs !!) $ randomRIO (0, length xs - 1)
replace :: Int -> a -> [a] -> [a]
replace i v xs = take i xs ++ v : drop (i + 1) xs
randomFlib :: Args -> IO String
randomFlib (Args smbs nsmbs sts nsts) = fmap concat $
replicateM (nsmbs * nsts) (sequence [oneOf smbs, oneOf sts])
crossover :: Args -> String -> String -> IO String
crossover (Args _ nsmbs _ nsts) a b = do
start <- randomRIO (0, 2 * nsmbs * nsts - 2)
end <- randomRIO (start + 1, 2 * nsmbs * nsts - 1)
return $ take start a ++ take (end - start) (drop start b) ++ drop end a
mutate :: Args -> String -> IO String
mutate (Args smbs nsmbs sts nsts) flib = do
i <- randomRIO (0, 2 * nsmbs * nsts - 1)
c <- oneOf $ if mod i 2 == 0 then smbs else sts
return $ replace i c flib
evolve :: String -> Int -> Float -> Int -> String -> IO ()
evolve states popSize breedChance run input =
nextGen (0, "") =<< replicateM popSize (randomFlib args) where
args = Args (map head symbols) (length symbols)
states (length . group $ sort states)
where symbols = group $ sort input
nextGen (top,_) _ | top == run = return ()
nextGen best pop = do
let scored = sort $ map (\flib -> (score run args flib input, flib)) pop
let top = last scored
breed <- fmap (< breedChance) $ randomRIO (0, 1)
mix <- crossover args (snd $ head scored) (snd top)
let newPop = (if breed then replace 0 mix else id) (map snd scored)
mutIndex <- randomRIO (0, popSize - 1)
mutant <- mutate args (newPop !! mutIndex)
when (fst top > fst best) (print top)
nextGen (max best top) $ replace mutIndex mutant newPop
main :: IO ()
main = evolve "ABCD" 10 0.3 100 "010011"
aW1wb3J0IENvbnRyb2wuTW9uYWQKaW1wb3J0IERhdGEuTGlzdAppbXBvcnQgU3lzdGVtLlJhbmRvbQoKZGF0YSBBcmdzID0gQXJncyB7IF9zeW1ib2xzIDo6IFN0cmluZywgX251bVN5bWJvbHMgOjogSW50CiAgICAgICAgICAgICAgICAgLCBfc3RhdGVzICA6OiBTdHJpbmcsIF9udW1TdGF0ZXMgOjogSW50IH0KCnJ1bkZsaWIgOjogQXJncyAtPiAoQ2hhciwgU3RyaW5nKSAtPiBDaGFyIC0+ICgoQ2hhciwgU3RyaW5nKSwgQ2hhcikKcnVuRmxpYiAoQXJncyBzbWJzIG5zbWJzIHN0cyBfKSAocywgbSkgaW5wdXQgPSAoKHMnLG0pLCBvdXQpIHdoZXJlCiAgICAob3V0OnMnOl8pID0gZHJvcCAoMiAqIChuc21icyAqIGluZGV4IHMgc3RzICsgaW5kZXggaW5wdXQgc21icykpIG0KICAgIGluZGV4IHggICAgPSBoZWFkIC4gZWxlbUluZGljZXMgeAoKc2NvcmUgOjogSW50IC0+IEFyZ3MgLT4gU3RyaW5nIC0+IFN0cmluZyAtPiBJbnQKc2NvcmUgcnVuIGFyZ3MgZmxpYiBpbnB1dCA9IGxlbmd0aCAuIGZpbHRlciBpZCAuIHppcFdpdGggKD09KSAodGFpbCBpbnB1dCcpIC4KICAgIHNuZCAuIG1hcEFjY3VtTCAocnVuRmxpYiBhcmdzKSAoaGVhZCAkIF9zdGF0ZXMgYXJncyxmbGliKSAkIGluaXQgaW5wdXQnCiAgICB3aGVyZSBpbnB1dCcgPSB0YWtlIChydW4gKyAxKSAkIGN5Y2xlIGlucHV0CgpvbmVPZiA6OiBbYV0gLT4gSU8gYQpvbmVPZiB4cyA9IGZtYXAgKHhzICEhKSAkIHJhbmRvbVJJTyAoMCwgbGVuZ3RoIHhzIC0gMSkKCnJlcGxhY2UgOjogSW50IC0+IGEgLT4gW2FdIC0+IFthXQpyZXBsYWNlIGkgdiB4cyA9IHRha2UgaSB4cyArKyB2IDogZHJvcCAoaSArIDEpIHhzCgpyYW5kb21GbGliIDo6IEFyZ3MgLT4gSU8gU3RyaW5nCnJhbmRvbUZsaWIgKEFyZ3Mgc21icyBuc21icyBzdHMgbnN0cykgPSBmbWFwIGNvbmNhdCAkCiAgICByZXBsaWNhdGVNIChuc21icyAqIG5zdHMpIChzZXF1ZW5jZSBbb25lT2Ygc21icywgb25lT2Ygc3RzXSkKCmNyb3Nzb3ZlciA6OiBBcmdzIC0+IFN0cmluZyAtPiBTdHJpbmcgLT4gSU8gU3RyaW5nCmNyb3Nzb3ZlciAoQXJncyBfIG5zbWJzIF8gbnN0cykgYSBiID0gZG8KICAgIHN0YXJ0IDwtIHJhbmRvbVJJTyAoMCwgICAgICAgICAyICogbnNtYnMgKiBuc3RzIC0gMikKICAgIGVuZCAgIDwtIHJhbmRvbVJJTyAoc3RhcnQgKyAxLCAyICogbnNtYnMgKiBuc3RzIC0gMSkKICAgIHJldHVybiAkIHRha2Ugc3RhcnQgYSArKyB0YWtlIChlbmQgLSBzdGFydCkgKGRyb3Agc3RhcnQgYikgKysgZHJvcCBlbmQgYQoKbXV0YXRlIDo6IEFyZ3MgLT4gU3RyaW5nIC0+IElPIFN0cmluZwptdXRhdGUgKEFyZ3Mgc21icyBuc21icyBzdHMgbnN0cykgZmxpYiA9IGRvCiAgICBpIDwtIHJhbmRvbVJJTyAoMCwgMiAqIG5zbWJzICogbnN0cyAtIDEpCiAgICBjIDwtIG9uZU9mICQgaWYgbW9kIGkgMiA9PSAwIHRoZW4gc21icyBlbHNlIHN0cwogICAgcmV0dXJuICQgcmVwbGFjZSBpIGMgZmxpYgoKZXZvbHZlIDo6IFN0cmluZyAtPiBJbnQgLT4gRmxvYXQgLT4gSW50IC0+IFN0cmluZyAtPiBJTyAoKQpldm9sdmUgc3RhdGVzIHBvcFNpemUgYnJlZWRDaGFuY2UgcnVuIGlucHV0ID0KICAgIG5leHRHZW4gKDAsICIiKSA9PDwgcmVwbGljYXRlTSBwb3BTaXplIChyYW5kb21GbGliIGFyZ3MpIHdoZXJlCiAgICBhcmdzID0gQXJncyAobWFwIGhlYWQgc3ltYm9scykgKGxlbmd0aCBzeW1ib2xzKQogICAgICAgICAgICAgICAgc3RhdGVzICAobGVuZ3RoIC4gZ3JvdXAgJCBzb3J0IHN0YXRlcykKICAgICAgICAgICAgICAgIHdoZXJlIHN5bWJvbHMgPSBncm91cCAkIHNvcnQgaW5wdXQKICAgIG5leHRHZW4gKHRvcCxfKSBfIHwgdG9wID09IHJ1biA9IHJldHVybiAoKQogICAgbmV4dEdlbiBiZXN0IHBvcCA9IGRvCiAgICAgICAgbGV0IHNjb3JlZCA9IHNvcnQgJCBtYXAgKFxmbGliIC0+IChzY29yZSBydW4gYXJncyBmbGliIGlucHV0LCBmbGliKSkgcG9wCiAgICAgICAgbGV0IHRvcCA9IGxhc3Qgc2NvcmVkCiAgICAgICAgYnJlZWQgPC0gZm1hcCAoPCBicmVlZENoYW5jZSkgJCByYW5kb21SSU8gKDAsIDEpCiAgICAgICAgbWl4IDwtIGNyb3Nzb3ZlciBhcmdzIChzbmQgJCBoZWFkIHNjb3JlZCkgKHNuZCB0b3ApCiAgICAgICAgbGV0IG5ld1BvcCA9IChpZiBicmVlZCB0aGVuIHJlcGxhY2UgMCBtaXggZWxzZSBpZCkgKG1hcCBzbmQgc2NvcmVkKQogICAgICAgIG11dEluZGV4IDwtIHJhbmRvbVJJTyAoMCwgcG9wU2l6ZSAtIDEpCiAgICAgICAgbXV0YW50IDwtIG11dGF0ZSBhcmdzIChuZXdQb3AgISEgbXV0SW5kZXgpCiAgICAgICAgd2hlbiAoZnN0IHRvcCA+IGZzdCBiZXN0KSAocHJpbnQgdG9wKQogICAgICAgIG5leHRHZW4gKG1heCBiZXN0IHRvcCkgJCByZXBsYWNlIG11dEluZGV4IG11dGFudCBuZXdQb3AKCm1haW4gOjogSU8gKCkKbWFpbiA9IGV2b2x2ZSAiQUJDRCIgMTAgMC4zIDEwMCAiMDEwMDExIg==