diff --git a/demo/Demo01.hs b/demo/Demo01.hs --- a/demo/Demo01.hs +++ b/demo/Demo01.hs @@ -39,8 +39,8 @@ pic1 :: TreePicture -pic1 = drawTreePicture charNode (standardAttr 18) (uniformScaling 30) tree1 +pic1 = drawTreePicture charNode (standardContext 18) (uniformScaling 30) tree1 pic2 :: TreePicture -pic2 = drawTreePicture (diskNode red) (standardAttr 24) (uniformScaling 30) tree2 +pic2 = drawTreePicture (diskNode red) (standardContext 24) (uniformScaling 30) tree2 diff --git a/src/Wumpus/Tree.hs b/src/Wumpus/Tree.hs --- a/src/Wumpus/Tree.hs +++ b/src/Wumpus/Tree.hs @@ -19,8 +19,8 @@ -- * Render a Data.Tree to a TreePicture - , DrawingAttr(..) -- re-export - , standardAttr -- re-export + , DrawingContext(..) -- re-export + , standardContext -- re-export , ScaleFactors(..) @@ -47,11 +47,9 @@ import Wumpus.Basic.Dots -- package: wumpus-basic import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr -import Wumpus.Basic.Monads.Drawing + import Wumpus.Core -- package: wumpus-core -import Data.Maybe import Data.Tree hiding ( drawTree ) -- | Output a 'TreePicture', generating an EPS file. @@ -104,15 +102,17 @@ -- -- drawTreePicture :: (a -> TreeNode) - -> DrawingAttr + -> DrawingContext -> ScaleFactors -> Tree a -> TreePicture -drawTreePicture drawF attr sfactors tree = - fromMaybe errK $ drawGraphic $ drawTree drawF attr $ design funs tree +drawTreePicture drawF ctx sfactors tree = + post $ drawTree drawF ctx $ design funs tree where funs = scalingFunctions sfactors - + post f = let xs = f [] in + if null xs then errK else frame xs + errK :: a errK = error "treePicture - empty tree drawing." @@ -153,9 +153,7 @@ -- Suitable for printing the shape of a tree, ignoring the data. -- circleNode :: RGBi -> (a -> TreeNode) -circleNode rgb = const fn - where - fn = dotCircle `props` (\s -> s { stroke_colour = rgb}) +circleNode rgb = \_ pt -> localCtxObj (primaryColour rgb) (dotCircle pt) -- | Tree nodes with a filled circle. @@ -163,9 +161,7 @@ -- Suitable for printing the shape of a tree, ignoring the data. -- diskNode :: RGBi -> (a -> TreeNode) -diskNode rgb = const fn - where - fn = dotDisk `props` (\s -> s { fill_colour = rgb}) +diskNode rgb = \_ pt -> localCtxObj (secondaryColour rgb) (dotDisk pt) diff --git a/src/Wumpus/Tree/Base.hs b/src/Wumpus/Tree/Base.hs --- a/src/Wumpus/Tree/Base.hs +++ b/src/Wumpus/Tree/Base.hs @@ -27,7 +27,6 @@ import Wumpus.Core -- package: wumpus-core import Wumpus.Basic.Dots -- package: wumpus-basic -import Wumpus.Basic.Monads.Drawing import Data.Tree @@ -42,5 +41,5 @@ type CoordTree u a = Tree (Point2 u, a) -type TreeNode = ANode Double (DotAnchor Double) +type TreeNode = DotLocImage Double diff --git a/src/Wumpus/Tree/Draw.hs b/src/Wumpus/Tree/Draw.hs --- a/src/Wumpus/Tree/Draw.hs +++ b/src/Wumpus/Tree/Draw.hs @@ -11,7 +11,7 @@ -- Stability : unstable -- Portability : GHC -- --- Version number +-- Drawing the tree using Wumpus-Basic. -- -------------------------------------------------------------------------------- @@ -26,12 +26,8 @@ import Wumpus.Core -- package: wumpus-core import Wumpus.Basic.Anchors -- package: wumpus-basic -import Wumpus.Basic.Colour.SVGColours import Wumpus.Basic.Dots import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr -import Wumpus.Basic.Monads.Drawing -import Wumpus.Basic.Monads.DrawingMonad import Data.VectorSpace -- package: vector-space @@ -39,13 +35,13 @@ -- Don\'t actually need the Turtle of ConsDrawing... -drawTree :: (a -> TreeNode) -> DrawingAttr -> CoordTree Double a -> DGraphic -drawTree drawF attr tree = execDrawing attr $ drawTop drawF tree +drawTree :: (a -> TreeNode) -> DrawingContext -> CoordTree Double a -> HPrim Double +drawTree drawF ctx tree = execDrawing ctx $ drawTop drawF tree drawTop :: (a -> TreeNode) -> CoordTree Double a -> Drawing Double () drawTop fn (Node (pt,a) ns) = do - ancr <- nodeAt (fn a) pt + ancr <- drawAtImg pt (fn a) mapM_ (draw1 fn ancr) ns draw1 :: (a -> TreeNode) @@ -53,19 +49,18 @@ -> CoordTree Double a -> Drawing Double () draw1 fn ancr_from (Node (pt,a) ns) = do - ancr <- nodeAt (fn a) pt - connector ancr_from ancr + ancr <- drawAtImg pt (fn a) + draw $ connector ancr_from ancr mapM_ (draw1 fn ancr) ns connector :: (Floating u, Real u, InnerSpace (Vec2 u)) - => DotAnchor u -> DotAnchor u -> Drawing u () -connector afrom ato = - trace $ wrapG $ ostroke black default_stroke_attr $ vertexPath [p0,p1] + => DotAnchor u -> DotAnchor u -> Graphic u +connector a1 a2 = openStroke $ vertexPath [p1,p2] where - (ang0,ang1) = anchorAngles (center afrom) (center ato) - p0 = radialAnchor ang0 afrom - p1 = radialAnchor ang1 ato + (ang0,ang1) = anchorAngles (center a1) (center a2) + p1 = radialAnchor ang0 a1 + p2 = radialAnchor ang1 a2 diff --git a/src/Wumpus/Tree/VersionNumber.hs b/src/Wumpus/Tree/VersionNumber.hs --- a/src/Wumpus/Tree/VersionNumber.hs +++ b/src/Wumpus/Tree/VersionNumber.hs @@ -22,7 +22,7 @@ -- | Version number -- --- > (0,5,0) +-- > (0,6,0) -- wumpus_tree_version :: (Int,Int,Int) -wumpus_tree_version = (0,5,0) +wumpus_tree_version = (0,6,0) diff --git a/wumpus-tree.cabal b/wumpus-tree.cabal --- a/wumpus-tree.cabal +++ b/wumpus-tree.cabal @@ -1,5 +1,5 @@ name: wumpus-tree -version: 0.5.0 +version: 0.6.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -18,6 +18,10 @@ . Changelog: . + 0.5.0 to 0.6.0: + . + * Updated to track changes in Wumpus-Basic. + . 0.4.0 to 0.5.0: . * Updated to track changes in Wumpus-Basic. Nothing new. @@ -53,8 +57,8 @@ build-depends: base < 5, containers >= 0.3.0 && < 0.4.0, vector-space >= 0.6, - wumpus-core == 0.31.0, - wumpus-basic == 0.6.0 + wumpus-core == 0.32.0, + wumpus-basic == 0.7.0 exposed-modules: