wumpus-tree 0.15.0 → 0.16.0

raw patch · 13 files changed

+869/−792 lines, 13 filesdep ~wumpus-basicdep ~wumpus-coredep ~wumpus-drawingPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic, wumpus-core, wumpus-drawing

API changes (from Hackage documentation)

Files

• CHANGES +43/−0
• demo/Demo01.hs +36/−38
• src/Wumpus/Tree.hs +20/−141
• src/Wumpus/Tree/Base.hs +26/−35
• src/Wumpus/Tree/Design.hs +128/−62
• src/Wumpus/Tree/Draw.hs +0/−152
• src/Wumpus/Tree/DrawLoc.hs +112/−0
• src/Wumpus/Tree/OTMConnectors.hs +173/−0
• src/Wumpus/Tree/ScalingContext.hs +0/−103
• src/Wumpus/Tree/TreeBuildMonad.hs +0/−213
• src/Wumpus/Tree/TreeBuilder.hs +316/−0
• src/Wumpus/Tree/VersionNumber.hs +2/−2
• wumpus-tree.cabal +13/−46

@@ -1,3 +1,46 @@+0.14.0 to 0.15.0:++  * Updated to work with latest Wumpus libraries. +    @ScalingContext@ has been temporarily added from Wumpus-Basic +    (it was considered obsolete there). At some point the +    functionality needs re-implementing so it can be removed from +    Tree.+  +0.13.0 to 0.14.0:++  * Updated to work with latest Wumpus libraries. ++0.12.0 to 0.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).+++0.11.1 to 0.12.0:++  * Internal changes to track updates to Wumpus-Basic.+   0.11.0 to 0.11.1: 

@@ -1,23 +1,13 @@ {-# OPTIONS -Wall #-} --- Note - @main@ is more convoluted than would normally be --- expected as it supports both sources of glyph metrics - the --- GhostScript distribution or the Core 14 metrics from Adobe.--- --- \"Real\" applications would be expected to choose one source. ------ I-am-not-a-lawyer, but it does look as though the Adobe font--- metrics are redistributable, the GhostScript metrics are --- seemingly redistributable under the same terms as the larger--- GhostScript distribution.---   module Demo01 where  import Wumpus.Tree-import Wumpus.Tree.TreeBuildMonad+-- import Wumpus.Tree.TreeBuildMonad  import Wumpus.Drawing.Colour.SVGColours         -- package: wumpus-drawing+import Wumpus.Drawing.Dots.AnchorDots import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic@@ -35,7 +25,7 @@ main1 :: FontLoader -> IO () main1 loader = do     createDirectoryIfMissing True "./out/" -    base_metrics <- loader [ Right helvetica_family ]+    base_metrics <- loader [ Right times_roman_family ]     printLoadErrors base_metrics     let pic1 = runCtxPictureU (makeCtx 18 base_metrics) tree_pic1     writeEPS "./out/regular_tree01.eps"  pic1@@ -50,39 +40,44 @@ tree_pic1 :: CtxPicture tree_pic1 = udrawTracing (0::Double) $ do     ---    draw $ plainTextLine "Tree 1:"        `at` (P2 0  530)-    drawScaledTree (uniformSF 30)         (P2 80 530) $ -       runTreeBuild charNode tree1+    draw $ dcTextlabel "Tree 1:"        `at` (P2 0  550)+    drawl (P2 10 500) $ runTreeLoc props1 (const red_dot) tree1     ---    draw $ plainTextLine "Tree 2:"       `at` (P2 160 530) -    drawScaledTree (uniformSF 30)        (P2 240 530) $ -        runTreeBuild (diskNode red) tree2+    draw $ dcTextlabel "Tree 2:"       `at` (P2 200 550) +    drawl (P2 300 550) $ runTreeLoc props2 dotChar tree2 -    draw $ plainTextLine "Tree 3:"       `at` (P2 0  410) +    draw $ dcTextlabel "Tree 3:"       `at` (P2 0  410)      localize (set_font_size 12) $ -        drawScaledFamilyTree (uniformSF 25) (P2 280 410) $ -          runTreeBuild charNode tree3+        drawl (P2 280 410) $ runTreeLoc props3 dotChar tree3      ---    draw $ plainTextLine "Tree 4:"       `at` (P2 0  200)-    drawScaledTree (scaleFactors 20 30)  (P2 80 200) $ -        runTreeBuild (circleNode black) tree4+    draw $ dcTextlabel "Tree 4:"       `at` (P2 0  190)+    drawl (P2 80 190) $ runTreeLoc props4 (const circ_dot) tree4     ---    draw $ plainTextLine "Tree 5:"        `at` zeroPt-    drawScaledTree (scaleFactors 20 30)  (P2 240 0) $-        runTreeBuild (circleNode black)  tree5+    draw $ dcTextlabel "Tree 5:"        `at` zeroPt+    drawl (P2 320 0) $ runTreeLoc props5 (const circ_dot) tree5+  where+    red_dot  = localize (fill_colour red) dotDisk+    circ_dot = localize (stroke_colour black) dotCircle +    props1 = tree_direction TREE_RIGHT $ standardTreeProps 30 30 radialOTMC+    props2 = standardTreeProps 30 40 familyOTMC+    props3 = tree_direction TREE_DOWN $ standardTreeProps 25 30 familyOTMC+    props4 = standardTreeProps 20 30 radialOTMC+    props5 = standardTreeProps 30 36 radialOTMC  -tree1 :: TreeBuild u (TreeSpec Char)-tree1 = regularBuild $ Node 'A' [Node 'B' bs, Node 'F' fs]+tree1 :: Tree Char+tree1 = 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' []]]  -tree2 :: TreeBuild u (TreeSpec Char)-tree2 = regularBuild $ Node 'A' [Node 'B' bs, Node 'F' [], Node 'G' gs]+++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' []]@@ -91,8 +86,10 @@ -- This is the tree from Andrew Kennedy's  -- /Functional Pearl Drawing Trees/ ---tree3 :: TreeBuild u (TreeSpec Char)-tree3 = regularBuild $ Node 'A' [a1, a2, a3]+-- Draw with dotChar.+--+tree3 :: Tree Char+tree3 = Node 'A' [a1, a2, a3]   where     a1 = Node 'B' [b1, b2]     a2 = Node 'S' [b3,b4]@@ -123,8 +120,8 @@ -- This is the tree (a) T3 from Buchheim, Junger and Leipert -- /Improving Walker\'s Algorithm to Run in Linear Time/. -- -tree4 :: TreeBuild u (TreeSpec Int)-tree4 = regularBuild $ Node 1 [a1, a2]+tree4 :: Tree Int+tree4 = Node 1 [a1, a2]   where     a1 = Node  2 [b1]     a2 = Node  3 [b2, b3]@@ -137,6 +134,7 @@     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/. -- @@ -144,8 +142,8 @@ -- spaces the leaves, it looks like the trees in that paper are  -- evenly spaced at the interior nodes too. -- -tree5 :: TreeBuild u (TreeSpec Int)-tree5 = regularBuild $+tree5 :: Tree Int+tree5 =      Node 1 [a1, tleaf 3, tleaf 4, tleaf 5, a2, tleaf 7, tleaf 8, tleaf 9, a3]   where     a1 = Node  2 [ tleaf 11, tleaf 12, tleaf 13, tleaf 14, tleaf 15, tleaf 16

@@ -1,170 +1,49 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Tree--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable -- Portability :  GHC --+-- Note - this module is a kludge whilst I work out a usable API.+--  --------------------------------------------------------------------------------  module Wumpus.Tree   (-  -- * The type of rendered trees--    ScaleFactors-  , uniformSF-  , scaleFactors--  , drawScaledTree-  , TreeDirection(..)-  , drawScaledTreeD--  , drawScaledFamilyTree+  -- * Re-exports+    module Wumpus.Tree.OTMConnectors +  , TreeDirection(..) +  , tree_direction+  , runTreeLoc -  -- * Drawing nodes-  , charNode-  , textNode-  , circleNode-  , diskNode+  -- * Definitions+  , standardTreeProps    )   where  import Wumpus.Tree.Base-import Wumpus.Tree.Design-import Wumpus.Tree.Draw-import Wumpus.Tree.ScalingContext-import Wumpus.Tree.TreeBuildMonad+import Wumpus.Tree.DrawLoc+import Wumpus.Tree.OTMConnectors -import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Drawing.Dots.AnchorDots -import Wumpus.Core                              -- package: wumpus-core -import Data.VectorSpace                         -- package: vector-space   ---- | Customize the size of the printed tree.------ A tree is /designed/ with a height of 1 unit between --- parent and child nodes.------ The y-scaling factor multiplies the unit height, a scaling --- factor of 30 represents 30 /points/.------ In the horizontal, 1 unit is the smallest possible distance --- between child nodes.----type ScaleFactors u = ScalingContext u Int u------- | Build uniform x- and y-scaling factors, i.e. @ x == 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)	------ --drawScaledTree :: (Real u, Floating u, InterpretUnit u, InnerSpace (Vec2 u)) -               => 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, InterpretUnit u, InnerSpace (Vec2 u)) -                => ScaleFactors u -> Point2 u -                -> TreeDirection -> TreeBuildAns u -                -> TreeDrawing u-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, InterpretUnit u, InnerSpace (Vec2 u)) -               => ScaleFactors u -> Point2 u -> TreeBuildAns u -               -> TreeDrawing u-drawScaledFamilyTree scale_f ogin (tree,annos) = -    drawFamilyTree annos $ design ogin scale_f tree------------------------------------------------------------------------------------- Drawing functions---- | Render tree nodes with a single character.------  Useful for rendering @ Data.Tree Char @.----charNode :: (Real u, Floating u, InterpretUnit u) -         => Char -> TreeNode u-charNode = dotChar----- | Tree nodes with a text label.------ Useful for rendering @ Data.Tree String @.------ Note the width of the label is not accounted for in the --- /design/ of the tree. Labels with long texts may overlap.--- Also, only a single line of text is printed - any text after --- the first newline character will be dropped.----textNode :: (Real u, Floating u, InterpretUnit u) -         => String -> TreeNode u-textNode = dotText . uptoNewline-  where-    uptoNewline = takeWhile (/='\n')---- | Tree nodes with a stroked circle.------ Suitable for printing the shape of a tree, ignoring the data.----circleNode :: (Floating u, InterpretUnit u) -           => RGBi -> (a -> TreeNode u)-circleNode rgb = \_ -> localize (stroke_colour rgb) dotCircle----- | Tree nodes with a filled circle.------ Suitable for printing the shape of a tree, ignoring the data.----diskNode :: (Floating u, InterpretUnit u) -         => RGBi -> (a -> TreeNode u)-diskNode rgb = \_ -> localize (fill_colour rgb) dotDisk--+standardTreeProps :: Fractional u +                  => u -> u -> OTMAnchorConn u a -> TreeProps u a+standardTreeProps sx sy otm_conn = +    TreeProps { tp_sibling_distance = sx +              , tp_level_distance   = sy+              , tp_multiconn        = otm_conn         +              , tp_direction        = TREE_DOWN+              }   

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Tree.Base--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -18,52 +18,43 @@ module Wumpus.Tree.Base   ( -    TreeDrawing-  , DTreeDrawing-  , CoordTree-  -  , TreeNode--  , Design(..)+    OTMAnchorConn+  , TreeProps(..)+  , TreePropsF+  , TreeDirection(..)+  , tree_direction+  , getTreeConnector    ) where -import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Drawing.Dots.AnchorDots -import Wumpus.Core                              -- package: wumpus-core -import Data.Tree----- | A rendered tree - alias for for @Picture Double@ in --- Wumpus-Core.----type TreeDrawing u      = TraceDrawing u ()--type DTreeDrawing       = TreeDrawing Double-+import Wumpus.Basic.Kernel                      -- package: wumpus-basic  +type OTMAnchorConn u a = TreeDirection -> u -> a -> [a] -> Graphic u  --- | Tree annotated with positions.----type CoordTree u a = Tree (Point2 u, a)+data TreeProps u a = TreeProps+      { tp_sibling_distance :: u+      , tp_level_distance   :: u+      , tp_multiconn        :: OTMAnchorConn u a+      , tp_direction        :: TreeDirection+      }   +type TreePropsF u a = TreeProps u a -> TreeProps u a +data TreeDirection = TREE_UP | TREE_DOWN | TREE_LEFT | TREE_RIGHT+  deriving (Eq,Ord,Show) --- | 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+tree_direction :: TreeDirection -> TreePropsF u a+tree_direction dir props = props { tp_direction = dir }  -data Design u a = Design -      { tree_design     :: CoordTree u a-      , tree_bbox       :: BoundingBox u-      }-+getTreeConnector :: (DrawingCtxM m, InterpretUnit u)+                 => TreeProps u a -> m (a -> [a] -> Graphic u)+getTreeConnector (TreeProps { tp_level_distance   = lvl+                            , tp_multiconn        = conn+                            , tp_direction        = dir  }) = +    uconvertCtx1 lvl >>= \ulvl -> return (conn dir ulvl) 

