wumpus-tree 0.7.0 → 0.8.0

raw patch · 6 files changed

+122/−50 lines, 6 filesdep ~wumpus-basicdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic, wumpus-core

API changes (from Hackage documentation)

Files

• demo/Demo01.hs +16/−19
• src/Wumpus/Tree.hs +25/−16
• src/Wumpus/Tree/Design.hs +7/−8
• src/Wumpus/Tree/Draw.hs +60/−2
• src/Wumpus/Tree/VersionNumber.hs +2/−2
• wumpus-tree.cabal +12/−3

@@ -10,23 +10,19 @@ import Data.Tree hiding ( drawTree ) import System.Directory ----- main :: IO ()-main = createDirectoryIfMissing True "./out/"-    >> writeEPS_TreePicture "./out/tree01.eps"  pic1-    >> writeSVG_TreePicture "./out/tree01.svg"  pic1-    >> writeEPS_TreePicture "./out/tree02.eps"  pic2-    >> writeSVG_TreePicture "./out/tree02.svg"  pic2-    >> writeEPS_TreePicture "./out/tree03.eps"  pic3-    >> writeSVG_TreePicture "./out/tree03.svg"  pic3-    >> writeEPS_TreePicture "./out/tree04.eps"  pic4-    >> writeSVG_TreePicture "./out/tree04.svg"  pic4-    >> writeEPS_TreePicture "./out/tree05.eps"  pic5-    >> writeSVG_TreePicture "./out/tree05.svg"  pic5+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_TreePicture "./out/tree01.eps"  pic1+    writeSVG_TreePicture "./out/tree01.svg"  pic1+    writeEPS_TreePicture "./out/tree02.eps"  pic2+    writeSVG_TreePicture "./out/tree02.svg"  pic2+    writeEPS_TreePicture "./out/tree03.eps"  pic3+    writeSVG_TreePicture "./out/tree03.svg"  pic3+    writeEPS_TreePicture "./out/tree04.eps"  pic4+    writeSVG_TreePicture "./out/tree04.svg"  pic4+    writeEPS_TreePicture "./out/tree05.eps"  pic5+    writeSVG_TreePicture "./out/tree05.svg"  pic5   pic1 :: TreePicture@@ -35,18 +31,19 @@ pic2 :: TreePicture pic2 = drawTreePicture (diskNode red) (standardContext 24) (uniformScaling 30) tree2 +-- This should be drawn in the /family tree/ style... pic3 :: TreePicture-pic3 = drawTreePicture charNode (standardContext 14) (uniformScaling 30) tree3+pic3 = drawFamilyTreePicture charNode (standardContext 14) (uniformScaling 30) tree3  pic4 :: TreePicture pic4 = drawTreePicture (circleNode black)                         (standardContext 24) -                       (ScaleFactors 20 30) +                       (scaleFactors 20 30)                         tree4 pic5 :: TreePicture pic5 = drawTreePicture (circleNode black)                         (standardContext 24) -                       (ScaleFactors 20 30) +                       (scaleFactors 20 30)                         tree5  

@@ -23,10 +23,12 @@   , standardContext                     -- re-export  -  , ScaleFactors(..)+  , ScaleFactors   , uniformScaling+  , scaleFactors    , drawTreePicture+  , drawFamilyTreePicture    -- * Output to file   , writeEPS_TreePicture@@ -74,17 +76,22 @@ -- In the horizontal, 1 unit is the smallest possible distance  -- between child nodes. ---data ScaleFactors = ScaleFactors-      { dx_scale :: Double-      , dy_scale :: Double -      }-  deriving (Eq,Show)+type ScaleFactors = ScalingContext Double Int Double +++ -- | Build uniform x- and y-scaling factors, i.e. @ x == y @. -- uniformScaling :: Double -> ScaleFactors-uniformScaling u = ScaleFactors u u +uniformScaling u = ScalingContext (\x -> u * x)+                                  (\y -> u * fromIntegral y)  +scaleFactors :: Double -> Double -> ScaleFactors+scaleFactors sx sy = ScalingContext (\x -> sx * x)+                                    (\y -> sy * fromIntegral y)	++ -- | 'drawTreePicture' : @ draw_fun * attr * scale_factors * tree -> TreePicture @ -- -- The rendering function.@@ -106,17 +113,19 @@                 -> ScaleFactors                  -> Tree a                  -> TreePicture-drawTreePicture drawF ctx sfactors tree = -    liftToPictureU $ drawTree drawF ctx $ design funs tree-  where-    funs = scalingFunctions sfactors+drawTreePicture drawF dctx sfactors tree = +    liftToPictureU $ drawTree drawF dctx $ design sfactors tree  -scalingFunctions :: ScaleFactors -> (Double -> Double, Int -> Double)-scalingFunctions (ScaleFactors sx sy) = (fx,fy)-  where-    fx d = sx * d-    fy d = sy * fromIntegral d+++drawFamilyTreePicture :: (a -> TreeNode) +                -> DrawingContext+                -> ScaleFactors +                -> Tree a +                -> TreePicture+drawFamilyTreePicture drawF dctx sfactors tree = +    liftToPictureU $ drawFamilyTree drawF dctx $ design sfactors tree  -------------------------------------------------------------------------------- -- Drawing functions

