> 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))