diff --git a/demo/Demo01.hs b/demo/Demo01.hs --- a/demo/Demo01.hs +++ b/demo/Demo01.hs @@ -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 ] diff --git a/src/Wumpus/Tree.hs b/src/Wumpus/Tree.hs --- a/src/Wumpus/Tree.hs +++ b/src/Wumpus/Tree.hs @@ -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 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 @@ -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 + } diff --git a/src/Wumpus/Tree/Design.hs b/src/Wumpus/Tree/Design.hs --- a/src/Wumpus/Tree/Design.hs +++ b/src/Wumpus/Tree/Design.hs @@ -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 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 @@ -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" diff --git a/src/Wumpus/Tree/TreeBuildMonad.hs b/src/Wumpus/Tree/TreeBuildMonad.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Tree/TreeBuildMonad.hs @@ -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) [] + + + + + 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,12,0) +-- > (0,13,0) -- wumpus_tree_version :: (Int,Int,Int) -wumpus_tree_version = (0,12,0) +wumpus_tree_version = (0,13,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.12.0 +version: 0.13.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -28,12 +28,39 @@ . . - \*\* 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: