sifflet-0.1.5: TreeLayout.hs

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 = 
          error $ "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