hxt-7.1: examples/hsvg/TreeVisualisation.hs
-- |
-- TreeVisualisation - A Haskell XML Toolbox application for
-- a graphic representation of n-ary trees, e.g. XmlTrees
-- with SGML. Input is a XML or HTML document, output a SGML document
-- consisting of a graphical representation of the tree
--
-- Author: Uwe Schmidt uwe@fh-wedel.de
--
-- Version : $Id: TreeVisualisation.hs,v 1.9 2004/09/02 19:11:50 hxml Exp $
module Main where
import Text.XML.HXT.Parser
import System.IO
import System.Environment
import System.Console.GetOpt
import System.Exit
import Data.Maybe
-- ----------------------------------------------------------
-- |
-- compute a layout tree for a given NTree
--
-- the layout tree has a stucture isomophic to the input tree
-- the layout is a pair of (x,y) coordinates. for every node
-- a weight is computed, the space for a tree will be proprtional to
-- the sum of the weight in the tree
treeToWeightedTree :: (Num b) => (a -> b) -> NTree a -> NTree (b, b)
treeToWeightedTree wf (NTree n cs)
= (NTree (wot, woc) cs')
where
cs' = map (treeToWeightedTree wf) cs
woc = sum . map (\ (NTree (sum', _) _) -> sum') $ cs'
wot = woc + wf n
-- |
-- auxiliary function called by 'horizontalLayout' for doint the hard work
weightedTreeToHLayout :: (Fractional a) => a -> a -> NTree (a,a) -> NTree (a,a)
weightedTreeToHLayout from to (NTree (_wot, woc) cs)
= NTree (from, to) cs'
where
len = to - from
cs' = layoutChildren (fromInteger 0) cs
layoutChildren _ []
= []
layoutChildren start (t1@(NTree (wot1, _woc1) _cs1) : ts)
= weightedTreeToHLayout from' to' t1 : layoutChildren start' ts
where
from' = (start / woc) * len + from
to' = (start' / woc) * len + from
start' = start + wot1
-- |
-- A horizontal layout for a tree generated with 'treeToWeightedTree'
-- is computed. The nodes are positioned in the unit square ((0,0),(1,1))
-- with the origin in the left upper corner. The root node is centered
-- at the top of the square
horizontalLayout :: (Fractional b) => (a -> b) -> NTree a -> NTree (b,b)
horizontalLayout weightFct
= weightedTreeToHLayout (fromInteger 0) (fromInteger 1) . treeToWeightedTree weightFct
-- |
-- layout of a tree in a 1.0 x 1.0 square
-- with the root node centered at the top and the
-- deepest leaves at the bottom
vTreeLayout :: (Fractional b) => (a -> b) -> NTree a -> NTree (b,b)
vTreeLayout weightFct t
= vLayout (0::Int) . horizontalLayout weightFct $ t
where
d = (depthNTree t - 1) `max` 1
vLayout i (NTree (l,u) cs)
= NTree (x, y) cs'
where
x = (l + u) / fromInteger 2
y = fromInteger (toInteger i) / fromInteger (toInteger d)
cs' = map (vLayout (i + 1)) cs
mirrorLayout :: NTree (a,a) -> NTree (a,a)
mirrorLayout
= mapNTree (\ (x,y) -> (y, x))
scaleLayout :: (RealFrac a) => Int -> Int -> Int -> NTree (a,a) -> NTree (Int,Int)
scaleLayout border dx dy
= mapNTree scale
where
scale (x,y) = (truncate (x * dx') + border, truncate (y * dy') + border)
dx' = fromIntegral (dx - 2 * border)
dy' = fromIntegral (dy - 2 * border)
centricLayout :: (Floating a) => NTree (a,a) -> NTree (a,a)
centricLayout
= mapNTree center
where
center (x, y)
= ((x' + 1) /2, (y' + 1) /2)
where
phi = (2 * x - 0.5) * pi
r = y
x' = cos phi * r
y' = sin phi * r
-- |
-- map nodes of a NTree to SVG tags
mapNodesToXml :: (a -> (Int, Int) -> XmlTrees) -> NTree a -> NTree (Int, Int) -> XmlTrees
mapNodesToXml formatNode layoutTree orgTree
= concat . zipWith formatNode (nTreeToList layoutTree) $ (nTreeToList orgTree)
mapNodesToSVG :: (a -> XmlFilter) -> NTree a -> NTree (Int, Int) -> XmlTrees
mapNodesToSVG circleLayout
= mapNodesToXml drawNode
where
drawNode n (x,y)
= atag "circle" [ sattr "cx" (show x)
, sattr "cy" (show y)
, circleLayout n
] $ undefined
mapEdgesToSVG :: ((Int, Int) -> (Int, Int) -> XmlTrees) -> NTree (Int, Int) -> XmlTrees
mapEdgesToSVG draw (NTree p1 cs)
= concatMap (\ t' -> mkLine t' ++ mapEdgesToSVG draw t') cs
where
mkLine (NTree p2 _) = draw p1 p2
drawLine :: XmlFilter -> (Int, Int) -> (Int, Int) -> XmlTrees
drawLine lineAttrl p1 p2
= drawLines lineAttrl [p1,p2]
drawHPath :: XmlFilter -> (Int, Int) -> (Int, Int) -> XmlTrees
drawHPath lineAttrl p1@(x1, y1) p2@(x2, y2)
= drawLines lineAttrl [p1, (x1,y12), (x2,y12), p2]
where
y12 = (y1 + y2) `div` 2
drawVPath :: XmlFilter -> (Int, Int) -> (Int, Int) -> XmlTrees
drawVPath lineAttrl p1@(x1, y1) p2@(x2, y2)
= drawLines lineAttrl [p1, (x12,y1), (x12,y2), p2]
where
x12 = (x1 + x2) `div` 2
drawLines :: XmlFilter -> [(Int, Int)] -> XmlTrees
drawLines attl ps
= concat . zipWith draw ps $ tail ps
where
draw (x1, y1) (x2, y2)
= atag "line" [ sattr "x1" (show x1)
, sattr "y1" (show y1)
, sattr "x2" (show x2)
, sattr "y2" (show y2)
, attl
] $ undefined
-- |
-- filter for copying the attributes into the content part
-- the result does not correspont to a wellformed XML document
-- but for drawing the tree inclusive attributes this works fine
moveAttrlToContent :: XmlFilter
moveAttrlToContent
= processChildren
( processBottomUp
( substChildren (getAttrl +++ getChildren) `when` isXTag ) )
-- |
-- the main transformation filter
xmlTreeToSVG :: XmlFilter
xmlTreeToSVG t
= rootTag [ getAttrl ]
[ getChildren
.>
isXTag -- get the root tag
.>
cat [ dtd DOCTYPE [ sattr a_name "svg"
, sattr k_public "-//W3C//DTD SVG 1.1//EN"
, sattr k_system "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"
] []
, tag "svg"
[ sattr "width" (show widthInt)
, sattr "height" (show heightInt)
, sattr "version" "1.1"
, sattr "xmlns" "http://www.w3.org/2000/svg"
, sattr "xmlns:xlink" "http://www.w3.org/1999/xlink" -- currently not used
]
[ stag "title" [ txt source]
, tag "text" [ sattr "x" "10" -- draw source uri
, sattr "y" "22"
, sattr "font-size" "12"
, sattr "fill" "grey"
] [ txt ("source: " ++ source)
]
, legend (10, heightInt - 5 * pixelPerLine - 10)
[ (tagColor, "tag")
, (textColor, "text")
, (attrColor, "attribute")
, (cmtColor, "comment")
, (defColor, "others")
]
, nodesToSVG
. scaleLayout borderWidthInt widthInt heightInt
. layoutFct
. vTreeLayout nSize
]
]
] .> addXmlPiToDoc $ t
where
t1 = head . (getChildren .> isXTag) $ t -- the root tag
pixelPerLine = 15
legend :: (Int, Int) -> [(String, String)] -> XmlFilter
legend (x1, y1) ls
= cat (zipWith legend1 ps ls)
where
ps = map (\ y' -> (x1, y1 + y' * pixelPerLine)) [0..]
legend1 (x', y') (color, text)
= cat [ atag "circle" [ sattr "cx" (show (x' + 5))
, sattr "cy" (show (y' + 10))
, sattr "r" "5"
, sattr "fill" color
, sattr "stroke-width" lineWidth
, sattr "stroke" lineColor
]
, tag "text" [ sattr "x" (show (x' + pixelPerLine))
, sattr "y" (show (y' + pixelPerLine))
, sattr "font-size" "12"
, sattr "fill" "grey"
] [ txt text
]
]
defValueOf attr' def' t'
| null res = def'
| otherwise = res
where
res = valueOf attr' t'
width = defValueOf "width" "800" t
height = defValueOf "height" "600" t
nodeScale = defValueOf "nodeSize" "1" t
borderWidth = defValueOf "borderWidth" "20" t
lineWidth = defValueOf "lineWidht" "1" t
lineColor = defValueOf "lineColor" "grey" t
textColor = defValueOf "textNodeColor" "blue" t
tagColor = defValueOf "tagNodeColor" "red" t
attrColor = defValueOf "attrNodeColor" "green" t
cmtColor = defValueOf "cmtNodeColor" "magenta" t
defColor = defValueOf "defaultNodeColor" "grey" t
layout = defValueOf "layout" "vertical" t
lineStyle = defValueOf "lineStyle" "line" t
source = valueOf a_source t
widthInt, heightInt, borderWidthInt :: Int
widthInt = read width `max` 100
heightInt = read height `max` 100
borderWidthInt= read borderWidth
nodesToSVG t' = mapEdgesToSVG (edgeLayoutFct edgeLayout) t'
++
mapNodesToSVG nodeLayout t1 t'
nodeLayout n
= cat [ sattr "fill" nColor
, sattr "stroke" ( if r < 5 -- if circle too small
then nColor -- border is drawn in the same color as cirle
else lineColor
)
, sattr "stroke-width" lineWidth
, sattr "r" (show r)
]
where
(nColor, nSz) = nLayout n
nSz1 = nSz * (read nodeScale)
r = (round (sqrt (fromInteger (toInteger nSz1))::Double))::Int
nSize :: XNode -> Double
nSize = fromInteger . toInteger . snd . nLayout
nLayout (XTag _tn _) = (tagColor, 9) -- constant size for tags
nLayout (XText tx) = (textColor, length tx)
nLayout (XAttr _an) = (attrColor, 4) -- attributes are smaller than tags
nLayout (XCmt c) = (cmtColor, length c)
nLayout _ = (defColor, 1) -- entities, PI's, dtd stuff, ...
layoutFct :: NTree (Double,Double) -> NTree (Double,Double)
layoutFct
= fromJust . lookup layout
$ [ ("vertical", id)
, ("horizontal", mirrorLayout )
, ("centric", centricLayout )
]
edgeLayoutFct
= fromJust . lookup (layout, lineStyle)
$ [ (("vertical", "line"), drawLine )
, (("vertical", "fork"), drawHPath )
, (("horizontal", "line"), drawLine )
, (("horizontal", "fork"), drawVPath )
, (("centric", "line"), drawLine )
, (("centric", "fork"), drawLine )
]
edgeLayout
= cat [ sattr "stroke" lineColor
, sattr "stroke-width" "1"
]
-- ----------------------------------------------------------
-- |
-- the main program of the Haskell XML Validating Parser
main :: IO ()
main
= do
argv <- getArgs
al <- cmdlineOpts argv
res <- run' (xmlToSVG al emptyRoot)
exitProg (null res) -- set return code and terminate
-- ------------------------------------------------------------
exitProg :: Bool -> IO a
exitProg True = exitWith (ExitFailure (-1))
exitProg False = exitWith ExitSuccess
-- ------------------------------------------------------------
-- |
-- the /real/ main program
--
-- runs in the trivial XmlState monad (with user state set to ())
-- so IO and access to global options is possible
xmlToSVG :: Attributes -> XmlStateFilter state
xmlToSVG al
= parseDocument al -- read document
.>>
traceMsg 1 "start processing"
.>>
liftMf
( canonicalizeAllNodes
.>
( moveAttrlToContent `when` hasAttr "withAttr" )
.>
xmlTreeToSVG
.>
indentDoc
)
.>>
traceMsg 1 "processing finished"
.>>
traceSource
.>>
traceTree
.>>
( writeDocument [ (a_indent, v_1) ]
`whenM`
getChildren
)
.>>
checkStatus
-- ------------------------------------------------------------
--
-- the options definition part
-- see doc for System.Console.GetOpt
progName :: String
progName = "TreeVisualisation"
options :: [OptDescr (String, String)]
options
= generalOptions
++
inputOptions
++
outputOptions
++
showOptions
++
[ Option "" ["width"] (ReqArg (nat "width") "NUM") "SVG image width in pixel, default: 800"
, Option "" ["height"] (ReqArg (nat "height") "NUM") "SVG image height in pixel, default: 600"
, Option "" ["withAttr"] (NoArg (att "withAttr" "1")) "show tag attributes, default: no"
, Option "" ["nodeSize"] (ReqArg (nat "nodeSize") "NUM") "scale size of nodes, default: 1"
, Option "" ["lineWidth"] (ReqArg (nat "lineWidth") "NUM") "width of edges in pixel, default: 1\n"
, Option "" ["border"] (ReqArg (nat "borderWidth") "NUM") "border around tree in pixel, default: 20\n"
, Option "" ["verticalTree"] (NoArg (att "layout" "vertical")) "vertical tree layout, root centered at the top border"
, Option "" ["horizontalTree"] (NoArg (att "layout" "horizontal")) "horizontal tree layout, root centered at the left border"
, Option "" ["centricTree"] (NoArg (att "layout" "centric")) "layout with root in the center"
, Option "" ["directLines"] (NoArg (att "lineStyle" "line")) "edges are drawn as direct lines"
, Option "" ["horizontalLines"] (NoArg (att "lineStyle" "fork")) "edges are drawn as a path of horizontal and vertical lines\n"
, Option "" ["textNodeColor"] (ReqArg (att "textNodeColor") "COLOR") "text node: color name or RGB value in format \"#RRGGBB\""
, Option "" ["tagNodeColor"] (ReqArg (att "tagNodeColor") "COLOR") "tag node color"
, Option "" ["attrNodeColor"] (ReqArg (att "attrNodeColor") "COLOR") "attribute node color"
, Option "" ["cmtNodeColor"] (ReqArg (att "cmtNodeColor") "COLOR") "comment node color"
, Option "" ["defaultNodeColor"] (ReqArg (att "defNodeColor") "COLOR") "other node color"
]
where
att n v = (n, v)
nat n v = (n, filter (`elem` "0123456789") v)
usage :: [String] -> IO a
usage errl
| null errl
= do
hPutStrLn stdout use
exitProg False
| otherwise
= do
hPutStrLn stderr (concat errl ++ "\n" ++ use)
exitProg True
where
header = "TreeVisualisation - An example application of the Haskell XML Toolbox\n" ++
"for the visualisation of the structure of a XML document with SVG\n" ++
"Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"
use = usageInfo header options
cmdlineOpts :: [String] -> IO (Attributes)
cmdlineOpts argv
= case (getOpt Permute options argv) of
(ol,n,[] )
-> do
sa <- src n
help (lookup a_help ol)
return (ol ++ sa)
(_,_,errs)
-> usage errs
where
src [] = usage ["no input url or file given\n"]
src [url] = return [("source", url)]
src _ = usage ["only one input uri or file allowed\n"]
help Nothing = return ()
help (Just _) = usage []
-- ------------------------------------------------------------