@@ -1,10 +1,11 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Tree.Design--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -25,14 +26,22 @@  module Wumpus.Tree.Design   (-    design-  , rotateAboutRoot++  -- * Design a tree+    UW+  , CoordTree+  , design++  -- * Post transform a tree design+  , scaleTree+  , orientateTree+   )   where  import Wumpus.Tree.Base-import Wumpus.Tree.ScalingContext +import Wumpus.Basic.Kernel              -- package: wumpus-basic  import Wumpus.Core                      -- package: wumpus-core @@ -41,53 +50,77 @@ import Data.Tree  +-- | Tree unit width.+-- +-- Trees are designed with 1.0 as the ideal width between nodes.+-- This is represented as a specific newtype so it can be +-- contextually scaled after the design, before the tree is drawn.+--+newtype UW = UW { getUW :: Double }+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) +instance Show UW where+  showsPrec p d = showsPrec p (getUW d) +instance InterpretUnit UW where+  normalize _ = realToFrac+  dinterp   _ = realToFrac+++++-- | Tree annotated with positions.+-- +-- This is the result of 'design'.+--+type CoordTree a = Tree (Point2 UW, a)++ -- | XPos is an absolute position ---type XPos u = u     +type XPos = UW -type XTree u a = Tree (XPos u, a)+type XTree a = Tree (XPos, a)   -- | Delta - difference in X-positions. ---type Delta u = u+type Delta = UW  -- A horizontal span. ---data HSpan u = HSpan !u !u+data HSpan = HSpan !UW !UW   deriving (Eq,Ord,Show)   -outsideMerge :: HSpan u -> HSpan u -> HSpan u+outsideMerge :: HSpan -> HSpan -> HSpan outsideMerge (HSpan p _) (HSpan _ q) = HSpan p q    -moveSpan :: Num u => Delta u -> HSpan u -> HSpan u+moveSpan :: Delta -> HSpan -> HSpan moveSpan d (HSpan p q) = HSpan (p+d) (q+d)  -newtype Extent u = Extent { span_list :: [HSpan u] }+newtype Extent = Extent { span_list :: [HSpan] }   deriving (Eq,Show)  -extlink :: u -> Extent u -> Extent u+extlink :: UW -> Extent -> Extent extlink a (Extent as) = Extent $ (HSpan a a) :as   -- note is this just for left ... ? ---midtop :: Fractional u => u -> Extent u -> XPos u+midtop :: UW -> Extent -> XPos midtop r (Extent [])        = r midtop _ (Extent (HSpan p q:_)) = p + (0.5*(q-p))   -- merge \"moving right\"... ---mergeMR :: Num u => Delta u -> Extent u -> Extent u -> Extent u+mergeMR :: Delta -> Extent -> Extent -> Extent mergeMR dx (Extent xs) (Extent ys) = Extent $ step xs ys   where     step ps     []     = ps@@ -96,7 +129,7 @@  -- dx is negative... ---mergeML :: Num u => Delta u -> Extent u -> Extent u -> Extent u+mergeML :: Delta-> Extent -> Extent -> Extent mergeML dx (Extent xs) (Extent ys) = Extent $ step xs ys   where     step ps     []     = map (moveSpan dx) ps@@ -105,24 +138,23 @@   -extentZero :: Extent u+extentZero :: Extent extentZero = Extent [] -extentOne :: XPos u -> Extent u+extentOne :: XPos -> Extent extentOne x = Extent [HSpan x x]   -- 'moveTree' is now recursive... ---moveTree :: Num u => Delta u -> XTree u a -> XTree u a+moveTree :: Delta -> XTree a -> XTree a moveTree dx (Node (x,a) subtrees) = Node ((x+dx),a) subtrees'   where     subtrees' = map (moveTree dx) subtrees   -fit :: (Fractional u, Ord u) -    => Extent u -> Extent u -> u+fit :: Extent -> Extent -> UW fit a b = go (span_list a) (span_list b) 0.0    where     go (HSpan _ p:ps) (HSpan q _:qs) acc = go ps qs (max acc (p - q + 1.0))@@ -132,8 +164,7 @@ -- Fitting the children of a node...  -fitleft :: (Fractional u, Ord u) -        => [(XTree u a,Extent u)] -> ([XTree u a], Extent u)+fitleft :: [(XTree a,Extent)] -> ([XTree a], Extent) fitleft []           = ([],extentZero) fitleft ((l,ext):xs) = (l:ts,ext') -- left-most child unchanged    where @@ -142,8 +173,7 @@      step aex (t,ex)  = let dx = fit aex ex                          in (mergeMR dx aex ex, moveTree dx t) -fitright :: (Fractional u, Ord u) -         => [(XTree u a, Extent u)] -> ([XTree u a], Extent u)+fitright :: [(XTree a, Extent)] -> ([XTree a], Extent) fitright = post . foldr fn Nothing   where     post                        = fromMaybe ([],extentZero)@@ -156,35 +186,38 @@   --- Note - this will tell how wide the tree is...--- though the last exten is not necessarily the widest. -designl :: forall a u. (Fractional u, Ord u) -        => Tree a -> (XTree u a, Extent u)+-- | Design the tree from the left.+-- +-- Left and right tree designs are merged.+--+designl :: forall a. Tree a -> (XTree a, Extent) designl (Node a [])   = (Node (0.0,a)  [],    extentOne 0.0) designl (Node a kids) = (Node (xpos,a) kids', ext1)   where-    xs              :: [(XTree u a, Extent u)]+    xs              :: [(XTree a, Extent)]     xs              = map designl kids -    kids'           :: [XTree u a]-    ext0, ext1      :: Extent u+    kids'           :: [XTree a]+    ext0, ext1      :: Extent     (kids',ext0)    = fitleft xs      xpos            = midtop 0.0 ext0     ext1            = xpos `extlink` ext0 --designr :: forall u a. (Fractional u, Ord u) -        => XPos u -> Tree a -> (XTree u a, Extent u)+-- | Design the tree from the right.+-- +-- Right and left tree designs are merged.+--+designr :: forall a. XPos -> Tree a -> (XTree a, Extent) designr r (Node a [])   = (Node (r,a)  [],    extentOne r) designr r (Node a kids) = (Node (xpos,a) kids', ext1)   where-    xs              :: [(XTree u a, Extent u)]+    xs              :: [(XTree a, Extent)]     xs              = map (designr r) kids -    kids'           :: [XTree u a]-    ext0, ext1      :: Extent u+    kids'           :: [XTree a]+    ext0, ext1      :: Extent     (kids',ext0)    = fitright xs      xpos            = midtop r ext0@@ -199,9 +232,8 @@ -- 1.0 separating nodes it is rescaled as a post-processing step -- into drawable coordinates.  ---design :: (Fractional u, Ord u)-       => Point2 u -> ScalingContext u Int u -> Tree a -> CoordTree u a-design ro sctx t = rootOrientate ro $ scaleDesign sctx 0 t3+design :: Tree a -> CoordTree a+design t = rootOrientate zeroPt $ decorateYPosns 0 t3   where     (t1,ext)                    = designl t     (_, HSpan xmin xmax)        = stats ext@@ -213,41 +245,28 @@     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.+-- Originally the tree has no y-positions, recurse through the +-- tree adding them... ---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'+decorateYPosns :: UW -> Tree (XPos, a) -> CoordTree a+decorateYPosns lvl (Node (xpos,a) kids) = Node (pt,a) kids'   where-    pt    = scalePt ctx xpos lvl-    kids' = map (scaleDesign ctx (lvl-1)) kids+    pt    = P2 xpos lvl+    kids' = map (decorateYPosns (lvl-1)) kids            -rootOrientate :: Num u => Point2 u -> CoordTree u a -> CoordTree u a+rootOrientate :: Point2 UW -> CoordTree a -> CoordTree 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' --- Updating this to the latest Wumpus-Basic would make the --- function a query...----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, HSpan u)+stats :: Extent -> (Int, HSpan) stats (Extent [])     = (0,HSpan 0 0) stats (Extent (e:es)) = foldr fn (1,e) es   where@@ -257,7 +276,7 @@ mean x y = (x+y) / 2.0  -minmaxMerge :: Ord u => HSpan u -> HSpan u -> HSpan u+minmaxMerge :: HSpan -> HSpan -> HSpan minmaxMerge (HSpan p q) (HSpan p' q') = HSpan (min p p') (max q q')  @@ -266,6 +285,53 @@   where     step (p:ps) (q:qs) = treeZipWith f p q : step ps qs     step _      _      = [] ++++++--------------------------------------------------------------------------------+-- Post design transformations...+++-- | 'scaleTree' : @ sibling_distance * level_distance * CoordTree -> Tree @+--+-- Scale a CoordTree - this forms a tree where the node label+-- is a pair of @Point2 u@ and an @a@ (usually a LocImage).+-- +scaleTree :: (DrawingCtxM m, InterpretUnit u)+          => u -> u -> CoordTree a -> m (Tree (Point2 u, a))+scaleTree sib_dist lvl_dist tree = +    getFontSize >>= \sz -> +    let fn = mkFun sz in return $ fmap (bimapL fn) tree+  where+    mkFun sz = \(P2 x y) -> let ux = sib_dist * (dinterp sz $ realToFrac x)+                                uy = lvl_dist * (dinterp sz $ realToFrac y)+                            in P2 ux uy+++++-- | Orientate the Tree according to it\'s drawing direction.+-- +-- This is a rotation about the root node.+--+orientateTree :: (Real u, Floating u)+              => TreeDirection -> Tree (Point2 u, a) -> Tree (Point2 u, a)+orientateTree TREE_DOWN  tree = tree+orientateTree TREE_UP    tree = rotateAboutRoot pi tree+orientateTree TREE_LEFT  tree = rotateAboutRoot (1.5*pi) tree+orientateTree TREE_RIGHT tree = rotateAboutRoot (0.5*pi) tree+++rotateAboutRoot :: (Real u, Floating u)+                => Radian -> Tree (Point2 u, a) -> Tree (Point2 u, a)+rotateAboutRoot ang (Node (ogin,val) kids) =+    Node (ogin, val) $ map step kids+  where+    step (Node (v0, a) ks) = Node (rotA v0, a) $ map step ks++    rotA                   = rotateAbout ang ogin   

@@ -1,152 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Tree.Draw--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Drawing the tree using Wumpus-Basic.--------------------------------------------------------------------------------------module Wumpus.Tree.Draw -  (-    drawTree-  , drawFamilyTree--  ) where--import Wumpus.Tree.Base-import Wumpus.Tree.TreeBuildMonad--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Drawing.Dots.AnchorDots--import Wumpus.Core                              -- package: wumpus-core---import Control.Monad-import qualified Data.IntMap as IntMap-import Data.Tree hiding ( drawTree )-----drawTree :: (Real u, Floating u, InterpretUnit u) -          => NodeAnnoRefs u -> CoordTree u (TreeNodeAns u) -> TreeDrawing u-drawTree annos tree = drawStep annos radialConns tree >> return ()----drawFamilyTree :: (Real u, Floating u, InterpretUnit u) -          => NodeAnnoRefs u -> CoordTree u (TreeNodeAns u) -> TreeDrawing u-drawFamilyTree annos tree = drawStep annos familyConn tree >> return ()---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, InterpretUnit 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, InterpretUnit u-             , CenterAnchor a, RadialAnchor a-             , u ~ DUnit a )  -          => a -> a -> Graphic u-connector a0 a1 = vertexPP [pt0,pt1] >>= openStroke-  where-    (ang0,ang1) = anchorAngles (center a0) (center a1)-    pt0         = radialAnchor ang0 a0-    pt1         = radialAnchor ang1 a1-    -----anchorAngles :: (Real u, Floating u) -             => Point2 u -> Point2 u -> (Radian,Radian)-anchorAngles f t = (theta0, theta1)-  where-    conn_v  = pvec f t-    theta0  = vdirection conn_v-    theta1  = if theta0 < pi then theta0 + pi else theta0 - pi-    ----------------------------------------------------------------------------------------- --familyConn :: ( Real u, Fractional u, InterpretUnit 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, InterpretUnit u) -        => Point2 u -> [Point2 u] -> Graphic u-famconn _       []         = error "famconn - empty list"-famconn pt_from [p1]       = famconn1 pt_from p1-famconn pt_from xs@(p1:_)  = oconcat downtick (horizontal : upticks)-   where-     hh         = halfHeight pt_from p1-     downtick   = locStraightLine (vvec (-hh)) `at` pt_from-     horizontal = midline (displaceV (-hh) pt_from) xs -     upticks    = map (locStraightLine (vvec hh) `at`) xs--midline :: (Fractional u, Ord u, InterpretUnit u) -        => Point2 u -> [Point2 u] -> Graphic u-midline _        []           = error "midline - empty list" -midline (P2 _ y) (P2 x0 _:zs) = -    let (a,b) = foldr fn (x0,x0) zs in straightLine (P2 a y) (P2 b y)-  where   -    fn (P2 x _) (lo,hi) | x < lo    = (x,hi)-                        | x > hi    = (lo,x)-                        | otherwise = (lo,hi)--halfHeight :: Fractional u => Point2 u -> Point2 u -> u-halfHeight (P2 _ ya) (P2 _ yb) = 0.5 * (abs $ ya - yb)- --- special case - should always be a vertical, but...----famconn1 :: (Fractional u, InterpretUnit u)-         => Point2 u -> Point2 u -> Graphic u-famconn1 a@(P2 xa _) b@(P2 xb _) -    | xa == xb  = straightLine a b-    | otherwise = vertexPP [a,m1,m2,b] >>= openStroke-  where-    hh = halfHeight a b-    m1 = displaceV (-hh)     a  -    m2 = displaceH (xb - xa) m1

@@ -0,0 +1,112 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Tree.DrawLoc+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Drawing a Tree as a LocGraphic.+--+--------------------------------------------------------------------------------++module Wumpus.Tree.DrawLoc+  (+    +    runTreeLoc++  ) where++import Wumpus.Tree.Base+import Wumpus.Tree.Design+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.Tree hiding ( drawTree )+++--+-- DESIGN NOTE +--+-- Only simplistic trees can be drawn as LocGraphics.+--+-- Technically, this is because LocImages only support +-- /production/ of /answers/ and not their /introspection/, so+-- we cannot query anchors directly[*] during construction. Thus +-- we can\'t have /graph-links/ which need /located/ anchors.+--+-- [*] Though we can use @dblelaborate@ for a special case.+--+++-- | Build a LocGraphic from a @Data.Tree@.+--+-- Nodes support custom drawing as the value of the /label/ at +-- each node is interpreted (naturally, all node drawings must +-- be of the same type). +--+runTreeLoc :: (Real u, Floating u, InterpretUnit u) +           => TreeProps u a -> (elt -> LocImage u a) -> Tree elt +           -> LocGraphic u+runTreeLoc props drawF tree = promoteLoc $ \pt ->+    let tree1 = fmap drawF tree+    in zapQuery (runDesign props tree1) >>= \ans -> +       ignoreAns (drawStep props ans `at` pt)++++drawStep :: (Real u, Floating u, InterpretUnit u) +         => TreeProps u a -> Tree (LocImage u a) -> LocImage u a+drawStep props (Node gf ns) =+    getTreeConnector props >>= \conn ->+    let imgs = sequence $ map (drawStep props) ns+    in dblelaborate gf imgs conn+      ++-- | This is not really a generally function - the types are not+-- complementary and it returns only the first answer but consumes +-- the second, so it doesn\'t belong in Wumpus-Basic. +-- +-- However, it is a problematic that it needs to +-- deconstruct the Ans directly - this suggests there is a need +-- for a more general version of this combinator in Wumpus-Basic.+-- +dblelaborate :: LocImage u a -> LocImage u b +             -> (a -> b -> Graphic u) +             -> LocImage u a+dblelaborate ma mb fn = promoteLoc $ \pt -> +    both (ma `at` pt) (mb `at` pt) >>= \(a,b) -> fn a b >> return a++designOrientateScale :: (Real u, Floating u, InterpretUnit u)+                     => TreeProps u a  -> Tree (LocImage u a) +                     -> Query u (Tree (Point2 u, LocImage u a))+designOrientateScale props tree =  +    scaleTree sx sy (design tree) >>= \ans -> return $ orientateTree dir ans+  where+    dir = tp_direction props+    sx  = tp_sibling_distance props+    sy  = tp_level_distance props++++-- | Transform a tree where each node is a LocImage into a tree+-- where each LocImage is displaced by the necessary coordinate+-- so it can be drawn.+--+runDesign :: (Real u, Floating u, InterpretUnit u)+          => TreeProps u a  -> Tree (LocImage u a) +          -> Query u (Tree (LocImage u a))+runDesign props tree =  +    designOrientateScale props tree >>= \tree2 -> +    return $ fmap fn tree2+  where+    fn ((P2 x y), gf) = moveStart (vec x y) gf++

@@ -0,0 +1,173 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Tree.Draw+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- One-to-many connectors.+--+--------------------------------------------------------------------------------++module Wumpus.Tree.OTMConnectors+  (++    radialOTMC+  , blankOTMC+  , familyOTMC+  , splayOTMC++  ) where++import Wumpus.Tree.Base++import Wumpus.Drawing.Paths.Absolute            -- package: wumpus-drawing++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Data.Monoid++++++-- Pulling out the points (nodes) from parent plus list of +-- children.+++radialNodes :: ( Real u, Floating u, InterpretUnit u+               , CenterAnchor a, RadialAnchor a+               , u ~ DUnit a )  +            => a -> [a] -> [(Point2 u, Point2 u)]+radialNodes a as = map fn as+  where+    actr = center a+    fn x = (radialAnchor ang0 a , radialAnchor ang1 x) +             where (ang0, ang1) = anchorAngles actr (center x)+        ++anchorAngles :: (Real u, Floating u) +             => Point2 u -> Point2 u -> (Radian,Radian)+anchorAngles f t = (theta0, theta1)+  where+    conn_v  = pvec f t+    theta0  = vdirection conn_v+    theta1  = if theta0 < pi then theta0 + pi else theta0 - pi+++-- +-- @radialConn@ cannot be represented as a connector from+-- one-point-to-many-points as the initial points all start from+-- slightly different places. +--+++-- | 'radialOTMC' has no need for the TreeDirection or height step.+-- +radialOTMC :: ( Real u, Floating u, InterpretUnit u+              , CenterAnchor a, RadialAnchor a +              , u ~ DUnit a) +           => OTMAnchorConn u a+radialOTMC _ _ a xs = mconcat $ map fn $ radialNodes a xs+  where+    fn (p0,p1) = zapQuery (vertexPP [p0,p1]) >>= dcOpenPath++-- | Blank connector - nothing is drawn.+--+blankOTMC :: ( Real u, Floating u, InterpretUnit u+            , CenterAnchor a+            , u ~ DUnit a) +         => OTMAnchorConn u a+blankOTMC _ _ a _ = emptyLocImage `at` center a+++--------------------------------------------------------------------------------+-- ++-- Note - can the \"crossbar\" of a famillyConn cannot be +-- calcuated parent-to-arbitrary-child?+-- +-- Probably we need to know half the height step, rather than +-- calculate it from anchors.+--++-- Drawing a fmaily connector is quite horrible...++++familyOTMC :: ( Real u, Floating u, Ord u, Tolerance u, InterpretUnit u+              , CenterAnchor a, CardinalAnchor a +              , u ~ DUnit a ) +           => OTMAnchorConn u a+familyOTMC _   _ _ [] = mempty+familyOTMC dir h a xs = +    let hh        = 0.5 * h+        (paF,caF) = famAnchors dir+        ptick     = outtick hh (center a) (paF a)+        cticks    = map (\o -> outtick hh (center o) (caF o)) xs+        kids      = sequence cticks+    in ignoreAns ptick `mappend` (ignoreAns $ elaborate kids fn)+  where+    fn ps = case linkAll ps of+              Nothing -> emptyLocImage `at` (center a)+              Just path -> zapQuery (toPrimPath path) >>= dcOpenPath++++famAnchors :: (CardinalAnchor a, u ~ DUnit a ) +             => TreeDirection -> (a -> Anchor u, a -> Anchor u)+famAnchors TREE_UP    = (north, south)+famAnchors TREE_DOWN  = (south, north)+famAnchors TREE_LEFT  = (west,  east)+famAnchors TREE_RIGHT = (east,  west)++++outtick :: (Real u, Floating u, InterpretUnit u) +        => u -> Point2 u -> Point2 u -> Image u (Point2 u)+outtick ll p0 p1 = +    let v0  = pvec p0 p1+        ang = vdirection v0+        v1  = avec ang ll+        p2  = p0 .+^ v1+    in replaceAns p2 (straightLine p1 p2)++-- | The input list is expected to be ordered...+--+linkAll :: (Real u, Floating u, Ord u, Tolerance u) +        => [Point2 u] -> Maybe (AbsPath u)+linkAll [] = Nothing+linkAll xs = Just $ optimizeLines $ vertexPath xs++++++splayOTMC :: ( Real u, Floating u, Ord u, Tolerance u, InterpretUnit u+              , CenterAnchor a, CardinalAnchor a +              , u ~ DUnit a ) +           => OTMAnchorConn u a+splayOTMC _   _ _ [] = mempty+splayOTMC dir _ a xs = +    let (paF,caF) = famAnchors dir+        p0        = paF a+    in mconcat $ map (\x -> fn p0 (caF x)) xs+  where+    fn p0 p1 = zapQuery (vertexPP [p0,p1]) >>= dcOpenPath++++--------------------------------------------------------------------------------++

@@ -1,103 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Tree.ScalingContext--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Scaling in X and Y------ \*\* WARNING \*\* - to be removed at some point.--- -----------------------------------------------------------------------------------module Wumpus.Tree.ScalingContext-  (--    ScalingContext(..)--  , scaleX-  , scaleY-  , scalePt-  , scaleVec--  , unitX-  , unitY--  , uniformScaling-  , coordinateScaling--  ) where---import Wumpus.Core				-- package: wumpus-core------ | ScalingContext is a dictionary of two functions for scaling --- in X and Y.----data ScalingContext ux uy u = ScalingContext-      { scale_in_x  :: ux -> u-      , scale_in_y  :: uy -> u-      }---scaleX              :: ScalingContext ux uy u -> ux -> u-scaleX ctx ux       = (scale_in_x ctx) ux--scaleY              :: ScalingContext ux uy u -> uy -> u-scaleY ctx uy       = (scale_in_y ctx) uy---scalePt             :: ScalingContext ux uy u -> ux -> uy -> Point2 u-scalePt ctx ux uy   = P2 (scale_in_x ctx ux) (scale_in_y ctx uy)--scaleVec            :: ScalingContext ux uy u -> ux -> uy -> Vec2 u-scaleVec ctx ux uy  = V2 (scale_in_x ctx ux) (scale_in_y ctx uy)---unitX               :: Num ux => ScalingContext ux uy u -> u-unitX ctx           = scaleX ctx 1- -unitY               :: Num uy => ScalingContext ux uy u -> u-unitY ctx           = scaleY ctx 1---------------------------------------------------------------------------------------- constructors for scaling context----- | Build a ScalingContext where both X and Y are scaled by the --- same uniform step.------ The dimensions (types) of the ScalingContext are unified - the --- output type and the input types are all the same.----uniformScaling :: Num u => u -> ScalingContext u u u-uniformScaling u = ScalingContext-      { scale_in_x  = (\x -> u*x)-      , scale_in_y  = (\y -> u*y)-      }------ | Build a ScalingContext for scaling Int coordinates.------ The scaling factors in X and Y can be different sizes.-----coordinateScaling :: Num u => u -> u -> ScalingContext Int Int u-coordinateScaling sx sy = ScalingContext-      { scale_in_x  = (\x -> sx * fromIntegral x)-      , scale_in_y  = (\y -> sy * fromIntegral y)-      }---

