wumpus-tree (empty) → 0.1.0
raw patch · 10 files changed
+706/−0 lines, 10 filesdep +basedep +containersdep +vector-spacesetup-changed
Dependencies added: base, containers, vector-space, wumpus-basic, wumpus-core
Files
- CHANGES +6/−0
- LICENSE +30/−0
- Setup.hs +29/−0
- demo/Demo01.hs +46/−0
- src/Wumpus/Tree.hs +170/−0
- src/Wumpus/Tree/Base.hs +47/−0
- src/Wumpus/Tree/Design.hs +219/−0
- src/Wumpus/Tree/Draw.hs +76/−0
- src/Wumpus/Tree/VersionNumber.hs +28/−0
- wumpus-tree.cabal +55/−0
+ CHANGES view
@@ -0,0 +1,6 @@++++0.1.0:++ * First release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008 Stephen Peter Tetley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,29 @@+#!/usr/bin/env runhaskell++import Distribution.Simple+import Distribution.Simple.Setup ( SDistFlags )+import Distribution.PackageDescription ( HookedBuildInfo, emptyHookedBuildInfo )+++main = defaultMainWithHooks sdist_warning_hooks++sdist_warning_hooks :: UserHooks+sdist_warning_hooks = simpleUserHooks { preSDist = sdistVersionWarning }+++sdistVersionWarning :: Args -> SDistFlags -> IO HookedBuildInfo+sdistVersionWarning _ _ = + mapM_ putStrLn msg >> printVersionNumberFile >> return emptyHookedBuildInfo+ where+ msg = [ "-------------------------------------------------------"+ , "-------------------------------------------------------"+ , ""+ , "WARNING - is Wumpus.Tree.VersionNumber correct?"+ , ""+ , "-------------------------------------------------------"+ , "-------------------------------------------------------"+ ]++printVersionNumberFile :: IO ()+printVersionNumberFile = + readFile "src/Wumpus/Tree/VersionNumber.hs" >>= putStrLn
+ demo/Demo01.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS -Wall #-}+++module Demo01 where++import Wumpus.Tree++import Wumpus.Basic.SVGColours -- package: wumpus-basic++import Data.Tree hiding ( drawTree )+import System.Directory+++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 :: 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' []]++++++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++++++pic1 :: TreePicture+pic1 = drawTreePicture charNode (standardAttr 18) (uniformScaling 30) tree1++pic2 :: TreePicture+pic2 = drawTreePicture (diskNode red) (standardAttr 24) (uniformScaling 30) tree2+
+ src/Wumpus/Tree.hs view
@@ -0,0 +1,170 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Tree+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : highly unstable+-- Portability : GHC+--+--------------------------------------------------------------------------------++module Wumpus.Tree+ (+ -- * The type of rendered trees+ TreePicture+++ -- * Render a Data.Tree to a TreePicture+ , DrawingAttr(..) -- re-export+ , standardAttr -- re-export+++ , ScaleFactors(..)+ , uniformScaling++ , drawTreePicture++ -- * Output to file+ , writeEPS_TreePicture+ , writeSVG_TreePicture++ -- * Drawing nodes+ , charNode+ , textNode+ , circleNode+ , diskNode++ )+ where++import Wumpus.Tree.Base+import Wumpus.Tree.Design+import Wumpus.Tree.Draw++import Wumpus.Basic.AnchorDots -- package: wumpus-basic+import Wumpus.Basic.Graphic+import Wumpus.Basic.Monads.DrawingCtxClass+import Wumpus.Core -- package: wumpus-core++import Data.Maybe+import Data.Tree hiding ( drawTree )++-- | Output a 'TreePicture', generating an EPS file.+--+writeEPS_TreePicture :: FilePath -> TreePicture -> IO ()+writeEPS_TreePicture = writeEPS_latin1++-- | Output a 'TreePicture', generating a SVG file.+--+writeSVG_TreePicture :: FilePath -> TreePicture -> IO ()+writeSVG_TreePicture = writeSVG_latin1+++-- | 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.+--+data ScaleFactors = ScaleFactors+ { dx_scale :: Double+ , dy_scale :: Double + }+ deriving (Eq,Show)++-- | Build uniform x- and y-scaling factors, i.e. @ x == y @.+--+uniformScaling :: Double -> ScaleFactors+uniformScaling u = ScaleFactors u u ++-- | '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.+--+--+drawTreePicture :: (a -> TreeNode) + -> DrawingAttr + -> ScaleFactors + -> Tree a + -> TreePicture+drawTreePicture drawF attr sfactors tree = + fromMaybe errK $ drawGraphic $ drawTree drawF attr $ design funs tree+ where+ funs = scalingFunctions sfactors++errK :: a+errK = error "treePicture - empty tree drawing." +++scalingFunctions :: ScaleFactors -> (Double -> Double, Int -> Double)+scalingFunctions (ScaleFactors sx sy) = (fx,fy)+ where+ fx d = sx * d+ fy d = sy * fromIntegral d++--------------------------------------------------------------------------------+-- Drawing functions++-- | Render tree nodes with a single character.+--+-- Useful for rendering @ Data.Tree Char @.+--+charNode :: Char -> TreeNode+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 :: String -> TreeNode+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 :: DRGB -> (a -> TreeNode)+circleNode rgb = const fn+ where+ fn pt = withinModifiedCtx (\s -> s { stroke_colour = rgb}) (dotCircle $ pt)+++-- | Tree nodes with a filled circle.+--+-- Suitable for printing the shape of a tree, ignoring the data.+--+diskNode :: DRGB -> (a -> TreeNode)+diskNode rgb = const fn+ where+ fn pt = withinModifiedCtx (\s -> s { fill_colour = rgb}) (dotDisk $ pt)+++
+ src/Wumpus/Tree/Base.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Tree.Base+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : stephen.tetley@gmail.com+-- Stability : unstable+-- Portability : GHC+--+-- Common types, ...+--+--------------------------------------------------------------------------------++module Wumpus.Tree.Base+ (+ TreePicture+ , CoordTree+ + , TreeNode++ ) where+++import Wumpus.Core -- package: wumpus-core+import Wumpus.Basic.AnchorDots -- package: wumpus-basic+import Wumpus.Basic.Monads.Drawing+import Wumpus.Basic.Monads.SnocDrawing++import Data.Tree++-- | A rendered tree - alias for for @Picture Double@ in +-- Wumpus-Core.+--+type TreePicture = Picture Double+++-- | Tree annotated with positions.+--+type CoordTree u a = Tree (Point2 u, a)+++type TreeNode = MGraphicF (SnocDrawing Double) Double (DotAnchor Double)+
+ src/Wumpus/Tree/Design.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Tree.Design+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : highly unstable+-- Portability : GHC+--+-- A variant of the tree drawing algorithm from +-- Andrew Kennedy - Functional Pearls Drawing Trees 1996.+--+-- Acknowledgment - although based on Andrew Kennedy\'s algorithm,+-- this version uses absolute extents rather than relative ones +-- and is a somewhat different in detail if not in spirit to the +-- original.+--+-- Any mistakes are mine of course.+-- +--------------------------------------------------------------------------------++module Wumpus.Tree.Design+ (+ design+ )+ where++import Wumpus.Tree.Base+++import Wumpus.Core ( Point2(..) ) -- package: wumpus-core++import Data.List +import Data.Maybe+import Data.Tree++++-- | XPos is an absolute position+--+type XPos = Double ++type XTree a = Tree (XPos,a)+++-- | Delta - difference in X-positions.+--+type Delta = Double++data Span = S !XPos !XPos+ deriving (Eq,Ord,Show)++++outsideMerge :: Span -> Span -> Span+outsideMerge (S p _) (S _ q) = S p q++moveSpan :: Delta -> Span -> Span+moveSpan d (S p q) = S (p+d) (q+d)+++newtype Extent = Extent { span_list :: [Span] }+ deriving (Eq,Show)+++extlink :: XPos -> Extent -> Extent+extlink a (Extent as) = Extent (S a a:as)++-- note is this just for left ... ?+midtop :: XPos -> Extent -> XPos +midtop r (Extent []) = r+midtop _ (Extent (S p q:_)) = p + (0.5*(q-p))+++-- merge \"moving right\"...+mergeMR :: Delta -> Extent -> Extent -> Extent+mergeMR dx (Extent xs) (Extent ys) = Extent $ step xs ys+ where+ step ps [] = ps+ step [] qs = map (moveSpan dx) qs+ step (p:ps) (q:qs) = outsideMerge p (moveSpan dx q) : step ps qs++-- dx is negative...+--+mergeML :: Delta -> Extent -> Extent -> Extent+mergeML dx (Extent xs) (Extent ys) = Extent $ step xs ys+ where+ step ps [] = map (moveSpan dx) ps+ step [] qs = qs+ step (p:ps) (q:qs) = outsideMerge (moveSpan dx p) q : step ps qs++++extentZero :: Extent+extentZero = Extent []++extentOne :: XPos -> Extent+extentOne x = Extent [S x x]+++-- 'moveTree' is now recursive...+--+moveTree :: Delta -> XTree a -> XTree a+moveTree dx (Node (x,a) subtrees) = Node ((x+dx),a) subtrees'+ where+ subtrees' = map (moveTree dx) subtrees++++fit :: Extent -> Extent -> Double+fit a b = step (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 +++-- Fitting the children of a node...+++fitleft :: [(XTree a,Extent)] -> ([XTree a], Extent)+fitleft [] = ([],extentZero)+fitleft ((l,ext):xs) = (l:ts,ext') -- left-most child unchanged+ where + (ext',ts) = mapAccumL step ext xs++ step aex (t,ex) = let dx = fit aex ex + in (mergeMR dx aex ex, moveTree dx t)++fitright :: [(XTree a,Extent)] -> ([XTree a], Extent)+fitright = post . foldr fn Nothing+ where+ post = fromMaybe ([],extentZero)+ fn (t,ex) Nothing = Just ([t],ex)+ fn (t,ex) (Just (ts,aex)) = Just (t':ts,aex')+ where+ dx = negate $ fit ex aex+ t' = moveTree dx t+ aex' = mergeML dx ex aex++++-- Note - this will tell how wide the tree is...+-- though the last exten is not necessarily the widest.++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 a,Extent)]+ xs = map designl kids++ kids' :: [XTree a]+ ext0, ext1 :: Extent+ (kids',ext0) = fitleft xs++ xpos = midtop 0.0 ext0+ ext1 = xpos `extlink` ext0+++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 a,Extent)]+ xs = map (designr r) kids++ kids' :: [XTree a]+ ext0, ext1 :: Extent+ (kids',ext0) = fitright xs++ xpos = midtop r ext0+ ext1 = xpos `extlink` ext0+++design :: (Double -> u, Int -> u) -> Tree a -> CoordTree u a+design (fx,fy) t = label 0 t3+ where+ (t1,ext) = designl t+ (h,S xmin xmax) = stats ext+ width = xmax - xmin+ (t2,_) = designr width t+ + -- 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 ++ zfn (x0,a) (x1,_) = (mean x0 x1,a)++++-- find height and width+--+stats :: Extent -> (Int,Span)+stats (Extent []) = (0,S 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))++mean :: Double -> Double -> Double+mean x y = (x+y) / 2.0+++treeZipWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c+treeZipWith f (Node a xs) (Node b ys) = Node (f a b) (step xs ys)+ where+ step (p:ps) (q:qs) = treeZipWith f p q : step ps qs+ step _ _ = [] ++++
+ src/Wumpus/Tree/Draw.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Tree.Draw+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : stephen.tetley@gmail.com+-- Stability : unstable+-- Portability : GHC+--+-- Version number+--+--------------------------------------------------------------------------------++module Wumpus.Tree.Draw where++import Wumpus.Tree.Base++import Wumpus.Core -- package: wumpus-core++import Wumpus.Basic.Anchors -- package: wumpus-basic+import Wumpus.Basic.AnchorDots+import Wumpus.Basic.Graphic +import Wumpus.Basic.Monads.SnocDrawing+import Wumpus.Basic.SVGColours++import Data.VectorSpace -- package: vector-space++import Data.Tree++-- Don\'t actually need the Turtle of SnocDrawing...++drawTree :: (a -> TreeNode) -> DrawingAttr -> CoordTree Double a -> DGraphic+drawTree drawF attr tree = + execSnocDrawing (regularConfig 1) (0,0) attr+ $ drawTop drawF tree +++drawTop :: (a -> TreeNode) -> CoordTree Double a -> SnocDrawing Double ()+drawTop drawF (Node (pt,a) ns) = do + ancr <- drawF a pt+ mapM_ (draw1 drawF ancr) ns++draw1 :: (a -> TreeNode) + -> DotAnchor Double + -> CoordTree Double a + -> SnocDrawing Double ()+draw1 drawF ancr_from (Node (pt,a) ns) = do+ ancr <- drawF a pt+ connector ancr_from ancr+ mapM_ (draw1 drawF ancr) ns +++connector :: (Floating u, Real u, InnerSpace (Vec2 u)) + => DotAnchor u -> DotAnchor u -> SnocDrawing u ()+connector afrom ato = trace1 $ ostroke black $ vertexPath [p0,p1]+ where + (ang0,ang1) = anchorAngles (center afrom) (center ato)+ p0 = radialAnchor ang0 afrom+ p1 = radialAnchor ang1 ato +++++anchorAngles :: (Floating u, Real u, InnerSpace (Vec2 u)) + => Point2 u -> Point2 u -> (Radian,Radian)+anchorAngles f t = (theta0, theta1)+ where+ conn_v = pvec f t+ theta0 = direction conn_v+ theta1 = if theta0 < pi then theta0 + pi else theta0 - pi+ +
+ src/Wumpus/Tree/VersionNumber.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Tree.VersionNumber+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : stephen.tetley@gmail.com+-- Stability : unstable+-- Portability : GHC+--+-- Version number+--+--------------------------------------------------------------------------------++module Wumpus.Tree.VersionNumber+ ( + wumpus_tree_version++ ) where++-- | Version number+--+-- > (0,1,0)+--+wumpus_tree_version :: (Int,Int,Int)+wumpus_tree_version = (0,1,0)
+ wumpus-tree.cabal view
@@ -0,0 +1,55 @@+name: wumpus-tree+version: 0.1.0+license: BSD3+license-file: LICENSE+copyright: Stephen Tetley <stephen.tetley@gmail.com>+maintainer: Stephen Tetley <stephen.tetley@gmail.com>+homepage: http://code.google.com/p/copperbox/+category: Graphics+synopsis: Drawing trees+description:+ .+ Tree drawing with /nice/ layout. + .+ Draw trees represented by Data.Tree, output SVG or EPS. The + output should be quite good - no overlapping edges, identical + subtrees should have the same shape.+ .+ .+build-type: Simple+stability: highly unstable+cabal-version: >= 1.2++extra-source-files:+ CHANGES,+ LICENSE,+ demo/Demo01.hs+ +library+ hs-source-dirs: src+ build-depends: base < 5, + containers >= 0.3.0 && < 0.4.0,+ vector-space >= 0.6,+ wumpus-core >= 0.22.0,+ wumpus-basic >= 0.3.0++ + exposed-modules:+ Wumpus.Tree,+ Wumpus.Tree.VersionNumber++ other-modules:+ Wumpus.Tree.Base,+ Wumpus.Tree.Design,+ Wumpus.Tree.Draw++ extensions:+ ++ ghc-options:+ + includes: + ++ +