DFA and NFA in Haskell

Question

I've written a determinstic & non-deterministic finite state machine. I've scrubbed the code quite a bit but I wonder if it could perhaps be scrubbed even more.

Suggestions for code clarity, formatting, API design and test suites (I can't think of any for my NFA) would be welcome.

Also, can the code be modified to support sets without obscuring code clarity? That way would prevent needless iteration of duplicate states.

dfa.hs:

module DFA (DFA(..), evalDFA) where

import Data.Maybe (Maybe(..))

data DFA s i = DFA {
    startState :: s,
    delta :: s -> i -> Maybe s,
    isFinal :: s -> Bool
}

evalDFA (DFA startState delta isFinal) xs =
    case endState of
        Nothing -> False
        Just s -> isFinal s
    where
        endState = foldl (\ m i -> m >>= (\ s -> delta s i)) (Just startState) xs

dfa_test.hs:

import Data.Maybe (Maybe(..))

import Test.QuickCheck (quickCheck, quickCheckWith)

import DFA (DFA(..), evalDFA)

alwaysPass :: DFA Int ()
alwaysPass = DFA 0 moves isFinal
    where
    moves :: Int -> () -> Maybe Int
    moves 0 () = Just 0
    moves _ _ = Nothing
    isFinal :: Int -> Bool
    isFinal _ = True

test_alwaysPass :: IO ()
test_alwaysPass = quickCheck (\ xs -> evalDFA alwaysPass xs)


alwaysFail :: DFA Int ()
alwaysFail = DFA 0 moves isFinal
    where
        moves :: Int -> () -> Maybe Int
        moves 0 () = Just 0
        moves _ _ = Nothing
        isFinal :: Int -> Bool
        isFinal _ = False

test_alwaysFail :: IO ()
test_alwaysFail = quickCheck (\ xs -> not $ evalDFA alwaysFail xs)


onlyTrue :: DFA Int Bool
onlyTrue = DFA 1 moves isFinal
    where
        moves :: Int -> Bool -> Maybe Int
        moves 0 False = Just 0
        moves 0 True = Just 0
        moves 1 False = Just 0
        moves 1 True = Just 1
        moves _ _ = Nothing
        isFinal :: Int -> Bool
        isFinal 1 = True
        isFinal _ = False

test_onlyTrue :: IO ()
test_onlyTrue =
    quickCheck (\ xs -> isAccept xs $ evalDFA onlyTrue xs)
    where
        isAccept :: [Bool] -> (Bool -> Bool)
        isAccept xs
            | all id xs = id
            | otherwise = not


endWithFalse :: DFA Int Bool
endWithFalse = DFA 0 moves isFinal
    where
        moves :: Int -> Bool -> Maybe Int
        moves 0 False = Just 1
        moves 0 True = Just 0
        moves 1 False = Just 1
        moves 1 True = Just 0
        moves _ _ = Nothing
        isFinal :: Int -> Bool
        isFinal 1 = True
        isFinal _ = False

test_endWithFalse :: IO ()
test_endWithFalse =
    quickCheck (\ xs -> isAccept xs $ evalDFA endWithFalse xs)
    where
        isAccept :: [Bool] -> (Bool -> Bool)
        isAccept [] = not
        isAccept xs
            | not $ last xs = id
            | otherwise = not


isBeer :: DFA Int Char
isBeer = DFA 0 moves isFinal
    where
        moves :: Int -> Char -> Maybe Int
        moves 0 'b' = Just 1
        moves 1 'e' = Just 2
        moves 2 'e' = Just 2
        moves 2 'r' = Just 3
        moves _ _ = Nothing
        isFinal :: Int -> Bool
        isFinal 3 = True
        isFinal _ = False

test_isBeer :: IO ()
test_isBeer =
    do
        quickCheck (\ xs -> isAccept xs $ evalDFA isBeer xs)
        checkBeer
    where
        checkBeer :: IO ()
        checkBeer
            | evalDFA isBeer "beer" = putStrLn "+++ OK, passed \"beer\" test."
            | otherwise = putStrLn "*** Failed! Falsifiable:\n\"beer\""
        isAccept :: [Char] -> (Bool -> Bool)
        isAccept [] = not
        isAccept xs
            | xs == "beer" = id
            | otherwise = not


isBeeeeeer :: DFA Int Char
isBeeeeeer = DFA 0 moves isFinal
    where
        moves :: Int -> Char -> Maybe Int
        moves 0 'b' = Just 1
        moves 1 'e' = Just 1
        moves 1 'r' = Just 2
        moves _ _ = Nothing
        isFinal :: Int -> Bool
        isFinal 2 = True
        isFinal _ = False

test_isBeeeeeer =
    do
        quickCheck (\ xs -> isAccept xs $ evalDFA isBeeeeeer xs)
        quickCheck (\ x -> evalDFA isBeeeeeer ("b" ++ replicate x 'e' ++ "r"))
    where
        middle :: [a] -> [a]
        middle = init . tail
        isAccept :: String -> (Bool -> Bool)
        isAccept [] = not
        isAccept [_] = not
        isAccept xs
            | head xs == 'b' && (all (== 'e') $ middle xs) && last xs == 'r' = id
            | otherwise = not


main :: IO ()
main = do
    test_alwaysPass
    test_alwaysFail
    test_onlyTrue
    test_endWithFalse
    test_isBeer
    test_isBeeeeeer

nfa.hs:

module NFA (NFA(..), evalNFA) where

import Data.Maybe (Maybe(..))

data NFA s i = NFA {
    startState :: s,
    delta :: s -> i -> [s],
    epsilon :: s -> [s],
    isFinal :: s -> Bool
}

step :: NFA s i -> s -> i -> [s]
step (NFA _ delta epsilon _) s i = [s] >>= forward >>= consumeInput >>= forward
    where
        forward s = case epsilon s of
            [] -> [s]
            xs -> xs >>= forward
        consumeInput s = delta s i

evalNFA :: NFA s i -> [i] -> Bool
evalNFA nfa xs = any (isFinal nfa) endStates
    where
        endStates = foldl (\ ss i -> ss >>= (\ s -> step nfa s i)) [startState nfa] xs

nfa_test.hs:

import Data.Maybe (Maybe(..))

import Test.QuickCheck (quickCheck)

import NFA (NFA(..), evalNFA)

alwaysPass :: NFA Int ()
alwaysPass = NFA 0 delta epsilon isFinal
    where
        delta :: Int -> () -> [Int]
        delta 0 () = [0]
        delta _ _ = []
        epsilon :: Int -> [Int]
        epsilon _ = []
        isFinal :: Int -> Bool
        isFinal 0 = True
        isFinal _ = False

test_alwaysPass :: IO ()
test_alwaysPass = quickCheck (\ xs -> evalNFA alwaysPass xs)


alwaysFail :: NFA Int ()
alwaysFail = NFA 0 delta epsilon isFinal
    where
        delta :: Int -> () -> [Int]
        delta 0 () = [0]
        delta _ _ = []
        epsilon :: Int -> [Int]
        epsilon _ = []
        isFinal :: Int -> Bool
        isFinal _ = False

test_alwaysFail :: IO ()
test_alwaysFail = quickCheck (\ xs -> not $ evalNFA alwaysFail xs)


main = do
    test_alwaysPass
    test_alwaysFail

Answer 1

One thing that could be changed is making the DFA delta function fully defined:

delta :: s -> i -> s

because delta should be defined over the entire alphabet for any state.

If you wanted to use a state with a Maybe, you could just extract the Nothing portion into the isFinal function.

It would also simplify evalDFA to

evalDFA (DFA startState delta isFinal) xs = isFinal $ foldl delta startState xs

The Set representation for an NFA could be

data NFA s i = NFA {
    startState :: s,
    delta :: s -> i -> S.Set s,
    epsilon :: s -> S.Set s,
    isFinal :: s -> Bool
}

I wasn't trying to get a lot of speed out of this but this is an implementation with set might be

step :: Ord s => NFA s i -> s -> i -> S.Set s
step nfa@(NFA _ deltaF epsilonF _) s i = foldl applyInsert S.empty newStates
    where newStates = epsilonMoves nfa s
          applyInsert states state = S.union states $ deltaF state i

Here we find all of the epsilon moves for the nfa state and then we fold across the new states and apply the delta function to each state and add the results together

The epsilonMoves function

epsilonMoves :: Ord s => NFA s i -> s -> S.Set s
epsilonMoves (NFA _ _ epsilonF _) s = epsilonMoves' $ S.singleton s
    where epsilonMoves' lastStates = if S.null newStates 
                                        then lastStates 
                                        else S.union lastStates $ epsilonMoves'  newStates 
            where newStates = foldl (\states' state -> S.union states' $ epsilonF state) S.empty lastStates

This just finds the next moves from the given state and then finds the moves of all of the given states children. If there are new states found after new states have been found, then nothing else is calculated.

A move to calculate the epsilon moves for a Set could then be

epsilonMovesSet :: Ord s => NFA s i -> S.Set s -> S.Set s 
epsilonMovesSet nfa states = foldl (\xs s -> S.union xs $ epsilonMoves nfa s) S.empty states

To step across multiple states you just fold across the given states and accumulate the results given by step on i

stepStates :: Ord s => NFA s i -> S.Set s -> i -> S.Set s
stepStates nfa states i = foldl (\states' state -> S.union states' $ step nfa state i) S.empty states 

A function to step through multiple states on multiple inputs could be

multipleSteps :: (Foldable f, Ord s) => NFA s i -> f i -> S.Set s
multipleSteps nfa@(NFA aState _ _ _) xs = foldl (stepStates nfa) (S.singleton aState) xs

Here you have to only use the states from stepStates to go back into stepStates because they're intermediary steps.

To evaluate the nfa

evalNFA :: Ord s => NFA s i -> [i] -> Bool
evalNFA nfa@(NFA sState _ _ isFinalF) xs = any isFinalF endStates
    where
        endStates = epsilonMovesSet nfa $ multipleSteps nfa xs

Here you step through the given nfa with multipleSteps and then calculate all of the possible epsilon moves from the final result.

I don't think the implementation is incredibly fast but it should work.

Some NFA tests could be some regular expression tests. If you don't know how to make an NFA from a regular expression you could use something to generate it for you but a simple case is a*(b|c).

The not-so-correct implementation for this with the NFA above would be:

testNFA :: NFA Int Char
testNFA = NFA 0 deltaF epsilonF isFinalF
    where
        startState = 0 :: Int
        deltaF 1 'a' = S.fromList [2]
        deltaF 4 'b' = S.fromList [5]
        deltaF 6 'd' = S.fromList [7]
        deltaF n _ = S.singleton n
        epsilonF 0 = S.fromList [1,3]
        epsilonF 2 = S.fromList [1,3]
        epsilonF 3 = S.fromList [4,6]
        epsilonF 5 = S.fromList [8]
        epsilonF 7 = S.fromList [8]
        epsilonF _ = S.empty
        isFinalF 8 = True
        isFinalF _ = False

and some text cases could be:

evalNFA testNFA "aaaaab" == True
evalNFA testNFA "ab" == True
evalNFA testNFA "b" == False
evalNFA testNFA "ad" == True
evalNFA testNFA "aaaaaad" == True
evalNFA testNFA "d" == False
evalNFA testNFA "" == False