wumpus-tree 0.12.0 → 0.13.0

raw patch · 8 files changed

+504/−184 lines, 8 filesdep +wumpus-drawingdep ~wumpus-basicdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependencies added: wumpus-drawing

Dependency ranges changed: wumpus-basic, wumpus-core

API changes (from Hackage documentation)

Files

• demo/Demo01.hs +72/−77
• src/Wumpus/Tree.hs +41/−33
• src/Wumpus/Tree/Base.hs +19/−2
• src/Wumpus/Tree/Design.hs +70/−25
• src/Wumpus/Tree/Draw.hs +49/−40
• src/Wumpus/Tree/TreeBuildMonad.hs +217/−0
• src/Wumpus/Tree/VersionNumber.hs +2/−2
• wumpus-tree.cabal +34/−5

@@ -15,6 +15,7 @@ module Demo01 where  import Wumpus.Tree+import Wumpus.Tree.TreeBuildMonad  import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Basic.System.FontLoader.Afm@@ -53,113 +54,106 @@  makePictures :: GlyphMetrics -> IO () makePictures base_metrics = do -    ---    let pic1 = runDrawingU (makeCtx 18 base_metrics) tree_drawing1-    writeEPS "./out/tree01.eps"  pic1-    writeSVG "./out/tree01.svg"  pic1-    ---    let pic2 = runDrawingU (makeCtx 24 base_metrics) tree_drawing2-    writeEPS "./out/tree02.eps"  pic2-    writeSVG "./out/tree02.svg"  pic2-    ---    let pic3 = runDrawingU (makeCtx 14 base_metrics) tree_drawing3-    writeEPS "./out/tree03.eps"  pic3-    writeSVG "./out/tree03.svg"  pic3-    ---    let pic4 = runDrawingU (makeCtx 24 base_metrics) tree_drawing4-    writeEPS "./out/tree04.eps"  pic4-    writeSVG "./out/tree04.svg"  pic4-    ---    let pic5 = runDrawingU (makeCtx 24 base_metrics) tree_drawing5-    writeEPS "./out/tree05.eps"  pic5-    writeSVG "./out/tree05.svg"  pic5+    let pic1 = runCtxPictureU (makeCtx 18 base_metrics) tree_pic1+    writeEPS "./out/regular_tree01.eps"  pic1+    writeSVG "./out/regular_tree01.svg"  pic1 ++ makeCtx :: FontSize -> GlyphMetrics -> DrawingContext makeCtx sz m = fontFace times_roman $ metricsContext sz m   -tree_drawing1 :: DTreeDrawing-tree_drawing1 = drawScaledTree charNode  (uniformScaling 30) tree1+tree_pic1 :: DCtxPicture+tree_pic1 = drawTracing $ do+    --+    draw $ textline "Tree 1:"        `at` (P2 0  530)+    drawScaledTree (uniformSF 30)         (P2 80 530) $ +       runTreeBuild charNode tree1+    --+    draw $ textline "Tree 2:"       `at` (P2 160 530) +    drawScaledTree (uniformSF 30)        (P2 240 530) $ +        runTreeBuild (diskNode red) tree2 -tree_drawing2 :: DTreeDrawing-tree_drawing2 = drawScaledTree (diskNode red) (uniformScaling 30) tree2+    draw $ textline "Tree 3:"       `at` (P2 0  410) +    localize (fontSize 12) $ +        drawScaledFamilyTree (uniformSF 25) (P2 280 410) $ +          runTreeBuild charNode tree3 --- This should be drawn in the /family tree/ style...--- -tree_drawing3 :: DTreeDrawing-tree_drawing3 = drawScaledFamilyTree charNode (uniformScaling 25) tree3+    --+    draw $ textline "Tree 4:"       `at` (P2 0  200)+    drawScaledTree (scaleFactors 20 30)  (P2 80 200) $ +        runTreeBuild (circleNode black) tree4+    --+    draw $ textline "Tree 5:"        `at` zeroPt+    drawScaledTree (scaleFactors 20 30)  (P2 240 0) $+        runTreeBuild (circleNode black)  tree5  -tree_drawing4 :: DTreeDrawing-tree_drawing4 = drawScaledTree (circleNode black) (scaleFactors 20 30) tree4 -tree_drawing5 :: DTreeDrawing-tree_drawing5 = drawScaledTree (circleNode black) (scaleFactors 20 30) tree5+tree1 :: TreeBuild u (TreeSpec Char)+tree1 = regularBuild $ Node 'A' [Node 'B' bs, Node 'F' fs]+  where+    bs = [Node 'C' [], Node 'D' [], Node 'E' []]+    fs = [Node 'G' [Node 'H' [], Node 'I' [], Node 'J' []]]  -tree1 :: Tree Char-tree1 = Node 'A' [Node 'B' bs, Node 'F' fs]+tree2 :: TreeBuild u (TreeSpec Char)+tree2 = regularBuild $ Node 'A' [Node 'B' bs, Node 'F' [], Node 'G' gs]   where-   bs = [Node 'C' [], Node 'D' [], Node 'E' []]-   fs = [Node 'G' [Node 'H' [], Node 'I' [], Node 'J' []]]+    bs = [Node 'C' [], Node 'D' [], Node 'E' []]+    gs = [Node 'H' [], Node 'I' [], Node 'J' []] -tree2 :: Tree Char-tree2 = Node 'A' [Node 'B' bs, Node 'F' [], Node 'G' gs]-  where-   bs = [Node 'C' [], Node 'D' [], Node 'E' []]-   gs = [Node 'H' [], Node 'I' [], Node 'J' []]  -- This is the tree from Andrew Kennedy's  -- /Functional Pearl Drawing Trees/ ----- Currently Wumpus-tree cannot render in the /family tree/ style.----tree3 :: Tree Char-tree3 = Node 'A' [a1, a2, a3]+tree3 :: TreeBuild u (TreeSpec Char)+tree3 = regularBuild $ Node 'A' [a1, a2, a3]   where     a1 = Node 'B' [b1, b2]     a2 = Node 'S' [b3,b4]     a3 = Node 'o' [b5]-    b1 = Node 'C' [leaf 'D', c1]-    b2 = Node 'P' [leaf 'Q', leaf 'R']-    b3 = Node 'T' [leaf 'U', leaf 'V', c2]-    b4 = Node 'e' [c3, leaf 'h', c4]-    b5 = Node 'p' [c5, c6, leaf '2']+    b1 = Node 'C' [tleaf 'D', c1]+    b2 = Node 'P' [tleaf 'Q', tleaf 'R']+    b3 = Node 'T' [tleaf 'U', tleaf 'V', c2]+    b4 = Node 'e' [c3, tleaf 'h', c4]+    b5 = Node 'p' [c5, c6, tleaf '2']     c1 = Node 'E' [d1]     c2 = Node 'W' [d2, d3]-    c3 = Node 'f' [leaf 'g']+    c3 = Node 'f' [tleaf 'g']     c4 = Node 'i' [d4]-    c5 = Node 'q' [leaf 'r', leaf 's', leaf 't', leaf 'u']-    c6 = Node 'v' [leaf 'w', d5, leaf '0', leaf '1']-    d1 = Node 'F' [leaf 'G', e1, leaf 'M', e2]-    d2 = Node 'X' [leaf 'Y']-    d3 = Node 'Z' [leaf 'a', leaf 'b', leaf 'c', leaf 'd']-    d4 = Node 'j' [leaf 'k', leaf 'l', leaf 'm', leaf 'n']-    d5 = Node 'x' [leaf 'y', leaf 'z'] -    e1 = Node 'H' [leaf 'I', leaf 'J', leaf 'K', leaf 'L']-    e2 = Node 'N' [leaf 'O']+    c5 = Node 'q' [tleaf 'r', tleaf 's', tleaf 't', tleaf 'u']+    c6 = Node 'v' [tleaf 'w', d5, tleaf '0', tleaf '1']+    d1 = Node 'F' [tleaf 'G', e1, tleaf 'M', e2]+    d2 = Node 'X' [tleaf 'Y']+    d3 = Node 'Z' [tleaf 'a', tleaf 'b', tleaf 'c', tleaf 'd']+    d4 = Node 'j' [tleaf 'k', tleaf 'l', tleaf 'm', tleaf 'n']+    d5 = Node 'x' [tleaf 'y', tleaf 'z'] +    e1 = Node 'H' [tleaf 'I', tleaf 'J', tleaf 'K', tleaf 'L']+    e2 = Node 'N' [tleaf 'O'] -leaf :: a -> Tree a-leaf a = Node a []+tleaf :: a -> Tree a+tleaf a = Node a []   -- This is the tree (a) T3 from Buchheim, Junger and Leipert -- /Improving Walker\'s Algorithm to Run in Linear Time/. -- -tree4 :: Tree Int-tree4 = Node 1 [a1, a2]+tree4 :: TreeBuild u (TreeSpec Int)+tree4 = regularBuild $ Node 1 [a1, a2]   where     a1 = Node  2 [b1]     a2 = Node  3 [b2, b3]     b1 = Node  4 [c1]     b2 = Node  5 [c2]-    b3 = Node  6 [leaf 9, c3]+    b3 = Node  6 [tleaf 9, c3]     c1 = Node  7 [d1]-    c2 = Node  8 [leaf 12]+    c2 = Node  8 [tleaf 12]     c3 = Node 10 [d2] -    d1 = Node 11 [leaf 14]-    d2 = Node 13 [leaf 15]+    d1 = Node 11 [tleaf 14]+    d2 = Node 13 [tleaf 15]  -- This is the tree (b) T3 from Buchheim, Junger and Leipert -- /Improving Walker\'s Algorithm to Run in Linear Time/.@@ -168,13 +162,14 @@ -- spaces the leaves, it looks like the trees in that paper are  -- evenly spaced at the interior nodes too. -- -tree5 :: Tree Int-tree5 = Node 1 [a1, leaf 3, leaf 4, leaf 5, a2, leaf 7, leaf 8, leaf 9, a3]+tree5 :: TreeBuild u (TreeSpec Int)+tree5 = regularBuild $+    Node 1 [a1, tleaf 3, tleaf 4, tleaf 5, a2, tleaf 7, tleaf 8, tleaf 9, a3]   where-    a1 = Node  2 [leaf 11, leaf 12, leaf 13, leaf 14, leaf 15, leaf 16-                 , leaf 17, leaf 18, leaf 19, leaf 20, b1]-    a2 = Node  6 [leaf 22]-    a3 = Node 10 [b2]-    b1 = Node 21 [leaf 24, leaf 25, leaf 26, leaf 27, leaf 28, leaf 29-                 ,leaf 30, leaf 31, leaf 32, leaf 33, leaf 34]-    b2 = Node 23 [leaf 35]+    a1 = Node  2 [ tleaf 11, tleaf 12, tleaf 13, tleaf 14, tleaf 15, tleaf 16+                 , tleaf 17, tleaf 18, tleaf 19, tleaf 20, b1]+    a2 = Node  6 [ tleaf 22 ]+    a3 = Node 10 [ b2 ]+    b1 = Node 21 [ tleaf 24, tleaf 25, tleaf 26, tleaf 27, tleaf 28, tleaf 29+                 , tleaf 30, tleaf 31, tleaf 32, tleaf 33, tleaf 34]+    b2 = Node 23 [ tleaf 35 ]

