module TreeLayout (VColor(..), white, cream, black, lightBlue, lightBlueGreen, lightGray, mediumGray, darkGray, yellow, darkBlueGreen, blueGreen, Style(..), VFont(..), defaultStyle, style0, style1, style2, style3, wstyle, styleIncreasePadding, FontTextExtents(..), setFont, ftExtents, TextBox(..), makeTextBox, tbWidth, tbHeight, tbBottom, drawTextBox, tbCenter, tbTextCenter, tbBoxCenter, offsetTextBoxCenters, tbSetWidth, setColor, 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, Draw(..), DrawMode(..), modeTextCol, modeEdgeCol, modeFillCol, drawBox, treeLayoutWiden ) where import System.IO.Unsafe import Graphics.Rendering.Cairo hiding (translate) import Graphics.UI.Gtk (Rectangle) import Control.Monad (when) import Data.Traversable () -- imports only instance declarations import Geometry import Tree as T hiding (tree) import Util 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) -- 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) -- UNUSED -- -- | measureText is not used; should it be? -- measureText :: Style -> String -> Size -- measureText style str = extentsSize (styleTextExtents style str) -- -- | extentsSize: unused; should it be? -- extentsSize :: FontTextExtents -> Size -- extentsSize ftExts = Size (textXadvance ftExts) (fontHeight ftExts) 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 margin = textMargin style textW = textXadvance extents textH = fontHeight extents + fontDescent extents 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} 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] -- 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] data Iolet = Iolet Circle -- | other shapes could be added deriving (Eq, Read, Show) 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 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 ... -} -- 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 -> Position -> Tree e -> Tree (GNode e) -> Tree Size -> TreeLayout e treeLayout2 style (Position startX startY) -- top left after padding (T.Node _root subtrees) -- the tree being laid out -- ^^ actually we don't need the tree as an argument; -- it's implied by the GNode tree (T.Node gnode subGNodes) -- "node sizes" (T.Node (Size treeWidth treeHeight) subTreeSizes) -- tree Sizes = 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 setColor :: VColor -> Render () setColor (ColorRGB red green blue) = setSourceRGB red green blue setColor (ColorRGBA red green blue alpha) = setSourceRGBA red green blue alpha -- Drawing things -- ****** THINK: is this class well conceived? -- A lot of things could be done with draw and translate -- if it were not tied to Style and DrawMode class Draw a where draw :: Style -> DrawMode -> a -> Render () translate :: Double -> Double -> a -> a -- VV DrawMode is now very awkward, since -- a node needs to know not only if it is selected, -- but which port(s) are selected data DrawMode = DrawNormal | DrawActive | DrawSelectedNode | DrawSelectedInlet Int | DrawSelectedOutlet Int deriving (Eq) instance (Draw e) => Draw [e] where draw style mode = mapM_ (draw style mode) translate dx dy = map (translate dx dy) {- Tree must be an instance of Draw, in order for translate to work in treeLayoutWiden, but again, this is a bad combination (draw + translate). -} instance (Draw e) => Draw (Tree e) where draw style mode tree = do draw style mode (rootLabel tree) draw style mode (subForest tree) translate dx dy tree = T.Node (translate dx dy (rootLabel tree)) (translate dx dy (subForest tree)) instance Draw (LayoutNode e) where draw style mode (LayoutNode gnode _treeBB) = draw style mode gnode translate dx dy (LayoutNode gnode treeBB) = LayoutNode (translate dx dy gnode) (translate dx dy treeBB) instance Draw (GNode e) where draw style mode (GNode _value textboxes nodeBB inlets outlets) = do -- draw node box let (nodeTextCol, nodeEdgeCol, nodeFillCol) = case mode of DrawActive -> (styleActiveTextColor, styleActiveEdgeColor, styleActiveFillColor) DrawSelectedNode -> (styleSelectedTextColor, styleSelectedEdgeColor, styleSelectedFillColor) _ -> (styleNormalTextColor, styleNormalEdgeColor, styleNormalFillColor) -- (overall box for the node) when (styleShowNodeBoxes style) $ drawBox (Just (nodeFillCol style)) (Just (nodeEdgeCol style)) nodeBB -- assert textboxes has one or two elements -- draw the first text box drawTextBox (Just (styleFont style)) (Just (nodeFillCol style)) -- background Nothing -- frame color (nodeTextCol style) -- text color (head textboxes) -- draw the second textbox, if any, using "aux" style case (tail textboxes) of [tbAux] -> drawTextBox (Just (styleAuxFont style)) Nothing Nothing (styleAuxColor style) tbAux _ -> return () -- Draw the iolets when (styleShowNodePorts style) $ do drawInlets style mode inlets drawOutlets style mode outlets 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) instance Draw TextBox where draw style mode = drawTextBox (Just (styleFont style)) (Just (modeFillCol mode style)) Nothing (modeTextCol mode style) translate dx dy (TextBox text textBB boxBB) = TextBox text (translate dx dy textBB) (translate dx dy boxBB) drawTextBox :: Maybe VFont -> Maybe VColor -> Maybe VColor -> VColor -> TextBox -> Render () drawTextBox mfont mbgcolor mframecolor textcolor (TextBox text textBB boxBB) = do let BBox textX textY _textW _textH = textBB drawBox mbgcolor mframecolor boxBB setColor textcolor case mfont of (Just font) -> setFont font _ -> return () moveTo textX textY showText text instance Draw BBox where draw style mode = drawBox (Just (modeFillCol mode style)) (Just (modeEdgeCol mode style)) translate dx dy (BBox x y w h) = BBox (x + dx) (y + dy) w h drawBox :: Maybe VColor -> Maybe VColor -> BBox -> Render () drawBox mBgColor mFgColor (BBox x y w h) = -- draw the BBox, in the specified colors, irrespective of style let setup color = do rectangle x y w h setColor color in case (mBgColor, mFgColor) of (Just bgColor, Just fgColor) -> do setup bgColor fillPreserve setColor fgColor stroke (Just bgColor, Nothing) -> do setup bgColor fill (Nothing, Just fgColor) -> do setup fgColor stroke _ -> return () instance Draw Position where draw _style _mode _pos = return () -- bare points are invisible ??? ****** translate dx dy (Position x y) = Position (x + dx) (y + dy) instance Draw Iolet where draw style mode (Iolet circle) = draw style mode circle translate dx dy (Iolet circle) = Iolet (translate dx dy circle) drawIolet :: Iolet -> VColor -> VColor -> Render () drawIolet (Iolet circle) = drawCircle circle drawInlets :: Style -> DrawMode -> [Iolet] -> Render () drawInlets style mode inlets = let selected i = mode == DrawSelectedInlet i in drawIolets selected style inlets drawOutlets :: Style -> DrawMode -> [Iolet] -> Render () drawOutlets style mode outlets = let selected o = mode == DrawSelectedOutlet o in drawIolets selected style outlets drawIolets :: (Int -> Bool) -> Style -> [Iolet] -> Render () drawIolets selected style iolets = -- (selected n) should be true iff n is the selected iolet let loop _ [] = return () loop n (p:ps) = uncurry (drawIolet p) (if selected n then (styleSelectedFillColor style, styleSelectedEdgeColor style) else (styleNormalFillColor style, styleNormalEdgeColor style)) >> loop (n + 1) ps in loop 0 iolets instance Draw Circle where draw style mode circle = drawCircle circle (modeFillCol mode style) (modeEdgeCol mode style) translate dx dy (Circle center radius) = Circle (translate dx dy center) radius drawCircle :: Circle -> VColor -> VColor -> Render () drawCircle (Circle (Position x y) r) bgColor fgColor = do newPath -- otherwise we get a line to the arc arc x y r 0 (2 * pi) setColor bgColor fillPreserve setColor fgColor stroke -- Helper functions to find the background and foreground colors for a mode modeFillCol :: DrawMode -> (Style -> VColor) modeFillCol DrawNormal = styleNormalFillColor modeFillCol DrawActive = styleActiveFillColor modeFillCol _ = styleSelectedFillColor modeTextCol :: DrawMode -> (Style -> VColor) modeTextCol DrawNormal = styleNormalTextColor modeTextCol DrawActive = styleActiveTextColor modeTextCol _ = styleSelectedTextColor modeEdgeCol :: DrawMode -> (Style -> VColor) modeEdgeCol DrawNormal = styleNormalEdgeColor modeEdgeCol DrawActive = styleActiveEdgeColor modeEdgeCol _ = styleSelectedEdgeColor