@@ -1,213 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Tree.TreeBuildMonad--- Copyright   :  (c) Stephen Tetley 2010-2011--- 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--  , branch-  , zbranch-  , leaf-  , zleaf--  ) where--import Wumpus.Tree.Base--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Drawing.Dots.AnchorDots---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-      }---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 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, InterpretUnit 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, InterpretUnit 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'.------ Also this function is not so useful now Wumpus-Basic has--- the @decorate@, @sdecorate@, and @adecorate@ functions.--- -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) []---            --

@@ -0,0 +1,316 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Tree.TreeBuilder+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Monadic building - trees with references for indirect +-- node-to-node connections and decoration+--+--------------------------------------------------------------------------------++module Wumpus.Tree.TreeBuilder+  (+    AbsTreeSpec+  , TreeSpec+  , TbNode++  , ref +  , leaf+  , root+  , mkleaf+  , linkref    ++  , drawTreeSpec++  ) where++import Wumpus.Tree.Base+import Wumpus.Tree.Design++import Wumpus.Drawing.Basis.TraceGraphic        -- package: wumpus-drawing++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Utils.HList++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import qualified Data.IntMap as IM+import Data.Monoid+import Data.Tree++-- TODO - are you sure this needs to build a Graphic rather than +-- a LocGraphic?+++data TbNode u a = RefNode Int (LocImage u a)+                | PlainNode (LocImage u a)++type instance DUnit (TbNode u a) = u++++type RefTree u a = Tree (TbNode u a)++type CoordRefTree u a = Tree (Point2 u, TbNode u a)++++type LinkDraw u node  = (node -> node -> Graphic u)+++-- | This allows special connectors or edge labels.+--+type LinkRef u node = (Int,Int, LinkDraw u node)+++newtype TreeSpec node u a = TreeSpec { +          getTreeSpec :: Int -> (a, Int, H (LinkRef u node)) }++type instance MonUnit (TreeSpec node u a) = u+++type AbsTreeSpec u node = TreeSpec node u (RefTree u node)+++-- Functor++instance Functor (TreeSpec node u) where+  fmap f ma = TreeSpec $ \s0 -> let (a,s1,w1) = getTreeSpec ma s0 +                                in (f a, s1, w1)+++-- Applicative++instance Applicative (TreeSpec node u) where+  pure a    = TreeSpec $ \s0  -> (a, s0, mempty)+  mf <*> ma = TreeSpec $ \s0 -> +                let (f,s1,w1) = getTreeSpec mf s0+                    (a,s2,w2) = getTreeSpec ma s1+                in (f a, s2, w1 `mappend` w2)+++-- Monad++instance Monad (TreeSpec node u) where+  return a = TreeSpec $ \s0 -> (a, s0, mempty)+  ma >>= k = TreeSpec $ \s0 -> let (a,s1,w1) = getTreeSpec ma s0+                                   (b,s2,w2) = (getTreeSpec . k) a s1+                               in (b,s2, w1 `mappend` w2)+++runTreeSpec :: AbsTreeSpec u node -> (RefTree u node, [LinkRef u node])+runTreeSpec ma = let (a,_,w1) = getTreeSpec ma 0 +                 in (a, toListH w1)+++ref :: LocImage u node -> TreeSpec node u (TbNode u node)+ref img = TreeSpec $ \s0 -> (RefNode s0 img, s0+1, mempty)++leaf :: TbNode u node -> RefTree u node +leaf nod = Node nod []++root :: TbNode u node -> [RefTree u node ] -> RefTree u node +root n1 xs = Node n1 xs++mkleaf :: LocImage u node -> RefTree u node+mkleaf img = Node (PlainNode img) []+++linkref :: TbNode u node -> TbNode u node -> LinkDraw u node -> TreeSpec node u ()+linkref (RefNode ix _) (RefNode jx _) fn = TreeSpec $ \s0 -> +   ((), s0, wrapH $ (ix,jx, fn))++linkref _              _              _  = TreeSpec $ \s0 -> ((), s0, mempty)++++-------------------------------------------------------------+-- +++++-- | Map for indexed objects that support taking anchors.+--+type ObjectMap node = IM.IntMap node++++drawTreeSpec :: ( Real u, Floating u, InterpretUnit u+                , DrawingCtxM m, TraceM m, u ~ MonUnit (m ())+                )+             => TreeProps u node -> Point2 u +             -> AbsTreeSpec u node+             -> m ()+drawTreeSpec props rootpt ma = +    let (rtree,links) = runTreeSpec ma+    in  makeCoordRefTree props rootpt rtree >>= \ctree -> +        askDC >>= \ctx ->+        let prim = rawBuildPrim ctx props ctree links+        in trace prim ++makeCoordRefTree :: ( Real u, Floating u, InterpretUnit u+                    , DrawingCtxM m, u ~ MonUnit (m ())+                    )+                 => TreeProps u a -> Point2 u -> RefTree u a +                 -> m (CoordRefTree u a)+makeCoordRefTree props (P2 x y) tree = +    scaleTree sx sy (design tree) >>= \ans -> return $ moveTree $ orient ans+  where+    orient   = orientateTree (tp_direction props)+    moveTree = fmap (bimapL (displace $ V2 x y))+    sx       = tp_sibling_distance props+    sy       = tp_level_distance props+++-- Whoa - have to be very careful about producing something that +-- is consistent with the DrawingContext.+-- +-- If we fork the DrawingContext we don\'t want to produce a +-- Graphic as a Graphic should be able to be (re-)drawn various +-- times in updated Contexts and reflect the changes each time.+--+-- Need a custom draw function... ++++rawBuildPrim :: InterpretUnit u +             => DrawingContext -> TreeProps u node +             -> CoordRefTree u node+             -> [LinkRef u node]+             -> HPrim u+rawBuildPrim ctx props tree links = +    let (_,w1,o) = runBuilder ctx props (node1 tree) +        w2       = foldr (fn o) mempty links+    in w1 `mappend` w2+  where+    fn imap (i,j,drawF) acc = case (IM.lookup i imap, IM.lookup j imap) of+        (Just a, Just b) -> let (PrimW o _) = runImage ctx (drawF a b)+                            in singleH o `mappend` acc+        _                -> acc+++node1 :: InterpretUnit u+      => CoordRefTree u node -> Builder node u node+node1 (Node (pt, RefNode ix gf) kids) = +    let img = applyLoc gf pt+    in do { a <- tellImage img+          ; addNodeRef ix a+          ; as <- mapM node1 kids+          ; conn <- currentConnector+          ; tellImage_ (conn a as)+          ; return a+          }++node1 (Node (pt, PlainNode gf) kids) = +    let img = applyLoc gf pt+    in do { a <- tellImage img+          ; as <- mapM node1 kids+          ; conn <- currentConnector+          ; tellImage_ (conn a as)+          ; return a+          }+++--------------------------------------------------------------------------------+-- Here a dependency on MTL would be useful...++newtype MonBase node u a = MonBase { +    getMonBase :: TreeProps u node -> ObjectMap node -> (a, ObjectMap node) }++newtype Builder node u a = Builder { +    getBuilder :: TraceGraphicT u (MonBase node u) a } ++type instance MonUnit (MonBase node u a) = u+type instance MonUnit (Builder node u a) = u+++-- Functor++instance Functor (MonBase node u) where+  fmap f ma = MonBase $ \env s0 -> let (a,s1) = getMonBase ma env s0 +                                   in (f a, s1)++instance Functor (Builder node u) where+  fmap f = Builder . fmap f . getBuilder +++-- Applicative++instance Applicative (MonBase node u) where+  pure a    = MonBase $ \_   s0  -> (a, s0)+  mf <*> ma = MonBase $ \env s0 -> +                let (f,s1) = getMonBase mf env s0+                    (a,s2) = getMonBase ma env s1+                in (f a, s2)++instance Applicative (Builder node u) where+  pure a    = Builder $ pure a+  mf <*> ma = Builder $ getBuilder mf <*> getBuilder ma +++-- Monad++instance Monad (MonBase node u) where+  return a = MonBase $ \_   s0 -> (a, s0)+  ma >>= k = MonBase $ \env s0 -> let (a,s1) = getMonBase ma env s0+                                   in (getMonBase . k) a env s1+++instance Monad (Builder node u) where+  return a = Builder $ return a+  ma >>= f = Builder $ getBuilder ma >>= getBuilder . f+++-- TraceGraphicM++instance TraceGraphicM (Builder node u) where+  tellImage img = Builder $ tellImage img+++-- DrawingCtxM++instance DrawingCtxM (Builder node u) where+  askDC           = Builder $ askDC+  asksDC f        = Builder $ asksDC f+  localize upd ma = Builder $ localize upd (getBuilder ma)++++liftBSt :: MonBase node u a -> Builder node u a+liftBSt ma = Builder $ liftTraceGraphicT ma++addNodeRef :: Int -> node -> Builder node u ()+addNodeRef i a = liftBSt inside+  where+    inside = MonBase $ \_ s0 -> ((), IM.insert i a s0)+++currentConnector :: InterpretUnit u +                 => Builder node u (node -> [node] -> Graphic u)+currentConnector = liftBSt inside >>= getTreeConnector+  where+    inside = MonBase $ \env s0 -> (env,s0)+++runMonBase :: TreeProps u node -> MonBase node u a -> (a, ObjectMap node)+runMonBase props ma = getMonBase ma props mempty+++runBuilder :: DrawingContext +           -> TreeProps u node +           -> (Builder node u a) +           -> (a, HPrim u, ObjectMap node)+runBuilder ctx props ma = +    let ((a,wp),s) = runMonBase props (runTraceGraphicT ctx (getBuilder ma)) in (a,wp,s)+

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

