Using finite automata

data NFA q sigma =
  NFA
  [q] -- the set of states
  [sigma] -- the set of alphabet symbols
  [q] -- the set of initial states
  [(q,sigma,q)] -- the transition relation
  [q] -- the set of final states

data NFA q sigma =
  NFA
  (q -> Bool) -- the used states
  (sigma -> Bool) -- the used alphabet symbols
  (q -> Bool) -- initial states
  (q -> sigma -> q -> Bool) -- transitions
  (q -> Bool) -- final states

data NFA q sigma =
  NFA
  [q] -- initial states
  (q -> Maybe sigma -> [q]) -- transitions
  (q -> Bool) -- final states

data DFA q sigma =
  DFA
  q -- initial state
  (q -> sigma :-> q) -- transitions
  (q -> Bool) -- final states

A DFA accepts a word just in case you end up in a final state by moving through the machine in accordance with the letters of the word.

> accepts :: DFA q sigma -> [sigma] -> Bool
> accepts m@(DFA start delta final) ws =
>   case followTrans m start ws of
>     Just q -> final q
>     _ -> False

We would like to use sets, which are implemented in the Data.Set module.  We import it for use in our present file.  However, we don't want the function names it defines to clutter up our namespace.  Instead, we import them under the name 'S.'  In order to call a function /f/ from the Data.Set module, we must write 'S.f'.

> import qualified Data.Set as S

For the operation of set difference, it is nice to have a special infix operator, '\\'.

> infixl 9 \\
> (\\) = S.difference

Similarly for set union I would like to just write '+++'.

> infixl 9 +++
> (+++) = S.union

An important operation on sets is closing them under some function.  A set /s/ is closed under a function /f/ just in case any time you apply /f/ to some object /a/ in /s/, the result /f a/ is already in /s/.

> closure :: Ord a => (a -> S.Set a) -> S.Set a -> S.Set a
> closure update set = performClosure set set
>   where
>     performClosure visited toDo =
>       if S.null newToDo then visited
>       else performClosure updatedVisited newToDo
>       where
>         newToDo = foldMap update toDo \\ visited
>         updatedVisited = visited +++ newToDo

An NFA is defined as a triple of a set of initial states, a transition function, and a function telling us whether a state is final.

> data NFA q sigma =
>   NFA
>   (S.Set q) -- initial states
>   (q -> Maybe sigma -> S.Set q) -- transitions
>   (q -> Bool) -- final states

To follow transitions according to a word, we step through the machine *through multiple states at the same time*.

> followTrans :: Ord q => NFA q sigma -> S.Set q -> [sigma] -> S.Set q
> followTrans m@(NFA start delta final) = follow
>   where
>     emptyBall = closure (\q -> delta q Nothing)
>     follow qs [] = qs
>     follow qs (w:ws) = if S.null nextStates then S.empty
>                        else follow nextStates ws
>       where
>         nextStates =
>           emptyBall (foldMap (\q -> delta q (Just w)) qs)

A machine accepts a word just in case one of the states you land in by traversing it in accordance with the letters of the word is a final state.

> accepts :: Ord q => NFA q sigma -> [sigma] -> Bool
> accepts m@(NFA start delta final) = not . S.null . S.filter final . followTrans m start

To obtain a DFA from an NFA, we identify the (single) start state of the DFA with the /set/ of all start states from the NFA, and a state in the DFA is final just in case it contains one final state from the NFA.

> determinize :: Ord q => NFA q sigma -> DFA (S.Set q) sigma
> determinize (NFA start delta final) = DFA start dDelta (not . S.null . S.filter final)
>   where
>     emptyBall = closure (\q -> delta q Nothing)
>     dDelta qs w = let nexts = emptyBall (foldMap (\q -> delta q (Just w)) qs)
>                   in
>                     if S.null nexts then Nothing
>                     else Just nexts

The function _mkTree_ constructs a tree by means of an /update/ function and an initial 'seed' value.  The update function maps a value to a list of values.  The initial seed value is put at the root of the tree.  The daughter trees are constructed by making trees for each element in the list of updated values obtained by applying the update function to the initial value.

> mkTree :: (a -> [a]) -> a -> Tree a
> mkTree update = grow
>   where
>     grow seed =
>       Node seed -- the seed value is put at the root
>            (fmap grow (update seed)) -- and a tree is grown from
>                                      -- each of the updated values

The function _mapTree_ is the tree version of the map function on lists (_fmap_).  It modifies the values stored at each node in the tree in a way determined by the function you give it as an argument.

> mapTree :: (a -> b) -> Tree a -> Tree b
> mapTree modify = modifyTree
>  where
>    modifyTree (Node a ts) =
>      Node (modify a) -- the root is changed
>           (fmap modifyTree ts) -- each of the original daughters are
>                                -- changed in the same way

The trees of the paths resulting from walking through the machine in accord with an input word can be obtained via the function _mkTree_.  The seed values are the possible start states (each path begins at a particular start state), and a value is updated by reading the next letter in the word (and possibly taking some number of empty transitions).  In order to read the correct letter at any particular state, the value associated with a node is a pair of the current state, and the rest of the input word.

> treesOfPaths :: Ord q => NFA q sigma -> [sigma] -> [Tree q]
> treesOfPaths (NFA start delta final) ws =
>   fmap -- for each start state ...
>        (mapTree fst {- 3. get rid of the words associated with the
>                        nodes -}
>          . mkTree upd -- 2. create a tree
>          . (,ws)) -- 1. pair it with the input word
>        (S.elems start)
>  where
>    upd (q,[]) = [] {- if the input has been exhausted, then there is
>                       nothing left to do -}
>    upd (q,(w:ws)) =
>      fmap -- for each state,
>        (,ws) -- pair it with the remaining input
>        (nextStates q w) {- the states which can be reached by
>                            reading w -}
>    emptyBall =
>      closure (\q -> delta q Nothing)
>    nextStates q w =
>      S.elems (emptyBall (delta q (Just w)))

A path in a tree extends from the root to a leaf.  Formally however it is just a sequence of node labels.

> type Path a = [a]

A tree traversal enumerates all paths in a tree.

> type Traversal a = Tree a -> [Path a]

A depth first traversal enumerates paths from left to right in the tree.  To implement a depth first traversal, it is helpful to maintain an intermediate data structure, recording the path taken to arrive at the current node.  Of course, when starting out at the root of the tree, the path taken is empty.

> depthFirst :: Traversal a
> depthFirst = dfs []
>   where
>    dfs path (Node a ts) = concatMap (dfs (a:path) ts)

Note that when visiting a node's daughters, the path to the daughters is the same as the path to their mother extended with their mother.


A breadth first traversal enumerates paths in a tree based on their distance from the root.  (If two paths are the same distance from the root, it enumerates them from left to right.)  Like the depth first implementation, each tree is paired with its path from the root.  In contrast to the depth first implementation, we cannot maintain just a single path, because we are enumerating all paths 'at once', and these lie along different paths from the root.

> breadthFirst :: Traversal a
> breadthFirst t = bfs [(t,[])]
>   where
>     bfs [] = []
>     bfs ((Node a ts,path) : tts) = bfs (tts ++ fmap (, (a:path)) ts)