Editing Tying the Knot (section)

== Transformations of cyclic graphs and the Credit Card Transform ==

Cycles certainly make it difficult to transform graphs in a pure non-strict language. Cycles in a source graph require us to devise a way to mark traversed nodes -- however we cannot mutate nodes and cannot even compare nodes with a generic (''derived'') equality operator. Cycles in a destination graph require us to keep track of the already constructed nodes so we can complete a cycle.

An obvious solution is to use a state monad and <tt>IORefs</tt>. There is also a monad-less solution, which is less obvious: seemingly we cannot add a node to the dictionary of already constructed nodes until we have built the node. This fact means that we cannot use the updated dictionary when building the descendants of the node -- which need the updated dictionary to link back. The problem can be overcome however with a ''credit card transform'' (a.k.a. "buy now, pay later" transform). To avoid hitting the bottom, we just have to "pay" by the "due date".

For illustration, we will consider the problem of printing out a non-deterministic finite automaton (NFA) and transforming it into a deterministic finite automaton (DFA). Both NFA and DFA are represented as cyclic graphs. The problem has been discussed on the Haskell/Haskell-Cafe mailing lists. The automata in question were to recognize strings over a binary alphabet.

A state of an automaton over a binary alphabet is a data structure:
<haskell>
data (Ord l,Show l) => FaState l =
        FaState {label :: l, acceptQ :: Bool,
                 trans0:: [FaState l],
                 trans1:: [FaState l]}
</haskell>
whose fields have the obvious meaning. Label is used for printing out and comparing states. The flag <code>acceptQ</code> tells if the state is final. Since an <code>FaState</code> can generally represent a non-deterministic automaton, transitions are the ''lists'' of states.

An automaton is then a list of starting states.
<haskell>
type FinAu l = [FaState l]
</haskell>
For example, an automaton equivalent to the regular expression <code>0*(0(0+1)*)*</code> could be defined as:
<haskell>
dom18 = [one]
     where one = FaState 1 True [one,two] []
           two = FaState 2 True [two,one] [one,two]
</haskell>
using the straightforward translation from a regular expression to an NFA.

We would like to compare and print automata and their states:
<haskell>
instance (Ord l,Show l) => Eq (FaState l) where
    (FaState l1 _ _ _) == (FaState l2 _ _ _) = l1 == l2
</haskell>

Printing a <code>FaState</code> however poses a slight problem. For example, the state labeled 1 in the automaton <code>dom18</code> refers to itself. If we blindly "follow the links", we will loop forever. Therefore, we must keep track of the already printed states. We need a data structure for such an occurrence check, with the following obvious operations:

<haskell>
class OCC occ where
    empty:: occ a
    seenp:: (Eq a) => a -> occ a -> Bool -- occurrence check predicate
    put::  a -> occ a -> occ a           -- add an item
</haskell>

In this article, we realize such a data structure as a list. In the future, we can pull in something fancier from the ''Edison'' collection:

<haskell>
instance OCC [] where
    empty = []
    seenp = elem
    put = (:)
</haskell>

We are now ready to print an automaton. To be more precise, we traverse the corresponding graph depth-first, pre-order, and keep track of the already printed states. A <code>states_seen</code> datum accumulates the shown states, so we can be sure we print each state only once and thus avoid the looping.

<haskell>
instance (Ord l,Show l) => Show (FaState l) where
    show state = "{@" ++ showstates [state] (empty::[FaState l]) "@}"
         where
           -- showstates worklist seen_states suffix
           showstates [] states_seen suffix = suffix
           showstates (st:rest) states_seen suffix
               | st `seenp` states_seen = showstates rest states_seen suffix
           showstates (st@(FaState l accept t0 t1):rest) states_seen suffix =
               showstate st
                     $ showstates (t0++t1++rest) (st `put` states_seen) suffix

           showstate (FaState l accept t0 t1) suffix
                     = "{State " ++ (show l) ++
                     " " ++ (show accept) ++ " " ++ (show $ map label t0) ++
                     " " ++ (show $ map label t1) ++ "}" ++ suffix
</haskell>

Now,