@@ -1,5 +1,5 @@ name:             wumpus-tree-version:          0.15.0+version:          0.16.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -32,48 +32,15 @@   .   Changelog:   .-  v0.14.0 to v0.15.0-  .-  * Updated to work with latest Wumpus libraries. -    @ScalingContext@ has been temporarily added from Wumpus-Basic -    (it was considered obsolete there). At some point the -    functionality needs re-implementing so it can be removed from -    Tree.-  .  -  v0.13.0 to v0.14.0:-  .-  * Updated to work with latest Wumpus libraries. -  .-  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.15.0 to v0.16.0:   .+  * Re-worked so tree drawings form a @LocGraphic@ rather than a +    @TraceDrawing@, this makes more in line with other graphic +    objects in Wumpus like shapes.   .-  v0.11.1 to v0.12.0:+  * Changed node type to be any @LocImage@ where the answer +    supports anchors.   .-  * Internal changes to track updates to Wumpus-Basic.   .    . build-type:         Simple@@ -90,18 +57,18 @@   build-depends:      base              <  5,                        containers        >= 0.3.0     && <= 0.6.0,                       vector-space      >= 0.6       && <  1.0,-                      wumpus-core       >= 0.50.0    && <  0.51.0,-                      wumpus-basic      == 0.17.0,-                      wumpus-drawing    == 0.3.0+                      wumpus-core       >= 0.51.0    && <  0.52.0,+                      wumpus-basic      == 0.18.0,+                      wumpus-drawing    == 0.4.0       exposed-modules:     Wumpus.Tree,     Wumpus.Tree.Base,     Wumpus.Tree.Design,-    Wumpus.Tree.Draw,-    Wumpus.Tree.ScalingContext,-    Wumpus.Tree.TreeBuildMonad,+    Wumpus.Tree.DrawLoc,+    Wumpus.Tree.OTMConnectors,+    Wumpus.Tree.TreeBuilder,     Wumpus.Tree.VersionNumber    other-modules: