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).enter image description here

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

• syb0rg: Welcome to Code Review, and thank you for making this such a wonderful review! Hopefully you can stick around to make some more!