A DFA Module

We announce to Haskell that we would like to bundle together the code in this file, and make it available to be used by other programs under the name Dfsa (which must also be the name of the file). This is done by the keyword module, which is used in the following way:

module NAME (comma delimited list of names of functions and types to export) where

In this particular case, we would like the name of the module to be Dfsa (as stated above), and it should export the types and functions listed.

module Dfsa
( DFSA(A)
, states
, sigma
, start
, finals
, delta
, recognizes
, intersection
, union
, complement
, difference
, subset
, isEmpty
) where

We will use functions from other pre-defined modules ourselves. The general syntax of a module import is:

import MODULE_NAME as ID (comma delimited list of functions and types to import)

Our imports are the below.

import Data.Foldable as F (foldlM)
-- http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Foldable.html#v:foldlM
import Data.Maybe as M (mapMaybe)
-- http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Maybe.html#v:catMaybes
import Data.List as L (intersect,nub)
-- http://hackage.haskell.org/package/base-4.12.0.0/docs/Data-List.html

In addition, we would like to hide the definition of certain functions which are automatically imported, because I want to reuse their names.

import Prelude hiding (product)

We define DFSAs as a new type of object, using the keyword data. Objects of this type can only be created using the A constructor, which takes five arguments in the following order:

1. the state set
2. the alphabet
3. the initial state
4. the final states
5. the transition function

data DFSA q b = A [q] [b] q [q] (q -> b -> Maybe q)

We can access these arguments in a given DFSA by pattern matching, but it is sometimes more convenient to define helper functions for this purpose.

states :: DFSA q b -> [q]
states (A qs _ _ _ _) = qs 

sigma :: DFSA q b -> [b]
sigma (A _ bs _ _ _) = bs 

start :: DFSA q b -> q
start (A _ _ q0 _ _) = q0

finals :: DFSA q b -> [q]
finals (A _ _ _ fs _) = fs

delta :: DFSA q b -> q -> b -> Maybe q
delta (A _ _ _ _ d) = d

We define a function, deltaStar, which takes a (single-step) transition function as argument and creates a multi-step one. We could have written this code ourselves, but it has already been written for us in the module Data.Foldable.

deltaStar :: (q -> b -> Maybe q) -> q -> [b] -> Maybe q
deltaStar = F.foldlM
-- deltaStar delta q [] = q
-- deltaStar delta q (b:bs) = case delta q b of
--                             Nothing -> Nothing
--                             Just q' -> deltaStar delta q' bs

Armed with deltaStar, we can define recognition straightforwardly. Note that if the string given has letters not in the alphabet of the machine, it returns False. It would be mathematically more accurate to return undefined, but I would rather not do this.

recognizes :: (Eq q, Eq s) => DFSA q s -> [s] -> Bool
a `recognizes` input
  | all (`elem` sigma a) input =
    case deltaStar (delta a) (start a) input of
      Nothing -> False
      Just q -> q `elem` finals a
  | otherwise = False

For any alphabet Σ, there is a trivial machine recognizing all words over that alphabet \(\Sigma^{{\ast}}\).

trivial :: [b] -> DFSA () b
trivial alphabet = A [()] alphabet () [()] (\_ _ -> Just ())

In order to verify this (or even state this formally), we need to have some way of enumerating the words of a particular alphabet. As the number of possible words over a nonempty alphabet is infinite, we need to be careful about how we enumerate them; there are some enumeration strategies that are fundamentally unfair, in that we will never come to certain words. As a simple example, consider how we might unfairly enumerate the set of positive integers ([1,2,3..]) evens first ([2,4..]) followed by odds ([1,3..]). Clearly, this is a way of listing the positive integers, but it is unfair in that we will never see an odd integer. A better (fairer) way is to interleave them, making sure that all smaller numbers appear before any larger ones. In the setting of strings over an alphabet, we can ensure fairness by enumerating all shorter words before any longer ones. A conceptually clean way to do this is to create a tree whose nodes are labeled with strings, and then enumerating each level of the tree.¹

wordsOver :: [a] -> [[a]]
wordsOver = bft . wordTree

wordTree :: [a] -> Tree [a]
wordTree alphabet = iter prefixLetters []
  where
    prefixLetters ws = (: ws) <$> alphabet

-- A tree data type; a leaf is a node without children
data Tree a = Node a [Tree a]

-- Creating a tree from a seed and a function
iter :: (a -> [a]) -> a -> Tree a
iter grow seed = Node seed (iter grow <$> grow seed)

-- A breadth first tree traversal
bft t = bf [t]
  where
    bf [] = []
    bf (Node b bs : ts) = b : bf (ts ++ bs)

{-
A faster implementation, from Jones & Gibbons '93, avoids the
costly repeated appending (++) by breaking the list of trees into two
lists: the front half, and the back half /in reverse/.  Then appending
something at the end of the list (ts ++ bs) is putting something at
the front of the back half of the list (xs, reverse bs ++ ys).
Although this also involves an append, the number of daughters 'bs' is
much smaller in general than the size of a given level 'ts.'  

> bft t = bf ([t],[])
>   where
>     bf ([],[]) = []
>     bf ([],ys) = bf (reverse ys,[])
>     bf (Node b bs : xs,ys) = b : bf (xs, reverse bs ++ ys)
-}

Now the property that the trivial machine satisfies can be stated in the Haskell language.

-- The trivial machine has the property that it recognizes all words over its alphabet
recognizes (trivial alph) `all` wordsOver alph == True
-- This of course won't terminate, as there are infinitely many words
-- over a particular alphabet!

Our machines are not necessarily complete; whenever a machine has a transition to Nothing (instead of to Just q, for some q) it is incomplete. We can make machines complete by adding a new 'sink' state to which previously undefined transitions lead. We will name the sink state Nothing, and a transition to it will return Just Nothing!

complete :: DFSA q b -> DFSA (Maybe q) b
complete a = A qs bs (Just $ start a) fs d
  where
    qs = Nothing : fmap Just (states a)
    bs = sigma a
    fs = fmap Just (finals a)
    d Nothing _ = Just Nothing
    d (Just q) b = Just $ delta a q b

We can define the cross-product of two machines by taking pairs of states, and defining transitions pointwise over the pairs. The initial state is the pair of input initial states, but what should count as a final state is underdetermined. Accordingly, the cross-product function will expect instructions (in the form of a predicate) as to how to determine whether a state is final.

product ::(Eq q,Eq r) => (Bool -> Bool -> Bool) -> DFSA q b -> DFSA r b -> DFSA (q,r) b
product isFinal a1 a2 = A qs bs q0 fs d
  where
    qs = [(q1,q2) | q1 <- states a1, q2 <- states a2]
    bs = sigma a1 -- should be the same as sigma a2!!!
    q0 = (start a1,start a2)
    fs = filter (\(q1,q2) -> isFinal
                  (q1 `elem` finals a1)
                  (q2 `elem` finals a2)) qs
    d (x,y) b = 
      do
        q1 <- delta a1 x b
        q2 <- delta a2 y b
        return (q1,q2)

Given the ability to take cross-products of machines, we can use different ways of determining whether a state is final to define language-theoretic operations over machines.

intersection :: (Eq q, Eq r) => DFSA q b -> DFSA r b -> DFSA (q,r) b
intersection = product (&&)

union :: (Eq q, Eq r) => DFSA q b -> DFSA r b -> DFSA (q,r) b
union = product (||)

difference :: (Eq q, Eq r) => DFSA q b -> DFSA r b -> DFSA (q,r) b
difference = product (\b1 b2 -> b1 && not b2)

complement :: Eq q => DFSA q b -> DFSA (Maybe q, ()) b
complement a = product (const . not) (complete a) (trivial (sigma a))

The case of complement is mildly degenerate; the complement of the language accepted by a complete machine is recognized by a machine with the same states and transitions, but which accepts just when the other doesn't (i.e., its final states are exactly the non-final states of the original machine). We can squish this construction into the procrustean bed of the product construction by taking the product of a machine with the trivial machine over the same alphabet, which is identical to the original machine, but with different state names (the original state q corresponds to the state (Just q,())).

We can determine whether the language accepted by a given machine is empty, by analyzing whether any of its final states could ever be reached from the start state on some input. We can do this by taking the closure of the set contining the initial state under the transition function. The closure of an object under a function is achieved by applying the function over and over again starting at that object, until nothing else happens. A (slightly) less informal algorithmic intuition is that you apply the function to the current input, and check if the output is different from the input. If it is, try again (by applying the function to the output). If not, you have found a fixed point of the function, and this is the object you have been looking for.

closure :: Eq a => (a -> a) -> a -> a
closure f a = fst $ head $ filter (uncurry (==)) $ zip steps (tail steps)
  where
    steps = iterate f a

Now the set of states reachable from the initial state on some input is the closure of the set containing just the initial state (which is reachable from itself on the empty input) under the transition function.

reachable :: Eq q => DFSA q b -> [q]
reachable a = closure (L.nub . concat . fmap getSuccessors) [start a]
  where
    getSuccessors q = M.mapMaybe (delta a q) (sigma a)

A machine accepts no strings at all iff none of its final states are reachable.

isEmpty :: Eq q => DFSA q b -> Bool
isEmpty a = null (finals a `L.intersect` reachable a)

Aside from it being fascinating that we can decide properties of the language accepted by a machine by looking at its structure, we can leverage the ability to decide whether the language of a machine is the empty set to decide more interesting properties of machines, such as whether the language of one is a subset of the language of another!

subset :: (Eq q,Eq r) => DFSA q b -> DFSA r b -> Bool
subset a1 a2 = isEmpty $ difference a1 a2

And since equality of sets is equivalent to both being subsets of the other, we can determine whether the languages accepted by two DFSA are identical.

equivalent :: (Eq q,Eq r) => DFSA q b -> DFSA r b -> Bool
equivalent a1 a2 = subset a1 a2 && subset a2 a1

wordsOver alphabet = [] : [w:ws | ws <- wordsOver alphabet, w <- alphabet]

-- > take 10 $ wordsOver "ab"
-- > ["","a","b","aa","ba","ab","bb","aaa","baa","aba"]

wordsOverBad alphabet = [] : [w:ws | w <- alphabet, ws <- wordsOverBad alphabet]

-- > take 10 $ wordsOverBad "ab"
-- > ["","a","aa","aaa","aaaa","aaaaa","aaaaaa","aaaaaaa","aaaaaaaa","aaaaaaaaa"]