@@ -17,14 +17,15 @@ module Wumpus.Tree   (   -- * The type of rendered trees-    TreeDrawing-  , DTreeDrawing        -- re-export. -  , ScaleFactors-  , uniformScaling+    ScaleFactors+  , uniformSF   , scaleFactors    , drawScaledTree+  , TreeDirection(..)+  , drawScaledTreeD+   , drawScaledFamilyTree  @@ -40,6 +41,7 @@ import Wumpus.Tree.Base import Wumpus.Tree.Design import Wumpus.Tree.Draw+import Wumpus.Tree.TreeBuildMonad  import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Drawing.Dots.AnchorDots@@ -48,7 +50,6 @@  import Data.VectorSpace                         -- package: vector-space -import Data.Tree hiding ( drawTree )   @@ -71,48 +72,55 @@  -- | Build uniform x- and y-scaling factors, i.e. @ x == y @. ---uniformScaling :: Num u => u -> ScaleFactors u-uniformScaling u = ScalingContext (\x -> u * x)-                                  (\y -> u * fromIntegral y) +uniformSF :: Num u => u -> ScaleFactors u+uniformSF u = ScalingContext (\x -> u * x)+                             (\y -> u * fromIntegral y)  + scaleFactors :: Num u => u -> u -> ScaleFactors u scaleFactors sx sy = ScalingContext (\x -> sx * x)                                     (\y -> sy * fromIntegral y)	  --- | 'drawTreePicture' : @ draw_fun * attr * scale_factors * tree -> TreePicture @------ The rendering function.+ -- --- @draw_fun@ renders the individual nodes. Usually 'charNode', --- 'circleNode'------ @attr@ is the font size (translates to node size), stroke --- colour, fill colour.------ @scale_factors@ scales the distances between parent and child --- (y-scale) and sibling nodes (x-scale).------ @tree@ is the input tree to be rendered.------+ drawScaledTree :: (Real u, Floating u, FromPtSize u, InnerSpace (Vec2 u)) -                => (a -> TreeNode u) -                -> ScaleFactors u-                -> Tree a +               => ScaleFactors u -> Point2 u -> TreeBuildAns u +               -> TreeDrawing u+drawScaledTree scale_f ogin (tree,annos) = +    drawTree annos $ design ogin scale_f tree++++data TreeDirection = TREE_UP | TREE_DOWN | TREE_LEFT | TREE_RIGHT+  deriving (Eq,Ord,Show)++drawScaledTreeD :: (Real u, Floating u, FromPtSize u, InnerSpace (Vec2 u)) +                => ScaleFactors u -> Point2 u +                -> TreeDirection -> TreeBuildAns u                  -> TreeDrawing u-drawScaledTree drawF scale_f tree = drawTree drawF $ design scale_f tree+drawScaledTreeD scale_f ogin tdir (tree,annos) = +    drawTree annos $ rotTree tdir $ design ogin scale_f tree    +rotTree :: (Real u, Floating u) +        => TreeDirection -> CoordTree u a -> CoordTree u a+rotTree TREE_UP     = rotateAboutRoot pi+rotTree TREE_DOWN   = id+rotTree TREE_LEFT   = rotateAboutRoot (1.5*pi)+rotTree TREE_RIGHT  = rotateAboutRoot (0.5*pi)++++ drawScaledFamilyTree :: (Real u, Floating u, FromPtSize u, InnerSpace (Vec2 u)) -                     => (a -> TreeNode u) -                     -> ScaleFactors u-                     -> Tree a -                     -> TreeDrawing u-drawScaledFamilyTree drawF scale_f tree = -    drawFamilyTree drawF $ design scale_f tree+               => ScaleFactors u -> Point2 u -> TreeBuildAns u +               -> TreeDrawing u+drawScaledFamilyTree scale_f ogin (tree,annos) = +    drawFamilyTree annos $ design ogin scale_f tree  -------------------------------------------------------------------------------- -- Drawing functions

@@ -17,12 +17,15 @@  module Wumpus.Tree.Base   (+     TreeDrawing   , DTreeDrawing   , CoordTree      , TreeNode +  , Design(..)+   ) where  import Wumpus.Basic.Kernel                      -- package: wumpus-basic@@ -32,21 +35,35 @@  import Data.Tree + -- | A rendered tree - alias for for @Picture Double@ in  -- Wumpus-Core. ---type TreeDrawing u = Drawing u+type TreeDrawing u      = TraceDrawing u () -type DTreeDrawing = TreeDrawing Double+type DTreeDrawing       = TreeDrawing Double  +++ -- | Tree annotated with positions. -- type CoordTree u a = Tree (Point2 u, a)   +-- | Tree nodes are currently a /Dot/ from Wumpus-Drawing.+--+-- At some point this should change to allow any object that +-- supports anchors.+-- type TreeNode u = DotLocImage u ++data Design u a = Design +      { tree_design     :: CoordTree u a+      , tree_bbox       :: BoundingBox u+      }  

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# OPTIONS -Wall #-} @@ -26,6 +27,7 @@ module Wumpus.Tree.Design   (     design+  , rotateAboutRoot   )   where @@ -33,12 +35,15 @@  import Wumpus.Basic.Kernel              -- package: wumpus-basic +import Wumpus.Core                      -- package: wumpus-core+ import Data.List  import Data.Maybe import Data.Tree   + -- | XPos is an absolute position -- type XPos u = u     @@ -50,30 +55,35 @@ -- type Delta u = u -data Span u = S !(XPos u) !(XPos u)+-- A horizontal span.+--+data HSpan u = HSpan !u !u   deriving (Eq,Ord,Show)   -outsideMerge :: Span u -> Span u -> Span u-outsideMerge (S p _) (S _ q) = S p q+outsideMerge :: HSpan u -> HSpan u -> HSpan u+outsideMerge (HSpan p _) (HSpan _ q) = HSpan p q -moveSpan :: Num u => Delta u -> Span u -> Span u-moveSpan d (S p q) = S (p+d) (q+d)  -newtype Extent u = Extent { span_list :: [Span u] }++moveSpan :: Num u => Delta u -> HSpan u -> HSpan u+moveSpan d (HSpan p q) = HSpan (p+d) (q+d)+++newtype Extent u = Extent { span_list :: [HSpan u] }   deriving (Eq,Show)  -extlink :: XPos u -> Extent u -> Extent u-extlink a (Extent as) = Extent (S a a:as)+extlink :: u -> Extent u -> Extent u+extlink a (Extent as) = Extent $ (HSpan a a) :as   -- note is this just for left ... ? ---midtop :: Fractional u => XPos u -> Extent u -> XPos u+midtop :: Fractional u => u -> Extent u -> XPos u midtop r (Extent [])        = r-midtop _ (Extent (S p q:_)) = p + (0.5*(q-p))+midtop _ (Extent (HSpan p q:_)) = p + (0.5*(q-p))   -- merge \"moving right\"...@@ -100,7 +110,7 @@ extentZero = Extent []  extentOne :: XPos u -> Extent u-extentOne x = Extent [S x x]+extentOne x = Extent [HSpan x x]   -- 'moveTree' is now recursive...@@ -114,10 +124,10 @@  fit :: (Fractional u, Ord u)      => Extent u -> Extent u -> u-fit a b = step (span_list a) (span_list b) 0.0 +fit a b = go (span_list a) (span_list b) 0.0    where-    step (S _ p:ps) (S q _:qs) acc = step ps qs (max acc (p - q + 1.0))-    step _          _          acc = acc  +    go (HSpan _ p:ps) (HSpan q _:qs) acc = go ps qs (max acc (p - q + 1.0))+    go _          _                  acc = acc     -- Fitting the children of a node...@@ -182,37 +192,72 @@     ext1            = xpos `extlink` ext0  +-- | Design a tree, properly balancing the child nodes oriented +-- at root. +--+-- As the design has no y-positions (but by recursion they can be +-- counted) and x-positions are respective to the unit distance +-- 1.0 separating nodes it is rescaled as a post-processing step+-- into drawable coordinates. +-- design :: (Fractional u, Ord u)-       => ScalingContext u Int u -> Tree a -> CoordTree u a-design sctx t = runScaling sctx (label 0 t3)+       => Point2 u -> ScalingContext u Int u -> Tree a -> CoordTree u a+design ro sctx t = rootOrientate ro $ scaleDesign sctx 0 t3   where     (t1,ext)                    = designl t-    (h,S xmin xmax)             = stats ext+    (_, HSpan xmin xmax)        = stats ext     width                       = xmax - xmin     (t2,_)                      = designr width t          -- reconcile the left and right drawings...     t3                          = treeZipWith zfn t1 t2+    zfn (x0,a) (x1,_)           = (mean x0 x1,a)+++-- Scale the tree. Originally the tree has no y-positions (but by +-- recursion they can be counted) and x-positions are respective +-- to the unit width 1.0.+--+scaleDesign :: Num uy +            => ScalingContext ux uy u -> uy -> Tree (XPos ux, a) -> CoordTree u a+scaleDesign ctx lvl (Node (xpos,a) kids) = Node (pt,a) kids'+  where+    pt    = scalePt ctx xpos lvl+    kids' = map (scaleDesign ctx (lvl-1)) kids+          -    mkPt x lvl                  = scalePt x (h - lvl)-    label lvl (Node (x,a) kids) = do pt <- mkPt x lvl-                                     kids' <- mapM (label (lvl+1)) kids-                                     return $ Node (pt,a) kids' -    zfn (x0,a) (x1,_)           = (mean x0 x1,a)+rootOrientate :: Num u => Point2 u -> CoordTree u a -> CoordTree u a+rootOrientate (P2 ox oy) (Node (P2 x0 y0, val) kids) = +    Node (P2 ox oy, val) $ map (mv (ox-x0) (oy-y0)) kids+  where+    mv dx dy (Node (P2 x y, a) ks) = let ks' = map (mv dx dy) ks +                                     in Node (P2 (x+dx) (y+dy), a) ks'  +rotateAboutRoot :: (Real u, Floating u) +                => Radian -> CoordTree u a -> CoordTree u a+rotateAboutRoot ang (Node (ogin,val) kids) =  +    Node (ogin, val) $ map step kids+  where+    step (Node (p0, a) ks) = Node (rotA p0, a) $ map step ks +    rotA                   = rotateAbout ang ogin+ -- find height and width ---stats :: (Num u, Ord u) => Extent u -> (Int, Span u)-stats (Extent [])     = (0,S 0 0)+stats :: (Num u, Ord u) => Extent u -> (Int, HSpan u)+stats (Extent [])     = (0,HSpan 0 0) stats (Extent (e:es)) = foldr fn (1,e) es   where-    fn (S x0 x1) (h, S xmin xmax) = (h+1, S (min x0 xmin) (max x1 xmax))+    fn s1 (h, acc_span) = (h+1, minmaxMerge s1 acc_span)  mean :: Fractional u => u -> u -> u mean x y = (x+y) / 2.0+++minmaxMerge :: Ord u => HSpan u -> HSpan u -> HSpan u+minmaxMerge (HSpan p q) (HSpan p' q') = HSpan (min p p') (max q q')   treeZipWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-} @@ -23,6 +24,7 @@   ) where  import Wumpus.Tree.Base+import Wumpus.Tree.TreeBuildMonad  import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Drawing.Dots.AnchorDots@@ -32,39 +34,53 @@   import Control.Monad+import qualified Data.IntMap as IntMap import Data.Tree hiding ( drawTree )   ------------------------------------------------------------------------------------- Draw individual connector between parent and each child node.  drawTree :: (Real u, Floating u, FromPtSize u) -         => (a -> TreeNode u) -         -> CoordTree u a -         -> Drawing u-drawTree drawF tree = drawTracing $ drawTop drawF tree +          => NodeAnnoRefs u -> CoordTree u (TreeNodeAns u) -> TreeDrawing u+drawTree annos tree = drawStep annos radialConns tree >> return ()  -drawTop :: (Real u, Floating u) -        => (a -> TreeNode u) -> CoordTree u a -> TraceDrawing u ()-drawTop fn (Node (pt,a) ns) = do -    ancr <- drawi $ fn a `at` pt-    mapM_ (draw1 fn ancr) ns -draw1 :: (Real u, Floating u)-      => (a -> TreeNode u) -      -> DotAnchor u -      -> CoordTree u a -      -> TraceDrawing u ()-draw1 fn ancr_from (Node (pt,a) ns) = do-    ancr <- drawi $ fn a `at` pt-    draw $ connector ancr_from ancr-    mapM_ (draw1 fn ancr) ns   +drawFamilyTree :: (Real u, Floating u, FromPtSize u) +          => NodeAnnoRefs u -> CoordTree u (TreeNodeAns u) -> TreeDrawing u+drawFamilyTree annos tree = drawStep annos familyConn tree >> return ()  -connector :: (Real u, Floating u) -          => DotAnchor u -> DotAnchor u -> Graphic u+drawStep :: (Real u, Floating u) +         => NodeAnnoRefs u +         -> (DotAnchor u -> [DotAnchor u] -> Graphic u)+         -> CoordTree u (TreeNodeAns u) -> TraceDrawing u (DotAnchor u)+drawStep annos connF (Node (pt,(fn, mb_ix)) ns) = do +    ancr <- drawi $ fn `at` pt+    xs   <- mapM (drawStep annos connF) ns   +    when (not $ null xs) $ draw $ connF ancr xs+    drawAnno annos ancr mb_ix+    return ancr++drawAnno :: NodeAnnoRefs u -> DotAnchor u -> Maybe Int -> TraceDrawing u ()+drawAnno _    _    Nothing   = return ()+drawAnno refs ancr (Just ix) = maybe (return ()) sk $ IntMap.lookup ix refs+  where+    sk fn = draw $ fn ancr++++radialConns :: ( Real u, Floating u+               , CenterAnchor a, RadialAnchor a, u ~ DUnit a ) +            => a -> [a] -> Graphic u+radialConns a []            = emptyLocGraphic `at` center a+radialConns a (x:xs)        = oconcat (connector a x) (map (connector a) xs)++++connector :: ( Real u, Floating u+             , CenterAnchor a, RadialAnchor a, u ~ DUnit a )  +          => a -> a -> Graphic u connector a1 a2 = openStroke $ vertexPath [p1,p2]   where       (ang0,ang1)    = anchorAngles (center a1) (center a2)@@ -74,34 +90,27 @@   -anchorAngles :: (Floating u, Real u) +anchorAngles :: (Real u, Floating u)               => Point2 u -> Point2 u -> (Radian,Radian) anchorAngles f t = (theta0, theta1)   where     conn_v  = pvec f t-    theta0  = direction conn_v+    theta0  = vdirection conn_v     theta1  = if theta0 < pi then theta0 + pi else theta0 - pi      ------------------------------------------------------------------------------------ Draw in /family tree/ style -drawFamilyTree :: (Real u, Floating u, FromPtSize u) -               => (a -> TreeNode u) -               -> CoordTree u a -               -> Drawing u-drawFamilyTree drawF tree = drawTracing $ drawFamily drawF tree   -drawFamily :: (Fractional u, Ord u) -           => (a -> TreeNode u)  -           -> CoordTree u a -           -> TraceDrawing u (DotAnchor u)-drawFamily fn (Node (pt,a) ns) = do-    ancr <- drawi $ fn a `at` pt-    xs   <- mapM (drawFamily fn) ns   -    when (not $ null xs) $ draw $ famconn (south ancr) (map north xs)-    return ancr++--------------------------------------------------------------------------------+-- ++familyConn :: ( Real u, Fractional u+              , CenterAnchor a, CardinalAnchor a, u ~ DUnit a ) +           => a -> [a] -> Graphic u+familyConn a []            = emptyLocGraphic `at` center a+familyConn a xs            = famconn (south a) (map north xs)  famconn :: (Fractional u, Ord u) => Point2 u -> [Point2 u] -> Graphic u famconn _       []         = error "famconn - empty list"

@@ -0,0 +1,217 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Tree.TreeBuildMonad+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Build a tree within a monad - the monad allows anchor references.+--+--------------------------------------------------------------------------------++module Wumpus.Tree.TreeBuildMonad+  (+    NodeId+  , ZNodeId+  , NodeAnno+  , NodeAnnoRefs+  +  , TreeBuild+  , TreeSpec+  , ZTreeSpec++  , TreeNodeAns+  , TreeBuildAns+  , runTreeBuild++  , regularBuild++  , nodeId+  , label+  , annotate++  , branch+  , zbranch+  , leaf+  , zleaf++  ) where++import Wumpus.Tree.Base++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Drawing.Dots.AnchorDots++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import qualified Data.IntMap as IntMap+import Data.Monoid+import Data.Tree++++++-- | Nodes can be bound with @(>>=)@ or in the do-notation before +-- they are drawn. This is similar to the concept of /embedded/ +-- nodes in TikZ. Bound nodes can be referenced by their anchors +-- e.g. to give them an extra annotation.+--+-- This opaque type represents bound nodes and regular nodes that +-- are just drawn and cannot be annotated.+-- +data NodeId a = NodeId Int+              | RegularNode a+  deriving (Eq)++-- The default node type. With this type, regular nodes have no+-- payload so can only be drawn as some common graphic e.g. a +-- filled or stroked disk.+--+type ZNodeId u = NodeId (UNil u)++type NodeDrawRefs u = IntMap.IntMap (TreeNode u)++type NodeAnno u     = DotAnchor u -> Graphic u++type NodeAnnoRefs u = IntMap.IntMap (NodeAnno u)++data St u = St+      { uid_counter     :: Int+      , node_refs       :: NodeDrawRefs u+      , anno_refs       :: NodeAnnoRefs u+      }++type instance DUnit (St u) = u++zeroSt :: St u+zeroSt = St { uid_counter = 0, node_refs = mempty, anno_refs = mempty }+++newtype TreeBuild u a = TreeBuild { getTreeBuild :: St u -> (a, St u) }++instance Functor (TreeBuild u) where+  fmap f ma = TreeBuild $ \s -> let (a,s1) = getTreeBuild ma s in (f a, s1)++instance Applicative (TreeBuild u) where+  pure a    = TreeBuild $ \s -> (a,s)+  mf <*> ma = TreeBuild $ \s -> let (f,s1) = getTreeBuild mf s+                                    (a,s2) = getTreeBuild ma s1+                                in (f a,s2)++instance Monad (TreeBuild u) where+  return a  = TreeBuild $ \s -> (a,s)+  ma >>= k  = TreeBuild $ \s -> let (a,s1) = getTreeBuild ma s +                                in getTreeBuild (k a) s1 +++++type instance MonUnit (TreeBuild u) = u+++type TreeSpec a   = Tree (NodeId a)+type ZTreeSpec u  = TreeSpec (UNil u)+++type TreeNodeAns  u = (TreeNode u, Maybe Int)+type TreeBuildAns u = (Tree (TreeNodeAns u), NodeAnnoRefs u)++-- | This is the @run@ function for the TreeBuild monad.+--+-- Note the monadic /command/ is type specialized to +-- @(TreeSpec a)@, this is because evaluation in the TreeBuild+-- monad is only significant for producing a @Tree (TreeNode u)@.+--++runTreeBuild :: (Real u, Floating u, FromPtSize u)+               => (a -> TreeNode u) -> TreeBuild u (TreeSpec a) -> TreeBuildAns u+runTreeBuild regDrawF ma = +    let (a,s) = getTreeBuild ma zeroSt+        t1    = postRun regDrawF (a, node_refs s)+    in (t1, anno_refs s)+++-- As the constructor to build NodeIds is not exposed a +-- TreeBuild should not be able to refer to uninstantiated+-- nodes, however while the failure continuation should be +-- unreachable we still need it in the code to make the +-- IntMap.lookup total.+--+postRun :: (Real u, Floating u, FromPtSize u)+        => (a -> TreeNode u) -> (TreeSpec a,NodeDrawRefs u) +        -> Tree (TreeNode u, Maybe Int)+postRun regDrawF (tree1,table) = fmap changeNode tree1+  where+    changeNode (RegularNode a)  = (regDrawF a, Nothing)+    changeNode (NodeId ix)      = maybe fk (sk ix) $ IntMap.lookup ix table +    +    sk ix                       = \a -> (a, Just ix)+    fk                          = (dotText "Error missing node", Nothing)+ +++-- | Turn an ordinary @Data.Tree@ into a /regular/ 'TreeSpec'.+--+-- All nodes become /regular/ nodes, no nodes are /bound/. Thus+-- nodes cannot be annotated etc.+--  +regularBuild :: Tree a -> TreeBuild u (TreeSpec a)+regularBuild (Node a kids) =  +    Node (RegularNode a) <$> mapM regularBuild kids+++nodeId :: TreeNode u -> TreeBuild u (NodeId a)+nodeId drawF = +    TreeBuild $ \(St ix nodes annos) -> +      let nodes' = IntMap.insert ix drawF nodes+      in (NodeId ix, St (ix+1) nodes' annos)++-- | Note - this is not /in/ the TreeBuild monad.+--+label :: a -> NodeId a +label a = RegularNode a+++-- | Annotate a /node/ with a 'NodeAnno'.+-- +-- Note - /regular/ nodes cannot be annotated, a node must be +-- bound to a variable first with 'nodeId'.+--+annotate :: u ~ DUnit a => NodeId a -> NodeAnno u -> TreeBuild u ()+annotate (RegularNode _) _     = return ()+annotate (NodeId nid)    annoF = +    TreeBuild $ \(St ix nodes annos) -> +      let annos' = IntMap.insert nid annoF annos+      in ((), St ix nodes annos')++++branch :: NodeId a -> [TreeSpec a] -> TreeSpec a+branch uid kids = Node uid kids+++-- | Default /branch/ - has children.+--+zbranch :: [ZTreeSpec u] -> ZTreeSpec u+zbranch kids = Node (RegularNode uNil) kids ++leaf :: NodeId a -> TreeSpec a+leaf uid = Node uid []++-- | Default /leaf/ - tree node with no children.+--+zleaf :: ZTreeSpec u+zleaf = Node (RegularNode uNil) []+++            ++

@@ -22,7 +22,7 @@  -- | Version number ----- > (0,12,0)+-- > (0,13,0) -- wumpus_tree_version :: (Int,Int,Int)-wumpus_tree_version = (0,12,0)+wumpus_tree_version = (0,13,0)

@@ -1,5 +1,5 @@ name:             wumpus-tree-version:          0.12.0+version:          0.13.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -28,12 +28,39 @@   <https://www.adobe.com/content/dam/Adobe/en/devnet/font/pdfs/Core14_AFMs.tar>   .   .-  \*\* WARNING \*\* - the API is unstable and will change. +  \*\* WARNING \*\* - the API is unstable and will change.   .   Changelog:   .-  v0.11.1 to v.0.12.0:+  v0.12.0 to v0.13.0:   .+  * Changed the specification of trees so that they are built in a+    monad. The bind operation of the monad allows /anchors/ to be +    extracted from tree nodes so they can be annotated with +    supplementary graphics. At the moment this is rather limited +    as Wumpus-Basic and Wumpus-Drawing do not offer much support +    for anchors other than the basic type classes.+  .+  * Changed the type of the rendering functions so they produce a +    TreeDrawing. This type is more suitable for building composite+    pictures than the previous type TreePicture. +  .+  * Also the rendering functions now take a start point for the +    root node, again this should be more convenient for drawing +    composite pictures - see the demo which now draws all the +    example trees on one page.+  .+  * Internally the tree design is now more flexible - trees can be +    designed upwards or leftwards rightwards, rather than just +    downwards; and edge drawing style is lifted out of the +    rendering to use a supplied combinator. Currently these +    features are not exposed by the API, the API needs more +    thought (possibly warranting changes to Wumpus-Basic and +    Wumpus-Drawing).+  .+  .+  v0.11.1 to v0.12.0:+  .   * Internal changes to track updates to Wumpus-Basic.   .    .@@ -52,8 +79,9 @@   build-depends:      base              <  5,                        containers        >= 0.3.0     && <= 0.6.0,                       vector-space      >= 0.6       && <  1.0,-                      wumpus-core       == 0.41.0,-                      wumpus-basic      == 0.14.0+                      wumpus-core       >= 0.42.0    && <  0.43.0,+                      wumpus-basic      == 0.15.0,+                      wumpus-drawing    == 0.1.0       exposed-modules:@@ -61,6 +89,7 @@     Wumpus.Tree.Base,     Wumpus.Tree.Design,     Wumpus.Tree.Draw,+    Wumpus.Tree.TreeBuildMonad,     Wumpus.Tree.VersionNumber    other-modules: