sourceCode haskell">{-# LANGUAGE TypeSynonymInstances, F=
lexibleInstances, TupleSections #-}
import           Data.Listan> (intersperse)
import           Data.Setn> (Set)
import           Control.Monad=
.State
import           Control.Monad=
.Writer
import qualified Data.Setn> as Set

data Tree a b
  =3D Leaf   {ss=3D"ot"> leafValue   :: b
           }
  | Branch {=3D"ot"> branchValue :: a
           , branchLeft  :: Tr=
ee a b
           , branchRight :: Tr=
ee a b
           }
  deriving Show

value :: Tree a a  class=3D"ot">-> a
value (Leaf a) =3D a
value (Branch a _ _) =3D> a

-- Bottom up
phase1 :: Ord b lass=3D"ot">=3D> Tree a b =3D"ot">-> (Set b, T=
ree (Set b) b)
phase1 (Leaf b) =3D (Se=
t.singleton b, Leaf b)
phase1 (Branch _ l r) =3Dn>
  (s3, Branch s3 l' r')
  where
    (s1, l') =3D phase1 l
    (s2, r') =3D phase1 r
    s3 =3D
      if Set.null i then> u else i
      where
        u =3D Set.union s1 s2
        i =3D Set.intersection s1 s2

-- Top down
phase2 :: Ord b lass=3D"ot">=3D> Tree (t">Set b) b -> Maybe=
 b -> Tree b b
phase2 (Leaf b) _ =3D <=
span class=3D"dt">Leaf b
phase2 (Branch set left right) parentOpt ass=3D"fu">=3D
  Branch b (phase2 left (Just<=
/span> b)) (phase2 right (Just b))
  where
    b =3D case parentOp=
t of
         Just p | Set.m=
ember p set -> p
         _ -> Set.elemAt 0<=
/span> set

-- Combine them together
fitch :: Ord b ass=3D"ot">=3D> Tree a b "ot">-> Tree b b
fitch t =3D
  phase2 t' Nothing
  where (_, t') =3D=
 phase1 t

--------------------------------------------------------=
----------
-- This part is about visualizing the trees using GraphV=
iz (dot)
class ToLabel a lass=3D"kw">where
  toLabel :: a -> pan class=3D"dt">String

instance ToLabel class=3D"dt">Char where
  toLabel c =3D [c]

instance ToLabel class=3D"dt">String where
  toLabel =3D id

instance ToLabel a n class=3D"ot">=3D> ToLabel (s=3D"dt">Set a) where
  toLabel s =3D
    "{" ++ co=
ncat (intersperse "," (map toLabel (Set=
.toList s))) ++ "}"<=
/span>

next :: State ss=3D"dt">Int Int
next =3D get <* modi=
fy (+1)

numberTree :: Tree a b =
-> State =3D"dt">Int (Tree (Int<=
/span>,a) (Int,b))
numberTree (Leaf b) =3D
  Leaf . (,b) ss=3D"fu"><$> next
numberTree (Branch a l r) =3D<=
/span>
  Branch . (,a) lass=3D"fu"><$> next <*> numbe=
rTree l <*> numberTree r

graphViz' :: (ToLabeln> a, ToLabel b) =3D>> Tree (Int,a) (lass=3D"dt">Int,b) -> ">Writer String String<=
/span>
graphViz' (Leaf (i,b)) =3D=
 do
  let n =3D =3D"st">"n" ++ show i
  tell $ n ++ ss=3D"st">" [shape=3Dbox, label=3D\"" fu">++ toLabel b ++ &qu=
ot;\"]\n"
  return n
graphViz' (Branch (i,a) l r) u">=3D do
  n1 <- graphViz' l
  n2 <- graphViz' r
  let np =3D s=3D"st">"n" ++ show i
  tell $ np ++ ass=3D"st">" [shape=3Doval, label=3D\"" =3D"fu">++ toLabel a ++ >"\"]\n"
  tell $ np ++ ass=3D"st">" -> " ++ n1  class=3D"fu">++ "\n"
  tell $ np ++ ass=3D"st">" -> " ++ n2  class=3D"fu">++ "\n"
  return np

graphViz :: (ToLabel a,=
 ToLabel b) =3D> an class=3D"dt">Tree a b -> =3D"dt">String
graphViz t =3D
  "digraph{\n" ++pan> execWriter (graphViz' t') ++ lass=3D"st">"}\n"
  where t' =3D eval=
State (numberTree t) 0

-- Sample tree from http://www.cse.nd.edu/~cse/2013fa/40=
532/lectures/lecture23/lecture23.pdf
t1 :: Tree () ss=3D"dt">Char
t1 =3D Branch ()
     ( Branch ()
       ( Branch ()
         (Leaf 'C'an>)
         (Leaf 'G'an>)
       )
       ( Branch ()
         (Leaf 'T'an>)
         (Leaf 'G'an>)
       )
     )
     (Leaf 'A')

main :: IO ()
main =3D
  putStrLn $ graphViz $=
 fitch t1