module Sifflet.Data.TreeLayout (VColor(..), white, cream, black, lightBlue, lightBlueGreen , lightGray, mediumGray, darkGray , yellow, darkBlueGreen, blueGreen , Style(..), VFont(..), defaultStyle, style0, style1, style2, style3 , wstyle , styleIncreasePadding , FontTextExtents(..), setFont, measureText, styleTextExtents, ftExtents , TextBox(..), makeTextBox, tbWidth, tbHeight, tbBottom , tbCenter, tbTextCenter, tbBoxCenter, offsetTextBoxCenters , tbSetWidth , treeSizes , GNode(..), treeGNodes, gnodeText, gnodeTextBB , Iolet(..), ioletCenter, makeIolets, makeIoletsRow , pointInIolet , IoletCounter, zeroIoletCounter , makeGNode , TreeLayout, LayoutNode(..) , layoutNodeSource, layoutRootBB, layoutTreeBB , treeLayout , treeLayoutPaddedSize, treeLayoutSize, treeLayoutWidth , layoutTreeMoveCenterTo , pointInLayoutNode, pointInGNode, findRect , treeLayoutWiden ) where import System.IO.Unsafe -- All this VVV is needed just to measure a piece of text; -- maybe font and text should be split out to a new module? import Graphics.Rendering.Cairo (FontExtents(..), FontSlant(..), FontWeight(..), Format(..), Render, TextExtents(..), fontExtents, renderWith, textExtents, selectFontFace, setFontSize, withImageSurface) import Graphics.UI.Gtk (Rectangle) import Data.Traversable () -- imports only instance declarations import Sifflet.Data.Geometry import Sifflet.Data.Tree as T hiding (tree) import Sifflet.Text.Repr () import Sifflet.Util -- Do colors really belong here??? data VColor = ColorRGB Double Double Double | ColorRGBA Double Double Double Double black, white, cream, lightBlue, lightBlueGreen :: VColor black = ColorRGB 0 0 0 white = ColorRGB 1 1 1 cream = ColorRGB 0.94902 0.94902 0.82745 lightBlue = ColorRGB 0.43529 0.43922 0.95686 lightBlueGreen = ColorRGB 0 1 1 lightGray, mediumGray, darkGray :: VColor lightGray = ColorRGBA 0.75 0.75 0.75 0.5 mediumGray = ColorRGB 0.5 0.5 0.5 darkGray = ColorRGB 0.25 0.25 0.25 yellow, darkBlueGreen, blueGreen :: VColor yellow = ColorRGB 0.9 0.9 0 darkBlueGreen = ColorRGB 0 0.3 0.3 blueGreen = ColorRGB 0 0.4 0.4 -- darkRed = ColorRGB 0.5 0 0, -- dark red data VFont = VFont {vfontFace :: String, vfontSlant :: FontSlant, vfontWeight :: FontWeight, vfontSize :: Double} data Style = Style {styleFont :: VFont, lineWidth :: Double, textMargin :: Double, -- in box on all four sides hpad, vpad :: Double, -- internode (interbox) spacing exomargin :: Double, -- margin of the tree within the window vtinypad :: (Double, Double), -- node-edge spacing (above, below) styleFramePad :: Double, -- pad between frames styleNormalTextColor, styleNormalFillColor, styleNormalEdgeColor, styleActiveTextColor, styleActiveFillColor, styleActiveEdgeColor, styleSelectedTextColor, styleSelectedFillColor, styleSelectedEdgeColor, styleTetherColor :: VColor, -- auxiliary text style, e.g., the value of an ExprNode styleAuxOffset :: Position, -- center-to-center offset dx dy styleAuxColor :: VColor, styleAuxFont :: VFont, styleIoletRadius :: Double, -- could extend to other shapes *** styleShowNodeBoxes :: Bool, -- draw a box around expr nodes styleShowNodePorts :: Bool -- draw the I/O ports of expr nodes } styleIncreasePadding :: Style -> Double -> Style -- increase hpad, vpad of style by multiplication styleIncreasePadding style factor = style {hpad = factor * hpad style, vpad = factor * vpad style} style0, style1, style2, style3, defaultStyle :: Style style0 = let green = ColorRGB 0.1 0.9 0.1 veryDarkGray = ColorRGB 0.1 0.1 0.1 brighterGreen = ColorRGB 0.5 0.95 0.5 in Style {styleFont = VFont "serif" FontSlantNormal FontWeightNormal 18, lineWidth = 2, textMargin = 18.0, -- text within its box hpad = 27, vpad = 36, -- inter-node separation exomargin = 0, vtinypad = (4.5, 4.5), -- node-edge separation styleFramePad = 35, -- padding between frames -- Foreground and background colors styleNormalTextColor = green, styleNormalEdgeColor = green, styleNormalFillColor = veryDarkGray, styleActiveTextColor = brighterGreen, styleActiveEdgeColor = brighterGreen, styleActiveFillColor = mediumGray, styleSelectedTextColor = blueGreen, styleSelectedEdgeColor = blueGreen, styleSelectedFillColor = darkGray, styleTetherColor = white, styleAuxOffset = Position 0.0 (-20.0), styleAuxColor = lightGray, styleAuxFont = VFont "serif" FontSlantItalic FontWeightNormal 12, styleIoletRadius = 5, styleShowNodeBoxes = True, -- draw a box around expr nodes styleShowNodePorts = True -- draw the I/O ports of expr nodes } style1 = let veryDarkBlue = ColorRGB 0 0 0.1 pinkIHope = ColorRGB 1 0.9 0.9 in style0 {styleNormalTextColor = veryDarkBlue, styleNormalEdgeColor = veryDarkBlue, styleNormalFillColor = lightGray, styleActiveTextColor = pinkIHope, styleActiveEdgeColor = pinkIHope } style2 = let darkPink = ColorRGB 1 0.5 0.5 in style1 {styleNormalFillColor = white, styleActiveTextColor = darkPink, styleActiveEdgeColor = darkPink} style3 = let semiTranspBlue = ColorRGBA 0 0.2 0.9 0.5 in style0 {exomargin = 10, styleNormalTextColor = yellow, styleNormalEdgeColor = yellow, styleNormalFillColor = darkBlueGreen, styleActiveTextColor = yellow, styleActiveEdgeColor = yellow, styleActiveFillColor = blueGreen, styleAuxColor = semiTranspBlue } defaultStyle = style3 wstyle :: Style wstyle = style3 { -- smaller to allow multiple frames on one canvas styleFont = VFont "serif" FontSlantNormal FontWeightNormal 14, textMargin = 8.0, hpad = 10.0, vpad = 24.0, vtinypad = (0.0, 0.0), exomargin = 10.0, -- between tree and window edges styleFramePad = 15, -- colors styleNormalTextColor = yellow, styleNormalEdgeColor = mediumGray, styleNormalFillColor = darkBlueGreen, styleActiveTextColor = yellow, styleActiveEdgeColor = mediumGray, styleActiveFillColor = blueGreen, styleSelectedTextColor = black, styleSelectedEdgeColor = lightBlueGreen, styleSelectedFillColor = lightBlueGreen, styleTetherColor = ColorRGBA 0.7 0.7 0.7 0.3, -- light gray -- node values styleAuxOffset = Position 0 (-16), styleAuxFont = VFont "serif" FontSlantItalic FontWeightNormal 12, styleAuxColor = ColorRGBA 0.9 0.5 0.5 1.0, -- ColorRGBA 1 0.9 0.9 0.75 styleIoletRadius = 5 } pointInLayoutNode :: Position -> LayoutNode e -> Bool pointInLayoutNode point = pointInGNode point . nodeGNode pointInGNode :: Position -> GNode e -> Bool pointInGNode point = pointInBB point . gnodeNodeBB -- UNUSED: findNode (except in findRect) -- find the node, if any, containing a point -- might need to adjust this to take iolets into account ****** findNode :: Position -> TreeLayout e -> Maybe (LayoutNode e) findNode point (T.Node node@(LayoutNode _rootGNode treeBB) sublayouts) = if pointInBB point treeBB then if pointInLayoutNode point node then Just node else findInSubs point sublayouts else Nothing where findInSubs :: Position -> [TreeLayout e] -> Maybe (LayoutNode e) findInSubs _p [] = Nothing findInSubs p (l:ls) = let found = findNode p l in case found of (Just _) -> found Nothing -> findInSubs p ls -- UNUSED: findRect findRect :: Position -> TreeLayout e -> Maybe Rectangle findRect point tlo = case findNode point tlo of Nothing -> Nothing Just node -> Just (bbToRect (gnodeNodeBB (nodeGNode node))) setFont :: VFont -> Render () setFont (VFont face slant weight size) = do selectFontFace face slant weight setFontSize size data FontTextExtents = FontTextExtents { fontAscent::Double, fontDescent::Double, fontHeight::Double, fontMaxXadvance::Double, fontMaxYadvance::Double, textXbearing::Double, textYbearing::Double, extTextWidth::Double, extTextHeight::Double, textXadvance::Double, textYadvance::Double} deriving (Eq, Read, Show) measureText :: Style -> String -> Size measureText style str = let extents = styleTextExtents style str in Size (textXadvance extents) (fontHeight extents + fontDescent extents) -- Rationale for unsafePerformIO: -- font extents of a string will not change unless the font itself -- changes, which is extremely unlikely styleTextExtents :: Style -> String -> FontTextExtents styleTextExtents style str = unsafePerformIO $ withImageSurface FormatARGB32 0 0 $ \ surface -> renderWith surface $ setFont (styleFont style) >> ftExtents str -- | ftExtents: used for what? ftExtents :: String -> Render FontTextExtents ftExtents text = do FontExtents asc desc fheight maxxadv maxyadv <- fontExtents TextExtents xbear ybear twidth theight xadv yadv <- textExtents text return (FontTextExtents asc desc fheight maxxadv maxyadv xbear ybear twidth theight xadv yadv) data TextBox = TextBox {tbText :: String, tbTextBB :: BBox, -- BBox of text without margins tbBoxBB :: BBox -- of text with margins } deriving (Eq, Read, Show) makeTextBox :: Style -> String -> TextBox makeTextBox style text = let extents = styleTextExtents style text Size textW textH = measureText style text -- textW = textXadvance extents -- textH = fontHeight extents + fontDescent extents margin = textMargin style boxW = textW + 2.0 * margin -- max (textW + 2.0 * margin) minWidth boxH = textH + 2.0 * margin boxX = 0 boxY = 0 textX = (boxW - textW) / 2.0 -- raise text slightly, by a fraction of its font descent -- (why? because it just looks better!) -- Maybe this should be made an aspect of style? raise = 0.5 * fontDescent extents textY = fontHeight extents + (boxH - textH) / 2.0 - raise textBB = BBox textX textY textW textH boxBB = BBox boxX boxY boxW boxH in TextBox text textBB boxBB instance Widen TextBox where widen tb@(TextBox _text textBB boxBB) minWidth = let w = bbWidth boxBB in if w >= minWidth then tb else let dw = minWidth - w in tb {tbTextBB = translate (dw / 2) 0 textBB, tbBoxBB = widen boxBB minWidth} instance Translate TextBox where translate dx dy (TextBox text textBB boxBB) = TextBox text (translate dx dy textBB) (translate dx dy boxBB) tbWidth :: TextBox -> Double tbWidth = bbWidth .tbBoxBB tbSetWidth :: TextBox -> Double -> TextBox tbSetWidth tbox w = let TextBox text textBB boxBB = tbox boxBB' = bbSetWidth boxBB w (dx, dy) = positionDelta (bbCenter boxBB) (bbCenter boxBB') in TextBox text (translate dx dy textBB) boxBB' tbHeight :: TextBox -> Double tbHeight = bbHeight . tbBoxBB tbBottom :: TextBox -> Double tbBottom = bbBottom . tbBoxBB -- The geometric "center" of a TextBox is the center of its "BoxBB" tbCenter :: TextBox -> Position tbCenter = tbBoxCenter tbBoxCenter :: TextBox -> Position tbBoxCenter = bbCenter . tbBoxBB -- and the center of its text should have the same x coordinate, -- but due to the way text is positioned, maybe not the same y. -- But do we ever need this? tbTextCenter :: TextBox -> Position tbTextCenter = bbCenter . tbTextBB offsetTextBoxCenters :: Position -> TextBox -> TextBox -> TextBox offsetTextBoxCenters offset anchor floater = -- Position the floater text box so that its center differs -- from the anchor text box by the given offset. -- (The offset argument comes first, like dx dy in translate.) let Position ax ay = tbBoxCenter anchor Position fx fy = tbBoxCenter floater Position ox oy = offset -- translate floater by (dx, dy), where fx + dx = ax + ox, -- so dx = ax + ox - fx; and dy similarly dx = ax + ox - fx dy = ay + oy - fy in translate dx dy floater -- GNode = graphical node, suitable for drawing data GNode e = GNode {gnodeValue :: e, gnodeTextBoxes :: [TextBox], -- one or two only gnodeNodeBB :: BBox, -- encloses all textboxes gnodeInlets :: [Iolet], -- input connectors gnodeOutlets :: [Iolet] -- output connectors } deriving (Eq) gnodeText :: GNode e -> String gnodeText = tbText . head . gnodeTextBoxes gnodeTextBB :: GNode e -> BBox gnodeTextBB = tbTextBB . head . gnodeTextBoxes instance (Show e) => Show (GNode e) where show (GNode v tbs nodeBB inlets outlets) = par "GNode" [show v, show tbs, show nodeBB, show inlets, show outlets] instance Translate (GNode e) where translate dx dy (GNode value textboxes nodeBB inlets outlets) = GNode value (map (translate dx dy) textboxes) (translate dx dy nodeBB) (translate dx dy inlets) (translate dx dy outlets) -- An IoletCounter returns (no. of inlets, no. of outlets) type IoletCounter e = e -> (Int, Int) -- A sort of "default" IoletCounter returning zeroes zeroIoletCounter :: IoletCounter e zeroIoletCounter _node = (0, 0) -- An IoletsMaker ??? -- type IoletsMaker e = Style -> e -> ([Position], [Position]) makeGNode :: (Repr e) => Style -> IoletCounter e -> e -> GNode e makeGNode style countIolets value = -- The function countIolets creates a tuple (# of inlets, # of outlets) -- for the node, of course being (0, 0) if we don't want any. let textboxes1 = map (makeTextBox style) (reprl value) textboxes2 = case textboxes1 of [_tb] -> textboxes1 [tb1, tb2] -> [tb1, offsetTextBoxCenters (styleAuxOffset style) tb1 tb2] _ -> wrong textboxes1 nodeBB = case textboxes2 of [tb] -> tbBoxBB tb [tb1, tb2] -> bbMerge (tbBoxBB tb1) (tbBoxBB tb2) _ -> wrong textboxes2 wrong tbs = errcats ["makeGNode: wrong no. of text boxes;", "expected 1 or 2, but got", show (length tbs)] (inlets, outlets) = makeIolets style nodeBB (countIolets value) in GNode value textboxes2 nodeBB inlets outlets makeIolets :: Style -> BBox -> (Int, Int) -> ([Iolet], [Iolet]) makeIolets style bbox (nin, nout) = -- make the (inlets, outlets) (makeIoletsRow style (bbXCenter bbox) (bbBottom bbox) nin, makeIoletsRow style (bbXCenter bbox) (bbTop bbox) nout) makeIoletsRow :: Style -> Double -> Double -> Int -> [Iolet] makeIoletsRow style cx cy n = -- make a row of n Iolets, centered at (cx, cy) let radius = styleIoletRadius style diam = 2 * radius -- diameter w = fromIntegral n * diam x1 = cx - w / 2 + radius -- the center of the first iolet x i = x1 + fromIntegral (i - 1) * diam make i = Iolet (Circle (Position (x i) cy) radius) in map make [1..n] -- | An Iolet is a circular port. -- Other shapes could be added. data Iolet = Iolet Circle deriving (Eq, Read, Show) instance Translate Iolet where translate dx dy (Iolet circle) = Iolet (translate dx dy circle) ioletCenter :: Iolet -> Position ioletCenter (Iolet circle) = circleCenter circle pointInIolet :: Position -> Iolet -> Bool pointInIolet point (Iolet circle) = pointInCircle point circle -- Build a Tree of node Sizes parallel to the Repr tree, -- each node in the Size tree is the size of -- the corresponding node in the repr tree. -- treeSizes: given a tree of *node* sizes, for the root nodes of the tree -- and its subtrees, returns a tree of *tree* sizes treeSizes :: Style -> Tree (GNode e) -> Tree Size treeSizes style gTree = let subtreeSizes = map (treeSizes style) (subForest gTree) (BBox _ _ rootWidth rootHeight) = gnodeNodeBB (rootLabel gTree) treeWidth = max rootWidth (paddedWidth style subtreeSizes) treeHeight = rootHeight + paddedHeight style subtreeSizes in T.Node (Size treeWidth treeHeight) subtreeSizes -- (paddedWidth style subtrees) and (paddedHeight style subtrees) -- compute the total size of all subtrees -- of of a Size tree, including padding. paddedWidth :: Style -> [Tree Size] -> Double paddedWidth _style [] = 0 paddedWidth style subtrees = sum [w | (T.Node (Size w _h) _) <- subtrees] + hpad style * fromIntegral (length subtrees - 1) -- UNUSED: -- -- | pairSum is unused; should it be? -- pairSum :: (Double, Double) -> Double -- pairSum (a, b) = a + b paddedHeight :: Style -> [Tree Size] -> Double paddedHeight _style [] = 0 paddedHeight style subtrees = vpad style + maximum [h | (T.Node (Size _w h) _) <- subtrees] -- A TreeLayout is a Tree of LayoutNodes. -- The root node in a TreeLayout identifies the root of the source Tree -- (nodeSource) and the node's bounding box (nodeNodeBB). -- It also tells the bounding box of the whole tree (nodeTreeBB). -- The subtrees of the TreeLayout are the TreeLayouts -- of the subtrees of the source Tree. type TreeLayout e = Tree (LayoutNode e) data LayoutNode e = LayoutNode {nodeGNode :: GNode e, nodeTreeBB :: BBox} deriving (Eq) layoutNodeSource :: LayoutNode e -> e layoutNodeSource = gnodeValue . nodeGNode instance (Show e) => Show (LayoutNode e) where show (LayoutNode gnode treebb) = par "LayoutNode" [show gnode, show treebb] instance Translate (LayoutNode e) where translate dx dy (LayoutNode gnode treeBB) = LayoutNode (translate dx dy gnode) (translate dx dy treeBB) instance Widen (LayoutNode e) where widen node@(LayoutNode gNode treeBB) minWidth = let dw = bbWidth treeBB - minWidth in if dw <= 0 then node else LayoutNode (translate (dw / 2) 0 gNode) (widen treeBB minWidth) -- Try this, it's tough! -- instance (Draw n, Widen n) = Widen (Tree n) where ... -- But why not just -- instance (Widen n) = Widen (Tree n) where ... -- UNUSED -- -- | layoutRootSource: unused -- layoutRootSource :: TreeLayout e -> e -- layoutRootSource tree = layoutNodeSource (rootLabel tree) layoutRootBB :: TreeLayout e -> BBox layoutRootBB = gnodeNodeBB . nodeGNode . rootLabel layoutTreeBB :: TreeLayout e -> BBox layoutTreeBB = nodeTreeBB . rootLabel treeLayout :: (Repr e) => Style -> IoletCounter e -> Tree e -> TreeLayout e treeLayout style counter tree = let t1 = treeGNodes style counter tree t2 = treeSizes style t1 start = Position (hpad style) (vpad style) t3 = treeLayout2 style start tree t1 t2 in treeLayoutAddMargin t3 (exomargin style) -- treeGNodes produces a tree of (GNode e), -- based on a top left corner at (0, 0) which, of course, will need -- to be translated in the final tlo. treeGNodes :: Repr e => Style -> IoletCounter e -> Tree e -> Tree (GNode e) treeGNodes style counter tree = fmap (makeGNode style counter) tree treeLayout2 :: (Repr e) => Style -- ^ tree style -> Position -- ^ top left after padding -> Tree e -- ^ the tree being laid out -- (actually we don't need the tree as an argument; -- it's implied by the GNode tree) -> Tree (GNode e) -- ^ "node sizes" -> Tree Size -- ^ tree Sizes -> TreeLayout e treeLayout2 style (Position startX startY) (T.Node _root subtrees) (T.Node gnode subGNodes) (T.Node (Size treeWidth treeHeight) subTreeSizes) = let nodeHeight = bbHeight (gnodeNodeBB gnode) -- center the root in its level -- UNUSED: -- nodeCenterX = startX + treeWidth / 2 -- nodeCenterY = startY + nodeHeight -- center the subtrees (may be wider or narrower than the root) subtreesTotalWidth = paddedWidth style subTreeSizes subX = startX + (treeWidth - subtreesTotalWidth) / 2 -- first subtree subY = startY + nodeHeight + vpad style sublayouts :: (Repr e) => Double -> [Tree e] -> [Tree (GNode e)] -> [Tree Size] -> [TreeLayout e] sublayouts _ [] [] [] = [] sublayouts x (t:ts) (g:gs) (s:ss) = treeLayout2 style (Position x subY) t g s : sublayouts (x + sizeW (rootLabel s) + hpad style) ts gs ss sublayouts _ _ _ _ = error "treeLayout2: mismatched list lengths" in T.Node (LayoutNode -- root node (centerGNode gnode startX startY treeWidth nodeHeight) -- node (BBox startX startY treeWidth treeHeight)) -- whole tree (sublayouts subX subtrees subGNodes subTreeSizes) -- | Center a GNode in a rectangular area centerGNode :: GNode e -> Double -> Double -> Double -> Double -> GNode e centerGNode gnode startx starty awidth aheight = let cx = startx + awidth / 2 -- desired center cy = starty + aheight / 2 Position cgx cgy = bbCenter (gnodeNodeBB gnode) in translate (cx - cgx) (cy - cgy) gnode treeLayoutPaddedSize :: Style -> TreeLayout e -> Size treeLayoutPaddedSize style tlo = let Size w h = treeLayoutSize tlo in Size (w + 2.0 * hpad style) (h + 2.0 * vpad style) treeLayoutSize :: TreeLayout e -> Size treeLayoutSize tlo = let BBox _x _y w h = layoutTreeBB tlo in Size w h layoutTreeMoveCenterTo :: Double -> Double -> TreeLayout e -> TreeLayout e layoutTreeMoveCenterTo newX newY layoutTree = let Position oldX oldY = bbCenter (nodeTreeBB (rootLabel layoutTree)) in translate (newX - oldX) (newY - oldY) layoutTree treeLayoutAddMargin :: TreeLayout e -> Double -> TreeLayout e treeLayoutAddMargin tree margin = let LayoutNode {nodeGNode = rootGNode, nodeTreeBB = treeBB} = rootLabel tree subtrees = subForest tree BBox x y w h = treeBB treeBB' = BBox (x - margin) (y - margin) (w + 2 * margin) (h + 2 * margin) root' = translate margin margin (LayoutNode rootGNode treeBB') subtrees' = translate margin margin subtrees in T.Node root' subtrees' treeLayoutWidth :: TreeLayout e -> Double treeLayoutWidth = bbWidth . layoutTreeBB treeLayoutWiden :: TreeLayout e -> Double -> TreeLayout e treeLayoutWiden tlo minWidth = let w = treeLayoutWidth tlo in if w >= minWidth then tlo else let dw = minWidth - w T.Node root subs = translate (dw / 2) 0 tlo LayoutNode rootGNode treeBB = root root' = LayoutNode rootGNode (translate (-dw / 2) 0 (widen treeBB minWidth)) in T.Node root' subs