<haskell>
 CCardFA> print dom18 -- prints as
 CCardFA> [{@{State 1 True [1,2] []}{State 2 True [2,1] [1,2]}@}]
</haskell>

The acceptance function for our automata can be written as follows. The function takes the list of starting states and the string over the boolean alphabet. The function returns <code>True</code> if the string is accepted.

<haskell>
finAuAcceptStringQ start_states str =
        any (\l -> acceptP l str) start_states
    where acceptP (FaState _ acceptQ _ _) [] = acceptQ
          acceptP (FaState _ _ t0 t1) (s:rest) =
                  finAuAcceptStringQ (if s then t1 else t0) rest
</haskell>

To test the automata, we can try

<haskell>
test1= finAuAcceptStringQ dom18 $ map (>0) [0,1,0,1]
test2= finAuAcceptStringQ dom18 $ map (>0) [1,1,0,1]
test3= finAuAcceptStringQ dom18 [True]
test4= finAuAcceptStringQ dom18 [False]
</haskell>

We are now ready to write the NFA→DFA conversion, a determinization of an NFA. We implement the textbook algorithm of tracing set of NFA states. A state in the resulting DFA corresponds to a list of the NFA states. A DFA is generally a cyclic graph, often with cycles of length 1 (self-referenced nodes). To be able to "link back" as we build DFA states, we have to remember the already constructed states. We need a data structure, a dictionary of states:

<haskell>
class StateDict sd where
    emptyd :: sd (l,FaState l)
    locate :: (Eq l) => l -> sd (l,FaState l) -> Maybe (FaState l)
    putd   :: (l,FaState l) -> sd (l,FaState l) -> sd (l,FaState l)
</haskell>

For now, we realize this dictionary as an associative list. If performance matters, we can use a fancier dictionary from the ''Edison'' collection:

<haskell>
instance StateDict [] where
    emptyd = []
    locate = lookup
    putd   = (:)
</haskell>

The work of the NFA→DFA conversion is done by the following function <code>determinize_cc</code>. The function takes a list of NFA states, the dictionary of the already built states, and returns a pair <hask>([dfa_state], updated_dictionary)</hask> where <hask>[dfa_state]</hask> is a singleton list.

<haskell>
-- [nfa_state] -> dictionary_of_seen_states ->
--                ([dfa_state],updated_dictionary)
-- [dfa_state] is a singleton list
determinize_cc states converted_states =
        -- first, check the cache to see if the state has been built already
      case  dfa_label `locate` converted_states of
        Nothing -> build_state
        Just dfa_state -> ([dfa_state],converted_states)
  where
      -- [NFA_labels] -> DFA_labels
      det_labels = sort . nub . map label
      dfa_label  = det_labels states

      -- find out NFA-followers for [nfa_state] upon ingestion of 0 and 1
      (t0_followers,t1_followers) =
                foldr (\st (f0,f1) -> (trans0 st ++ f0, trans1 st ++ f1))
                      ([],[]) states
      acceptQ'    = any acceptQ states

      -- really build the dfa state and return ([dfa_state],updated_cache)
      build_state = let
           -- note, the dfa_state is computed _below_
           converted_states1 = (dfa_label,dfa_state) `putd` converted_states
           (t0', converted_states2) =
                   (determinize_cc t0_followers converted_states1)
           (t1', converted_states3) =
                   (determinize_cc t1_followers converted_states2)
           dfa_state =
                (FaState dfa_label acceptQ' t0' t1')
           in ([dfa_state],converted_states3)
</haskell>
The front end of the NFA→DFA transformer:
<hask>finAuDeterminize states = fst $ determinize_cc states []</hask>

At the heart of the credit card transform is the phrase from the above code:
{|
|<haskell>   converted_states1 = (dfa_label,dfa_state) `putd` converted_states</haskell>
|}
The phrase expresses the addition to the dictionary of the <code>converted_states</code> of a <code>dfa_state</code> that we haven't built yet. The computation of the <code>dfa_state</code> is written 4 lines below the phrase in question. Because <code>(,)</code> is non-strict in its arguments and <code>locate</code> is non-strict in its result, we can get away with a mere promise to "pay".

Note that the computation of the <code>dfa_state</code> needs <code>t0'</code> and <code>t1'</code>, which in turn rely on <code>converted_states1</code>. This fact shows that we can tie the knot by making a promise to compute a state, add this promise to the dictionary of the built states, and use the updated dictionary to build the descendants. Because Haskell is a non-strict language, we don't need to do anything special to make the promise. Every computation is Haskell is by default a promise.

We can print the DFA for <code>dom18</code> to see what we've got:
<haskell>
 CCardFA> finAuDeterminize dom18
 CCardFA>-- which shows
 CCardFA> [{@{State [1]   True  [[1,2]] [[]]   }
 CCardFA>    {State [1,2] True  [[1,2]] [[1,2]]}
 CCardFA>    {State []    False [[]]    [[]]   }@}]
</haskell>
which is indeed a DFA (which happens to be minimal) recognizing <code>(0+1)* - 1(0+1)*</code>

We can run the determinized FA using the same function <code>finAuAcceptStringQ</code>:
<haskell>
test1' = finAuAcceptStringQ (finAuDeterminize dom18) $ map (>0) [0,1,0,1]
test2' = finAuAcceptStringQ (finAuDeterminize dom18) $ map (>0) [1,1,0,1]
</haskell>

The complete code for this example is in http://pobox.com/~oleg/ftp/Haskell/CCard-transform-DFA.lhs.

Another example of tying a knot in the case of forward links, by using a fixed-point combinator, is discussed in http://www.mail-archive.com/haskell@haskell.org/msg10687.html.
----
=== Improved error-recovery for transformations of cyclic graphs ===
<blockquote>
<tt>(...some observations about the aforementioned [https://www.mail-archive.com/haskell@haskell.org/msg10687.html''forward links/fixed-point combinator'' example])</tt>

For a long time, I've had an issue with Oleg's reply to Hal Daume III, the "forward links" example. The problem is that it doesn't really exploit laziness or circular values. It's solution would work even in a strict language. It's simply a functional version of the standard approach: build the result with markers and patch it up afterwards.

It is a fairly clever way of doing purely something that is typically done with references and mutable update, but it doesn't really address what Hal Daume III was after. Fixing Hal Daume's example so that it won't loop is relatively trivial; simply change the <tt>case</tt> to a <tt>let</tt> or equivalently use a lazy pattern match in the case. However, if that's all there was to it, I would've written this a long time ago.

The problem is that it no longer gives you control of the error message or anyway to recover from it. With GHC's extensions to exception handling you could do it, but you'd have to put <code>readDecisionTree</code> in the <code>IO</code> monad to recover from it, and if you wanted better messages you'd have to put most of the parsing in the <code>IO</code> monad so that you could catch the error earlier and provide more information then rethrow.

What's kept me is that I couldn't figure out a way to tie the knot when the environment had a type like, <code>Either String [(String,DecisionTree)]</code>. This is because it's impossible for this case; we decide whether to return:
* <code>Left "could not find subtree"</code> or
* <code>Right someValue</code>
&emsp;and therefore whether the environment is <code>Left</code> or <code>Right</code> based on whether we could find the subtree in the environment. In effect, we need to lookup a value in an environment we may return to know whether to return it. Obviously this is a truly circular dependency.

This made me think that Oleg's solution was as good as any other and better than some (actually, ironically Oleg's solution also uses a <tt>let</tt> instead of a <tt>case</tt>, however, there's nothing stopping it from being a <tt>case</tt>, but it still would provide no way to recover from it without effectively doing what is mentioned below). Recently, I've thought about this again and the solution is obvious and follows directly from the original definition modified to use <tt>let</tt>.

It doesn't loop because only particular values in the lookup table fail, in fact, you might never know there was a variable lookup error if you didn't touch all of the tree. This translates directly into the environment having type <code>[(String,Either String DecisionTree)]</code>.

There are several benefits to this approach compared to Oleg's:
# it solves my original problem, you are now able to specify the error messages (Oleg's can do this),
# it goes beyond that (and beyond Hal Daume's original "specification") and also allows you to recover from an error without resorting to the <code>IO</code> monad and/or extensions (Oleg's can't do this),
# it does implicitly what Oleg's version does explicitly,
# because of (3) it shares properly while Oleg's ''does not'',
# both the environment and the returned value are made up of showable values, not opaque functions,
# it requires less changes to the original code and is more localized than Oleg's solution; only the variable lookup and top-level function will need to change.

To recover, all one needs to do is make sure all the values in the lookup table are <code>Right</code> values. If they aren't, there are various ways you could collect the information; there are also variations on how to combine error information and what to provide. Even without a correctness check, you can still provide better error messages for the erroneous thunks.

A possible variation that loses some of the benefits, is to change the <code>DecisionTree</code> type (or have a different version, <code>[[IndirectComposite]]</code> comes to mind here) that has <code>Either ErrorInfo ErrorDecisionTree</code> subnodes, which will allow you to recover at any time (though, if you want to make a normal <code>DecisionTree</code> out of it you will lose sharing). Also, the circular dependency only comes up if you need to use the environment to decide on an error.

For example:

* a plain old syntactic parse error can cyclicly use an <code>Either ErrorInfo [(String,DecisionTree)]</code> perfectly fine (pass in <code>fromRight env</code> where <code>fromRight ~(Right x) = x)</code>. It will also work even with the above approach giving the environment the type <code>Either [(String,Either ErrorInfo DecisionTree)]</code>. Below is code for a simplified scenario that does most of these things,

:<haskell>
module Main where
import Maybe ( fromJust )
import Monad

main :: IO ()
main = do
    input <- getContents
    length input `seq` print (fixup input)

instance Monad (Either s) where
    return = Right
    m >>= f = either Left f m

isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft        _ = False

fromRight :: Either a b -> b
fromRight ~(Right x) = x

fixup :: String -> Either String [(String,Either String String)]
fixup input = env
    where env = mapM (parse (fromRight env) . words) (lines input)

checkedFixup :: String -> Either String [(String,String)]
checkedFixup input =
    case fixup input of
        Left err -> Left err
        Right env -> case filter (isLeft . snd) env of
                        [] -> Right $ map (\(n,Right v) -> (n,v)) env
                        (_,Left err):_ -> Left err

parse :: [(String,Either String String)] -> [String] -> Either String (String,Either String String)
parse env ("define":name:values) = Right (name,values')
  where values' = liftM unwords $ mapM lookupRef values
        lookupRef ('*':word)
            = maybe (Left $ "couldn't find "++word++" in "++name)
                    id
                    (lookup word env)
        lookupRef word = Right word
parse env input = Left $ "parse error with: "++unwords input
</haskell>
:<code>checkedFixup</code> demonstrates how you could check and recover, but since the environment is the return value neither <code>fixup</code> or <code>checkedFixup</code> quite illustrate having potentially erroneous thunks in the actual return value. Some example:
:{|
|- style="text-align: center"
|'''input'''
|'''outputs'''
|-
|<pre>
define x *y *y
define y a b
</pre>
| <haskell>
Right [("x",Right "a b a b"),
       ("y",Right "a b")]
</haskell>
|-
|<pre>
define x *y *y
aousht
define y a b
</pre>
| <haskell>
Left "parse error with: aousht"
</haskell>
|-
|<pre>
define x *y *z
define y a b
define z *w
</pre>
| <haskell>
Right [("x",Left "couldn't find w in z"),
       ("y",Right "a b"),
       ("z",Left "couldn't find w in z")]
</haskell>
|}

* Consider a tree <tt>Y</tt> that contains the subtree <tt>X</tt> twice:

: With Oleg's version, when we resolve the <code>X</code> variable we look up a (manually) delayed tree and then build <tt>X</tt>. Each subtree of <tt>Y</tt> will build it's own version of <tt>X</tt>.

: With the truly circular version each subtree of <tt>Y</tt> will be the same, possibly erroneous, thunk that builds <tt>X</tt>, if the thunk isn't erroneous then when it is updated both of <tt>Y</tt>'s subtrees will point to the same <tt>X</tt>.

[[User:DerekElkins|Derek Elkins]]
</blockquote>

[[Category:Code]]
[[Category:Idioms]]