Posts Tagged ‘fsm’

Programming Praxis – The Evolution Of Flibs

July 13, 2012

In today’s Programming Praxis exercise, our goal is to implement a genetic algorithm to evolve finite state machines that predict repeating sequences. The solution is one of the longest ones in quite a while, so let’s get started, shall we?

Some imports:

import Control.Monad
import Data.List
import System.Random

First we need something to keep track of the allowable states and inputs. When I wrote it I didn’t quite know how many arguments where going to end up in it, so I made it a datatype rather than a tuple. A difference with the Scheme solution is that the characters used for the state are customisable. It doesn’t serve much purpose, but it allows things to be a bit more generic.

data Args = Args { _symbols :: String, _numSymbols :: Int
                 , _states  :: String, _numStates :: Int }

I started with the function to run a flib since I wanted to know if I understood them correctly. Initially I stored the table in a Map, but after a while I found that keeping them as strings would require less conversion and code when displaying, generating and mutating them.

runFlib :: Args -> (Char, String) -> Char -> ((Char, String), Char)
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

For the score function we cycle the input to the given length and check how many times the next item is predicted correctly.

score :: Int -> Args -> String -> String -> Int
score run args flib input = length . filter id . zipWith (==) (tail input') .
    snd . mapAccumL (runFlib args) (head $ _states args,flib) $ init input'
    where input' = take (run + 1) $ cycle input

Two generic functions we need later on: oneOf chooses a random element of a given list and replace replaces the element with the given index in a list with the new value.

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

To generate a random flib we simply concatenate the appropriate number of inputs and states.

randomFlib :: Args -> IO String
randomFlib (Args smbs nsmbs sts nsts) = fmap concat $
    replicateM (nsmbs * nsts) (sequence [oneOf smbs, oneOf sts])

To breed two flibs we take the beginning and/or end of one flib and insert the middle of the other.

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

To mutate a flib we replace a random character with a new one of the correct type.

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

Finally, we have to function that does the actual work of testing and changing the different generations. First we create a random population of the desired size. Each generation, we calculate all the scores, print the best one if it’s an improvement, potentially breed to best and worst flibs, mutate one of the elements and repeat the whole process until we have found one that can correctly predict the entire sequence.

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

A test to see if everything is working properly:

main :: IO ()
main = evolve "ABCD" 10 0.3 100 "010011"