[Haskell Practice] finite automata

dfa.hs

module DFA
( DFA (..)
, trans
, run
, accept
) where

import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe
import Control.Monad

type Delta s a = Map.Map (s, a) s

data DFA s a = DFA
    { states :: Set.Set s
    , sigma :: Set.Set a
    , delta :: Delta s a
    , startState :: s
    , acceptStates :: Set.Set s
    } deriving (Show)

trans :: (Ord s, Ord a) => s -> a -> DFA s a -> Maybe s
trans state alpha dfa = Map.lookup (state, alpha) $ delta dfa

run :: (Ord s, Ord a) => [a] -> DFA s a -> Maybe s
run input dfa = (foldM trans' $ startState dfa) input
    where trans' state alpha = trans state alpha dfa

accept :: (Ord s, Ord a) => [a] -> DFA s a -> Bool
accept input dfa =
    if isNothing $ final
        then False
        else Set.member (fromJust final) (acceptStates dfa)
    where final = run input dfa

main.hs

import qualified Data.Map as Map
import qualified Data.Set as Set

import Test.HUnit

import qualified DFA
import qualified NFA

dfa = DFA.DFA
    { DFA.states = Set.fromList ['x', 'y']
    , DFA.sigma = Set.fromList [0, 1]
    , DFA.delta = Map.fromList
        [ (('x', 0), 'x')
        , (('y', 0), 'y')
        , (('x', 1), 'y')
        , (('y', 1), 'x') ]
    , DFA.startState = 'x'
    , DFA.acceptStates = Set.fromList ['y'] }

nfa = NFA.NFA
    { NFA.states = Set.fromList [1, 2, 3]
    , NFA.sigma = Set.fromList ['a', 'b']
    , NFA.delta = Map.fromList
        [ ((1, Just 'b'),   Set.fromList [2])
        , ((1, Nothing),    Set.fromList [3])
        , ((2, Just 'a'),   Set.fromList [2, 3])
        , ((2, Just 'b'),   Set.fromList [3])
        , ((3, Just 'a'),   Set.fromList [1]) ]
    , NFA.startState = 1
    , NFA.acceptStates = Set.fromList [1] }

nfa' = NFA.toDFA nfa

dfaTestCase = TestCase (do
    assertEqual "[]" (DFA.accept [] dfa) False
    assertEqual "[1]" (DFA.accept [1] dfa) True
    assertEqual "[0]" (DFA.accept [0] dfa) False
    assertEqual "[0, 1, 1, 0, 1, 1]"
        (DFA.accept [0, 1, 1, 0, 1, 1] dfa) False
    assertEqual "[0, 1, 1, 0, 1, 1, 1]"
        (DFA.accept [0, 1, 1, 0, 1, 1, 1] dfa) True
    assertEqual "[0, 1, 1, 0, 1, 1, 1, 0]"
        (DFA.accept [0, 1, 1, 0, 1, 1, 1, 0] dfa) True)

nfaTestCase = TestCase (do
    assertEqual "[]" (NFA.accept [] nfa) True
    assertEqual "['a']" (NFA.accept ['a'] nfa) True
    assertEqual "['b']" (NFA.accept ['b'] nfa) False
    assertEqual "['b', 'a', 'b']"
        (NFA.accept ['b', 'a', 'b'] nfa) False
    assertEqual "['b', 'a', 'b', 'a']"
        (NFA.accept ['b', 'a', 'b', 'a'] nfa) True
    assertEqual "['b', 'a', 'b', 'a', 'a']"
        (NFA.accept ['b', 'a', 'b', 'a', 'a'] nfa) True)

convertTestCase = TestCase (do
    assertEqual "[]" (DFA.accept [] nfa') True
    assertEqual "['a']" (DFA.accept ['a'] nfa') True
    assertEqual "['b']" (DFA.accept ['b'] nfa') False
    assertEqual "['b', 'a', 'b']"
        (DFA.accept ['b', 'a', 'b'] nfa') False
    assertEqual "['b', 'a', 'b', 'a']"
        (DFA.accept ['b', 'a', 'b', 'a'] nfa') True
    assertEqual "['b', 'a', 'b', 'a', 'a']"
        (DFA.accept ['b', 'a', 'b', 'a', 'a'] nfa') True)

main = runTestTT $ TestList [dfaTestCase, nfaTestCase, convertTestCase]

nfa.hs

module NFA
( NFA (..)
, trans
, run
, accept
, toDFA
) where

import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe (isNothing, fromJust)

import qualified DFA

type Delta s a = Map.Map (s, Maybe a) (Set.Set s)

data NFA s a = NFA
    { states :: Set.Set s
    , sigma :: Set.Set a
    , delta :: Delta s a
    , startState :: s
    , acceptStates :: Set.Set s
    } deriving Show

move :: (Ord s, Ord a) => s -> Maybe a -> NFA s a -> Set.Set s
move state alpha nfa =
    if isNothing result
        then Set.empty
        else fromJust result
    where result = Map.lookup (state, alpha) $ delta nfa

moveWithAlpha :: (Ord s, Ord a) => s -> a -> NFA s a -> Set.Set s
moveWithAlpha state alpha = move state (Just alpha)

moveWithNothing :: (Ord s, Ord a) => s -> NFA s a -> Set.Set s
moveWithNothing state = move state Nothing

epsilonClosure :: (Ord s, Ord a) => Set.Set s -> NFA s a -> Set.Set s
epsilonClosure states nfa = Set.fold appendStates states states
    where appendStates = \s acc -> Set.union acc $ moveWithNothing s nfa

trans :: (Ord s, Ord a) => Set.Set s -> a -> NFA s a -> Set.Set s
trans states alpha nfa = Set.fold appendStates Set.empty states
    where appendStates = \s acc -> Set.union acc $ move s
          move s = epsilonClosure (moveWithAlpha s alpha nfa) nfa

run :: (Ord s, Ord a) => [a] -> NFA s a -> Set.Set s
run input nfa = foldl trans' startStates input
    where trans' states alpha = trans states alpha nfa
          startStates = epsilonClosure (Set.singleton $ startState nfa) nfa

accept :: (Ord s, Ord a) => [a] -> NFA s a -> Bool
accept input nfa = not $ Set.null $ Set.intersection final $ acceptStates nfa
    where final = run input nfa

powerset :: (Ord s) => Set.Set s -> Set.Set (Set.Set s)
powerset set = Set.fold union emptySet set
    where union = \s acc -> Set.union acc $ Set.map (Set.insert s) acc
          emptySet = Set.singleton Set.empty

toDFA :: (Ord s, Ord a) => NFA s a -> DFA.DFA (Set.Set s) a
toDFA nfa = DFA.DFA
    { DFA.states = states'
    , DFA.sigma = sigma'
    , DFA.delta = delta'
    , DFA.startState = starts
    , DFA.acceptStates = Set.filter isAccept states' }
    where states' = powerset $ states nfa
          sigma' = sigma nfa
          delta' = Map.fromList $ foldl run' [] stateList
              where run' = \acc s -> foldl (\acc' a -> trans' s a : acc') acc sigmaList
                    trans' = \state alpha -> ((state, alpha), trans state alpha nfa)
                    sigmaList = Set.toList sigma'
                    stateList = Set.toList states'
          starts = epsilonClosure (Set.singleton $ startState nfa) nfa
          isAccept = not . Set.null . Set.intersection (acceptStates nfa)