@@ -31,8 +31,7 @@  import Wumpus.Tree.Base --import Wumpus.Core ( Point2(..) )       -- package: wumpus-core+import Wumpus.Basic.Graphic             -- package: wumpus-basic  import Data.List  import Data.Maybe@@ -176,8 +175,8 @@     ext1            = xpos `extlink` ext0  -design :: (Double -> u, Int -> u) -> Tree a -> CoordTree u a-design (fx,fy) t = label 0 t3+design :: ScalingContext Double Int u -> Tree a -> CoordTree u a+design sctx t = runScaling sctx (label 0 t3)   where     (t1,ext)                    = designl t     (h,S xmin xmax)             = stats ext@@ -187,10 +186,10 @@     -- reconcile the left and right drawings...     t3                          = treeZipWith zfn t1 t2     -    mkPt x lvl                  = P2 (fx x) (fy $ h - lvl)-    label lvl (Node (x,a) kids) = Node (mkPt x lvl, a) kids'-       where-         kids' = map (label (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) 

@@ -18,6 +18,7 @@ module Wumpus.Tree.Draw    (     drawTree+  , drawFamilyTree    ) where @@ -31,11 +32,18 @@  import Data.VectorSpace                         -- package: vector-space +import Data.Monoid import Data.Tree hiding ( drawTree ) --- Don\'t actually need the Turtle of ConsDrawing... -drawTree :: (a -> TreeNode) -> DrawingContext -> CoordTree Double a -> HPrim Double++---------------------------------------------------------------------------------+-- Draw individual connector between parent and each child node.++drawTree :: (a -> TreeNode) +         -> DrawingContext +         -> CoordTree Double a +         -> HPrim Double drawTree drawF ctx tree = execDrawing ctx $ drawTop drawF tree   @@ -74,3 +82,53 @@     theta1  = if theta0 < pi then theta0 + pi else theta0 - pi      +--------------------------------------------------------------------------------+-- Draw in /family tree/ style++drawFamilyTree :: (a -> TreeNode) +               -> DrawingContext +               -> CoordTree Double a +               -> HPrim Double+drawFamilyTree drawF ctx tree = execDrawing ctx $ drawFamily drawF tree +++drawFamily :: (a -> TreeNode)  +           -> CoordTree Double a +           -> Drawing Double (DotAnchor Double)+drawFamily fn (Node (pt,a) ns) = do+    ancr <- drawi $ fn a `ati` pt+    xs   <- mapM (drawFamily fn) ns   +    draw $ famconn (south ancr) (map north xs)+    return ancr++famconn :: (Fractional u, Ord u) => Point2 u -> [Point2 u] -> Graphic u+famconn _       []         = mempty+famconn pt_from [p1]       = famconn1 pt_from p1+famconn pt_from xs@(p1:_)  = mconcat $ downtick : horizontal : upticks+   where+     hh         = halfHeight pt_from p1+     downtick   = straightLine (vvec (-hh)) pt_from+     horizontal = midline (vdisplace (-hh) pt_from) xs +     upticks    = map (straightLine (vvec hh)) xs++midline :: (Fractional u, Ord u) => Point2 u -> [Point2 u] -> Graphic u+midline _        []          = mempty+midline (P2 _ y) (P2 x0 _:zs) = +    let (a,b) = foldr fn (x0,x0) zs in straightLineBetween (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 => Point2 u -> Point2 u -> Graphic u+famconn1 a@(P2 xa _) b@(P2 xb _) +    | xa == xb  = straightLineBetween a b+    | otherwise = openStroke $ vertexPath [a,m1,m2,b] +  where+    hh = halfHeight a b+    m1 = vecdisplace (vvec (-hh)) a  +    m2 = vecdisplace (hvec $ xb - xa) m1

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

@@ -1,5 +1,5 @@ name:             wumpus-tree-version:          0.7.0+version:          0.8.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -15,9 +15,18 @@   output should be quite good - no overlapping edges, identical    subtrees should have the same shape, leaf nodes evenly spaced.   .+  \*\* WARNING \*\* - the API is unstable and will change.    .   Changelog:+  . +  0.7.0 to 0.8.0:   .+  * Changed drawTreePicture to use the @ScalingContext@ datatype+    from Wumpus.Basic. The type @ScaleFactors@ is now a type+    synonym for @SalingContext@ operation on all Doubles. +  . +  * Added an alternative drawing style /family tree/.+  .    0.6.0 to 0.7.0:   .    * More example trees in Demo01.hs.@@ -39,8 +48,8 @@   build-depends:      base              <  5,                        containers        >= 0.3.0     && < 0.4.0,                       vector-space      >= 0.6,-                      wumpus-core       == 0.33.0,-                      wumpus-basic      == 0.8.0+                      wumpus-core       == 0.34.0,+                      wumpus-basic      == 0.9.0       exposed-modules: