> module Haskore.General.LoopTreeRecursive where
> import qualified Haskore.General.LoopTreeTagged as LTT
> import qualified Haskore.General.TagDictionary as Dict
> import Control.Monad.Trans.State(StateT, evalState, put, get, )
> import Control.Monad (liftM, )
Loop now needs an ID because there may be more than one of them.
> data T a =
>      Branch a [T a]
>    | Recurse (Fix (T a)) -- function with a fix-point
>    | Loop Tag            -- tag needed for resolving Recurse by 'unwind'
>
> type Fix a = a -> a
> type Tag   = Int
> example0 :: T Char
> example0 = Recurse (\x -> Branch 'a' [Recurse (\y -> Branch 'b' [y]), x])
> example1 :: T Char
> example1 =
>    Branch 'a'
>       [Recurse (\x -> Branch 'b' [x]),
>        Recurse (\y -> Branch 'c' [y])]
Implement two interleaved recursions. let x = f y y = g x z z = h y in z
> exampleLeapFrog :: T Char
> exampleLeapFrog =
>    Recurse (\z -> Branch 'h' [
>       Recurse (\y -> Branch 'g' [
>          Branch 'f' [y],z])])
This data structure is very safe to use, that is, it is not possible to loop to undefined tags as in \code{LoopTreeTagged}. But some operations are easier to perform on the tagged variant. Especially we can not inspect the structure of the \code{Recurse} function immediately. Instead we have to place a \code{Loop} marker inside the tree produced by the \code{Recurse} function. In order to turn such a marked tree back into a \code{Recurse} function we have to maintain a dictionary. This is obviously not very efficient. Intensive operations should be applied to the tagged tree. We provide the conversions now. The function \function{toTagged} uses duplicate tags in different branches. They do not cause confusion but reduce data dependencies.
> toTagged :: Tag -> T a -> LTT.T Tag a
> toTagged n branch =
>    case branch of
>       Branch x s    ->  LTT.Branch x (map (toTagged n) s)
>       Recurse fe  ->  LTT.Tag n (toTagged (succ n) (fe (Loop n)))
>       Loop m      ->  LTT.Loop m
The function \function{toTaggedUnique} employs a State in order to assign tags that are unique overall the whole tree.
> toTaggedUnique :: Tag -> T a -> LTT.T Tag a
> toTaggedUnique n branch = evalState (toTaggedState branch) n
> toTaggedState :: (Enum tag, Monad m) => T a -> StateT tag m (LTT.T tag a)
> toTaggedState branch =
>    case branch of
>       Branch x s    ->  liftM (LTT.Branch x) (mapM toTaggedState s)
>       Recurse fe  ->  do n <- get
>                          put (succ n)
>                          liftM (LTT.Tag n)
>                                (toTaggedState (fe (Loop (fromEnum n))))
>       Loop m      ->  return (LTT.Loop (toEnum m))
> fromTagged :: (Ord tag) => LTT.T tag a -> T a
> fromTagged =
>    let conv tags branch =
>           case branch of
>              LTT.Branch x s   ->  Branch x (map (conv tags) s)
>              LTT.Tag tag x  ->  Recurse (\y -> conv
>                                           (Dict.insert tag y tags) x)
>              LTT.Loop tag   ->  Dict.lookup tags tag
>    in  conv Dict.empty
To check equality of and show Trees, we need to supply unique Tags to each recursive loop, which we do via a simple counter.
> instance Eq a => Eq (T a) where
>   x == y  =  toTagged 0 x == toTagged 0 y
>
> instance Show a => Show (T a) where
>   show  =  show . toTaggedUnique 0
>
> instance Functor T where
>   fmap f  =  fromTagged . fmap f . toTagged 0
Unwinding (i.e. computing fixpoints):
> unwind :: T a -> T a
> unwind (Branch x s)    = Branch x (map unwind s)
> unwind (Recurse fe)  = x where x = unwind (fe x)
> unwind (Loop _)      = error "unwind: no loop allowed in a tree"
The 2nd equation above is analogous to: fix f = x where x = f x And these two equations could also be written as: fix f = f (fix f) unwind (Rec fe) = unwind (fe (Rec fe))