> 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, mapM, )
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))
> | Loop Tag
>
> 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))