sifflet-lib 1.2.5.1 → 2.0.0.0

raw patch · 74 files changed

+12474/−10301 lines, 74 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Sifflet/Functoid.hs +104/−0
• Data/Sifflet/Geometry.hs +162/−0
• Data/Sifflet/Tree.hs +67/−0
• Data/Sifflet/TreeGraph.hs +252/−0
• Data/Sifflet/TreeLayout.hs +660/−0
• Data/Sifflet/WGraph.hs +478/−0
• Graphics/Rendering/Sifflet/Draw.hs +223/−0
• Graphics/Rendering/Sifflet/DrawTreeGraph.hs +182/−0
• Graphics/UI/Sifflet.hs +30/−0
• Graphics/UI/Sifflet/Callback.hs +152/−0
• Graphics/UI/Sifflet/Canvas.hs +1011/−0
• Graphics/UI/Sifflet/EditArgsPanel.hs +332/−0
• Graphics/UI/Sifflet/Frame.hs +307/−0
• Graphics/UI/Sifflet/GtkForeign.hs +123/−0
• Graphics/UI/Sifflet/GtkUtil.hs +224/−0
• Graphics/UI/Sifflet/LittleGtk.hs +185/−0
• Graphics/UI/Sifflet/RPanel.hs +154/−0
• Graphics/UI/Sifflet/Tool.hs +585/−0
• Graphics/UI/Sifflet/Types.hs +301/−0
• Graphics/UI/Sifflet/Window.hs +1259/−0
• Graphics/UI/Sifflet/Workspace.hs +597/−0
• ISSUES +403/−0
• Language/Sifflet/Examples.hs +277/−0
• Language/Sifflet/Export/Exporter.hs +192/−0
• Language/Sifflet/Export/Haskell.hs +159/−0
• Language/Sifflet/Export/Python.hs +198/−0
• Language/Sifflet/Export/ToHaskell.hs +136/−0
• Language/Sifflet/Export/ToPython.hs +171/−0
• Language/Sifflet/Export/ToScheme.hs +321/−0
• Language/Sifflet/Expr.hs +1021/−0
• Language/Sifflet/ExprTree.hs +227/−0
• Language/Sifflet/Parser.hs +319/−0
• Language/Sifflet/SiffML.hs +474/−0
• Language/Sifflet/TypeCheck.hs +590/−0
• Language/Sifflet/Util.hs +135/−0
• RELEASE-NOTES +159/−0
• Sifflet/Data/Functoid.hs +0/−98
• Sifflet/Data/Geometry.hs +0/−162
• Sifflet/Data/Tree.hs +0/−67
• Sifflet/Data/TreeGraph.hs +0/−250
• Sifflet/Data/TreeLayout.hs +0/−660
• Sifflet/Data/WGraph.hs +0/−410
• Sifflet/Examples.hs +0/−277
• Sifflet/Foreign/Exporter.hs +0/−191
• Sifflet/Foreign/Haskell.hs +0/−155
• Sifflet/Foreign/Python.hs +0/−194
• Sifflet/Foreign/ToHaskell.hs +0/−135
• Sifflet/Foreign/ToPython.hs +0/−170
• Sifflet/Foreign/ToScheme.hs +0/−318
• Sifflet/Language/Expr.hs +0/−1148
• Sifflet/Language/Parser.hs +0/−309
• Sifflet/Language/SiffML.hs +0/−468
• Sifflet/Rendering/Draw.hs +0/−223
• Sifflet/Rendering/DrawTreeGraph.hs +0/−182
• Sifflet/Text/Pretty.hs +0/−56
• Sifflet/Text/Repr.hs +0/−65
• Sifflet/UI.hs +0/−30
• Sifflet/UI/Callback.hs +0/−140
• Sifflet/UI/Canvas.hs +0/−982
• Sifflet/UI/Frame.hs +0/−306
• Sifflet/UI/GtkForeign.hs +0/−123
• Sifflet/UI/GtkUtil.hs +0/−224
• Sifflet/UI/LittleGtk.hs +0/−179
• Sifflet/UI/RPanel.hs +0/−154
• Sifflet/UI/Tool.hs +0/−561
• Sifflet/UI/Types.hs +0/−308
• Sifflet/UI/Window.hs +0/−1172
• Sifflet/UI/Workspace.hs +0/−405
• Sifflet/Util.hs +0/−135
• Text/Sifflet/Pretty.hs +56/−0
• Text/Sifflet/Repr.hs +65/−0
• datafiles/siffml-1.0.rnc +60/−0
• datafiles/siffml-2.0.rnc +71/−0
• sifflet-lib.cabal +52/−44

@@ -0,0 +1,104 @@+module Data.Sifflet.Functoid+    (Functoid(..)+    , functoidName, functoidArgNames, functoidHeader+    , FunctoidLayout(..), flayout+    , flayoutBBox, flayoutSize, flayoutWidth, flayoutBottom+    , flayoutWiden)++where++import Data.Graph.Inductive as G++import Data.Sifflet.Geometry+import Data.Sifflet.TreeLayout++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+++-- | A Functoid is either a FunctoidParts, representing a partially+-- defined function, or a (completely defined) Function.+-- A FunctoidParts represents an incompletely defined function,+-- which has a function name, argument names, and a list of graph nodes +-- representing the function body which might not yet form+-- a complete expression tree, e.g., nodes might+-- be unconnected.++data Functoid = FunctoidParts {fpName :: String,+                               fpArgs :: [String],+                               fpNodes :: [G.Node]}+              | FunctoidFunc {fpFunc :: Function}+      deriving (Show)++functoidName :: Functoid -> String+functoidName (FunctoidParts {fpName = name}) = name+functoidName (FunctoidFunc function) = functionName function++functoidArgNames :: Functoid -> [String]+functoidArgNames (FunctoidParts {fpArgs = args}) = args+functoidArgNames (FunctoidFunc function) = functionArgNames function++functoidHeader :: Functoid -> String+functoidHeader f = unwords (functoidName f : functoidArgNames f)++-- | What is a FunctoidLayout?  You can think of it as a +-- tree layout for a Frame,+-- or for a Functoid, or as a Forest of Tree Layouts!+-- For an Edit frame, it must be a forest, since the nodes are not+-- yet necessarily connected into a tree.+-- For a call frame, it will be a single TreeLayout (singleton list).++data FunctoidLayout = FLayoutTree (TreeLayout ExprNode)+                    | FLayoutForest [TreeLayout ExprNode] BBox++-- | Graphically lay out the Functoid.+-- mvalues: Nothing implies an uncalled frame,+--          Just values implies a called frame, even with 0 arguments.++flayout :: Style -> Functoid -> Env -> Maybe [Value] -> FunctoidLayout+flayout style functoid env mvalues =+    case functoid of+      FunctoidParts {} ->+          -- STUB: [] and bbox ***+          -- WELL: is this supposed to CREATE the tlo or RETRIEVE the tlo?+          -- Either way, it won't work without access to the WGraph!+          FLayoutForest [] (BBox (hpad style) (vpad style) 300 300)+      FunctoidFunc function ->+          let expr = functionBody function+              aspecs = functionArgSpecs function+              exprTree = case mvalues of+                           Nothing -> exprToTree expr+                           Just _values -> evalTree (exprToTree expr) env+              tlo = treeLayout style +                               (exprNodeIoletCounter env aspecs)+                               exprTree+          in FLayoutTree tlo++flayoutBBox :: FunctoidLayout -> BBox+flayoutBBox aflayout =+    case aflayout of+      FLayoutTree t -> layoutTreeBB t+      FLayoutForest _ bbox -> bbox++flayoutSize :: FunctoidLayout -> Size+flayoutSize = bbSize . flayoutBBox++flayoutWidth :: FunctoidLayout -> Double+flayoutWidth = bbWidth . flayoutBBox++flayoutBottom :: FunctoidLayout -> Double+flayoutBottom = bbBottom . flayoutBBox++flayoutWiden :: FunctoidLayout -> Double -> FunctoidLayout +flayoutWiden aflayout minWidth =+    case aflayout of+      FLayoutTree t -> FLayoutTree (treeLayoutWiden t minWidth)+      FLayoutForest f bbox -> FLayoutForest f bbox -- STUB ***++instance Translate FunctoidLayout where+    translate dx dy fl =+        case fl of+          FLayoutTree t -> +              FLayoutTree (translate dx dy t)+          FLayoutForest f b ->+              FLayoutForest (translate dx dy f) (translate dx dy b)

@@ -0,0 +1,162 @@+module Data.Sifflet.Geometry+    (Position(..), +     positionDelta, positionDistance,+     positionDistanceSquared, positionCloseEnough,+     Circle(..), pointInCircle,+     Size(..),+     BBox(..), +     bbX, bbY, bbWidth, bbSetWidth, bbHeight, bbPosition, bbSize,+     bbToRect, bbFromRect, bbCenter, bbLeft, bbXCenter, bbRight,+     bbTop, bbYCenter, bbBottom,+     bbMerge, bbMergeList, pointInBB,+     Widen(widen),+     Translate(..)+    )++where++import Data.Tree as T+import Graphics.UI.Gtk(Rectangle(Rectangle))++-- A Position may be interpreted either absolutely, as a point (x, y);+-- or relatively, as an offset (dx, dy)++data Position = Position {posX :: Double, posY :: Double} -- x, y+              deriving (Eq, Read, Show)++positionDelta :: Position -> Position -> (Double, Double)+positionDelta (Position x1 y1) (Position x2 y2) = (x2 - x1, y2 - y1)++positionDistance :: Position -> Position -> Double+positionDistance p1 p2 = sqrt (positionDistanceSquared p1 p2)++positionDistanceSquared :: Position -> Position -> Double+positionDistanceSquared (Position x1 y1) (Position x2 y2) =+    (x1 - x2) ** 2 + (y1 - y2) ** 2++positionCloseEnough :: Position -> Position -> Double -> Bool+positionCloseEnough p1 p2 radius =+    -- Essentially asks if p1 and p2 are nearly intersecting,+    -- i.e., if p1 is within a circle with center p2 and the given radius+    positionDistanceSquared p1 p2 <= radius ** 2++++data Circle = Circle {circleCenter :: Position,+                      circleRadius :: Double}+            deriving (Eq, Read, Show)++pointInCircle :: Position -> Circle -> Bool+pointInCircle point (Circle center radius) =+  positionCloseEnough point center radius++data Size = Size {sizeW :: Double, sizeH :: Double}    -- width, height+              deriving (Eq, Read, Show)++-- | BBox x y width height; (x, y) is the top left corner++data BBox = BBox Double Double Double Double+                   deriving (Eq, Read, Show)++-- | BBox accessors and utilities++bbX, bbY, bbWidth, bbHeight :: BBox -> Double+bbX (BBox x _y _w _h) = x++bbY (BBox _x y _w _h) = y+bbWidth (BBox _x _y w _h) = w+bbHeight (BBox _x _y _w h) = h++bbPosition :: BBox -> Position+bbPosition (BBox x y _w _h) = Position x y++bbSize :: BBox -> Size+bbSize (BBox _x _y w h) = Size w h++bbCenter :: BBox -> Position+bbCenter (BBox x y w h) = Position (x + w / 2) (y + h / 2)++bbSetWidth :: BBox -> Double -> BBox+bbSetWidth (BBox x y _w h) nwidth = BBox x y nwidth h++bbLeft, bbXCenter, bbRight :: BBox -> Double+bbLeft = bbX+bbXCenter (BBox x _y w _h) = x + w / 2+bbRight (BBox x _y w _h) = x + w++bbTop, bbYCenter, bbBottom :: BBox -> Double+bbTop = bbY+bbYCenter (BBox _x y _w h) = y + h / 2+bbBottom (BBox _x y _w h) = y + h++bbToRect :: BBox -> Rectangle+bbToRect (BBox x y w h) = +    Rectangle (round x) (round y) (round w) (round h)++bbFromRect :: Rectangle -> BBox+bbFromRect (Rectangle x y w h) =+    BBox (fromIntegral x) (fromIntegral y)+                (fromIntegral w) (fromIntegral h)++-- | Form a new BBox which encloses two bboxes+bbMerge :: BBox -> BBox -> BBox+bbMerge bb1 bb2 =+    let f1 ! f2 = f1 (f2 bb1) (f2 bb2)+        bottom = max ! bbBottom -- i.e.,  max (bbBottom bb1) (bbBottom bb2)+        top = min ! bbTop+        left = min ! bbLeft+        right = max ! bbRight+    in BBox left top (right - left) (bottom - top)++bbMergeList :: [BBox] -> BBox+bbMergeList [] = error "bbMergeList: empty list"+bbMergeList (b:bs) = foldl bbMerge b bs+    +-- Test whether a point (e.g., from mouse click) is within a+-- bounding box+pointInBB :: Position -> BBox -> Bool+pointInBB (Position x y) (BBox x1 y1 w h) =+    x >= x1 &&+    x <= x1 + w &&+    y >= y1 &&+    y <= y1 + h++class Widen a where+  -- | Make an object have at least a specified minimum width;+  -- does nothing if it's already at least that wide+  widen :: a -> Double -> a++instance Widen BBox where+    widen bb@(BBox x y w h) minWidth =+        if w >= minWidth+        then bb+        else BBox x y minWidth h++-- | A Translate is a thing that can be repositioned by+-- delta x and delta y++class Translate a where+        translate :: Double -- ^ delta X+                  -> Double -- ^ delta Y+                  -> a -- ^ thing in old position+                  -> a -- ^ thing in new position++instance (Translate e) => Translate [e] where+    translate dx dy = map (translate dx dy)++instance (Translate e) => Translate (Tree e) where+    translate dx dy t = +        T.Node (translate dx dy (rootLabel t))+               (translate dx dy (subForest t))+++instance Translate BBox where+  translate dx dy (BBox x y w h) = BBox (x + dx) (y + dy) w h++instance Translate Position where+    translate dx dy (Position x y) = Position (x + dx) (y + dy)++instance Translate Circle where+    translate dx dy (Circle center radius) =+        Circle (translate dx dy center) radius+

@@ -0,0 +1,67 @@+-- Tree.hs+-- General (not binary) trees++module Data.Sifflet.Tree +    (T.Tree(..), tree, leaf, isLeaf, treeSize, treeDepth+    , Repr(..)+    -- Since String is not an instance of Repr,+    -- we need to convert (Tree String) to (Tree Name)+    , Name(..), nameTree+    , putTree, putTreeR, putTreeRs, putTreeS+    , drawTreeShow+    )++where++import Data.Tree as T+import Text.Sifflet.Repr++-- Makers++tree :: e -> Forest e -> T.Tree e+tree root subtrees = T.Node {rootLabel = root, subForest = subtrees}++leaf :: e -> T.Tree e+leaf x = tree x []++isLeaf :: T.Tree e -> Bool+isLeaf (T.Node _root []) = True+isLeaf _ = False++treeSize :: T.Tree e -> Int+treeSize (T.Node _root subtrees) = 1 + sum (map treeSize subtrees)++treeDepth :: T.Tree e -> Int+treeDepth (T.Node _root []) = 1+treeDepth (T.Node _root subtrees) = 1 + maximum (map treeDepth subtrees)++{- tree_map or treeMap:+   removed; use (Functor) fmap instead+-}++{- tree_mapM:+   removed, use Data.Traversable.mapM instead.+-}++nameTree :: T.Tree String -> T.Tree Name+nameTree = fmap Name++putTree :: (Show e) => T.Tree e -> IO ()+putTree = putTreeS++-- putTreeR -- using repr (first part)+putTreeR :: (Repr e) => T.Tree e -> IO()+putTreeR = putStrLn . drawTree . fmap repr++-- putTreeRs -- using reprs (all parts)+putTreeRs :: (Repr e) => T.Tree e -> IO()+putTreeRs = putStrLn . drawTree . fmap reprs+++-- putTreeS -- using show+putTreeS :: (Show e) => T.Tree e -> IO ()+putTreeS = putStrLn . drawTreeShow++drawTreeShow :: (Show e) => T.Tree e -> String+drawTreeShow = drawTree . fmap show+

@@ -0,0 +1,252 @@+module Data.Sifflet.TreeGraph +    (LayoutGraph, +     flayoutToGraph, treeLayoutToGraph,+     -- treeToGraph, +     orderedTreeToGraph, +     treeGraphNodesTree, graphToTreeOriginal,+     graphToTreeStructure, +     flayoutToGraphRoots,+     graphToOrderedTree, graphToOrderedTreeFrom,+     orderedChildren, adjCompareEdge,+     nextNodes, -- exported for testing; any other reason?+     grTranslateNode, grTranslateSubtree, grTranslateGraph,++     -- moved from Workspace.hs:+     functoidToFunction, graphToExprTree,++    )++where++import Data.List (sort, sortBy)++import Data.Graph.Inductive as G++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree as T+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+import Language.Sifflet.TypeCheck++import Language.Sifflet.Util++type LayoutGraph n e = Gr (LayoutNode n) e++flayoutToGraph :: FunctoidLayout -> WGraph+flayoutToGraph tlo = +    case tlo of +      FLayoutTree t -> treeLayoutToGraph t+      FLayoutForest ts _bbox -> +          foldl grAddGraph wgraphNew (map treeLayoutToGraph ts)++treeLayoutToGraph :: TreeLayout ExprNode -> WGraph+treeLayoutToGraph = orderedTreeToGraph . fmap WSimple+++-- flayoutToGraphRoots returns a list of graph nodes (Ints)+-- corresponding to the root of the tree, or the roots of+-- the trees in the forest.+-- The list is ordered in the same sense as the graph nodes.++flayoutToGraphRoots :: FunctoidLayout -> [G.Node]+flayoutToGraphRoots (FLayoutTree _t) = [1]+flayoutToGraphRoots (FLayoutForest trees _bbox) =+    let loop _ [] res = reverse res+        loop next (t:ts) res =+            loop (next + treeSize t) ts (next:res)+    in loop 1 trees []+++-- {-# DEPRECATED treeToGraph "use ??? instead" #-}++-- treeToGraph :: Tree e -> Gr e ()+-- treeToGraph (T.Node root subtrees)  = +--     -- Convert an ordered tree to a graph.+--     -- The graph edge labels from parent to child +--     -- are integers corresponding to the order of the children.+--     -- So, to recover the ordered list of children, +--     -- sort by the edge label.+--     let g0 = empty :: Gr e ()+--         g1 = insNode (1, root) g0++--         grow :: Gr e () -> [(Tree e, G.Node)] -> G.Node -> Gr e ()+--         -- grow graph [(tree, parent)] node+--         grow g [] _ = g+--         grow g ((t, p):tps) n =+--             -- insert t forming g', insert ts into g'+--             let edge = ((), p) -- predecessors, or both?+--                 g' = ([edge], n, (rootLabel t), []) & g -- assume pred only+--             in grow g' (tps ++ [(s, n) | s <- subForest t])+--                        (succ n)++--     in grow g1 [(s, 1) | s <- subtrees] 2++sprout :: G.Node -> Tree e -> [(G.Node, WEdge, Tree e)]+sprout parent (T.Node _ subtrees) =+    -- create triples (parent graph node, edge, subtree)+    let m = length subtrees - 1+    in [(parent, WEdge e, s) | (e, s) <- zip [0..m] subtrees]+++orderedTreeToGraph :: Tree e -> Gr e WEdge+orderedTreeToGraph otree  = +    -- Convert an ordered tree to a graph.+    -- The graph edge labels from parent to child +    -- are integers corresponding to the order of the children.+    -- So, to recover the ordered list of children, +    -- sort by the edge label.+    let g0 = empty :: Gr e WEdge+        g1 = insNode (1, rootLabel otree) g0++        grow :: Gr e WEdge -> [(G.Node, WEdge, Tree e)] -> G.Node -> Gr e WEdge+        -- grow graph [(parent, edgeLabel, subtree), ...] node+        grow g [] _ = g+        grow g ((p, e, t):pets) n =+            -- insert pet forming g', insert pets into g';+            -- n is the node id for the root of this subtree+            let adj = (e, p) -- to parent (priority, node)+                g' = ([adj], n, (rootLabel t), []) & g +                n' = succ n+            in grow g' (pets ++ +                        sprout n t+                        -- [(s, n) | s <- subForest t])+                        )+                       n'++    in grow g1 (sprout 1 otree) 2++-- And what about this (e, Node) type?  Is it some sort of monad?++treeGraphNodesTree :: Tree e -> Tree Node+treeGraphNodesTree atree =+    -- returns a tree of Nodes of the Graph (treeToGraph atree)+    let gnTree :: Tree e -> Node -> Node -> (Tree Node, Node)+        gnTree (T.Node _root subtrees) rootNode next =+            -- rootNode = Node (number) for the root,+            -- next = next unused Node+            let (nNodes, next') = nextNodes subtrees next+                (subtrees', next'') = gnSubtrees subtrees nNodes next'+            in (T.Node rootNode subtrees', next'')++        gnSubtrees :: [Tree e] -> [Node] -> Node -> ([Tree Node], Node)+        gnSubtrees [] [] next = ([], next)+        gnSubtrees (t:ts) (n:ns) next = +            let (t', next') = gnTree t n next+                (ts', next'') = gnSubtrees ts ns next'+            in ((t' : ts'), next'')+        gnSubtrees _ _ _ = error "gnSubtrees: list lengths do not match"++    in fst (gnTree atree 1 2)++nextNodes :: [e] -> Node -> ([Node], Node)+nextNodes items next = +  -- next is the next unused Node (number).+  -- Returns list of new nodes, and a new "next" node+  -- E.g., nextNodes [a, b] 3 = ([3, 4], 5)+  --       nextNodes [c, d, e] 5 = ([5, 6, 7], 8)+  --       nextNodes [] 8 = ([], 8)+  let n = length items+      next' = next + n+  in ([next .. (next' - 1)], next')++-- When a tree is converted to a graph,+-- each tree node's ordered children get graph node numbers+-- in ascending order.  Therefore, when reconstructing the tree,+-- sorting the graph nodes restores the order of the children+-- as in the tree.++graphToOrderedTree :: Gr e WEdge -> Tree e+-- inverse of orderedTreeToGraph+graphToOrderedTree g = graphToOrderedTreeFrom g 1++graphToOrderedTreeFrom :: Gr e WEdge -> G.Node -> Tree e+graphToOrderedTreeFrom g n =+    case lab g n of+      Just label -> +          T.Node label (map (graphToOrderedTreeFrom g) (orderedChildren g n))+      Nothing -> +          errcats ["missing label for node", show n]++-- | List of the nodes children, ordered by edge number+orderedChildren :: Gr e WEdge -> G.Node -> [G.Node]+orderedChildren g = map fst . sortBy adjCompareEdge . lsuc g++adjCompareEdge :: (Node, WEdge) -> (Node, WEdge) -> Ordering+adjCompareEdge (_n1, e1) (_n2, e2) = compare e1 e2++{-# DEPRECATED graphToTreeOriginal "use ??? instead" #-}++graphToTreeOriginal :: Gr e () -> G.Node -> Tree e+-- (\g -> graphToTreeOriginal g 1) is the inverse of treeToGraph+graphToTreeOriginal g n =+    case lab g n of+      Just label -> T.Node label (map (graphToTreeOriginal g) +                                      (sort (suc g n)))+      _ -> errcats ["missing label for node", show n]++{-# DEPRECATED graphToTreeStructure "use ??? instead" #-}++graphToTreeStructure :: Gr n e -> G.Node -> Tree G.Node+-- This is *not* an inverse of treeToGraph.+-- Rather, graphToTreeStructure (treeToGraph t 1) is a tree t' of Nodes+-- (i.e., integer identifiers of nodes in the graph)+-- which parallels the structure of t.++graphToTreeStructure g n = T.Node n (map (graphToTreeStructure g)+                                         (sort (suc g n)))++grTranslateNode :: +  Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateNode node dx dy graph = +    grUpdateNodeLabel graph node (translate dx dy)++grTranslateSubtree :: +  Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateSubtree root dx dy graph = +    let trSubtrees :: [Node] -> LayoutGraph n e -> LayoutGraph n e+        trSubtrees [] g = g+        trSubtrees (r:rs) g = trSubtrees (rs ++ suc g r)+                              (grTranslateNode r dx dy g)+    in trSubtrees [root] graph++grTranslateGraph :: Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateGraph dx dy graph = nmap (translate dx dy) graph++grUpdateNodeLabel :: (DynGraph g) => g a b -> Node -> (a -> a) -> g a b+grUpdateNodeLabel graph node updater =+  case match node graph of+    (Nothing, _) -> error "no such node"+    (Just (preds, jnode, label, succs), graph') ->+        -- jnode == node+        (preds, jnode, updater label, succs) & graph'++functoidToFunction :: +    Functoid -> WGraph -> G.Node -> Env -> SuccFail Function+functoidToFunction functoid graph frameNode env =+    case functoid of+      FunctoidFunc f -> Succ f+      FunctoidParts {fpName = name, fpArgs = args} ->+          case suc graph frameNode of+            [root] ->+                do+                  {+                    expr <- treeToExpr $ graphToExprTree graph root+                  ; let impl = Compound args expr+                  ; (atypes, rtype) <- decideTypes name expr args env+                  ; Succ (Function (Just name) atypes rtype impl)+                  }+            _ -> Fail "The graph structure is not a tree!"++graphToExprTree :: WGraph -> G.Node -> Tree ExprNode+graphToExprTree g root =+    let extractExprNode wnode =+            case wnode of+              WSimple layoutNode -> gnodeValue (nodeGNode layoutNode)+              WFrame _ -> error "graphToExprTreeFrom: unexpected WFrame node"+    in fmap extractExprNode (graphToOrderedTreeFrom g root)++

@@ -0,0 +1,660 @@+module Data.Sifflet.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 Data.Sifflet.Geometry+import Data.Sifflet.Tree as T hiding (tree)+import Text.Sifflet.Repr ()+import Language.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.+newtype 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+++      

@@ -0,0 +1,478 @@+module Data.Sifflet.WGraph +    (WNode(..), WEdge(..), WGraph, WContext+    , wgraphNew, isWSimple, isWFrame, grInsertNode, grRemoveNode+    , connectToFrame+    , grConnect, grDisconnect+    , grAddGraph+    , grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree+     +    , wlab, llab, nodeExprNode, nodeText, nodeValue+    , nodeBBox, nodePosition, nodeInputValues+    , graphOrphans, adoptChildren+    , nodeAllChildren, nodeSimpleChildren, allDescendants, nodeFrameChildren+    , nodeAllSimpleDescendants, nodeProperSimpleDescendants+    , nodeIsSimple, nodeIsOpen, nodeContainerFrameNode+    , nodeParent++    , grUpdateFLayout, grUpdateTreeLayout+    , printWGraph+    , translateNodes+    , translateNode, grRelabelNode+    , translateTree+    , functoidParts, functionToParts+    -- Additional operations on graphs+    , nfilter+    )++where ++import Data.List (sort)+import Data.Maybe (fromJust)++import Data.Graph.Inductive as G++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree as T    -- exports Data.Tree.Tree(Node), etc.+import Data.Sifflet.TreeLayout++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree++import Text.Sifflet.Repr ()++import Language.Sifflet.Util++-- | A WGraph consists of WNodes with (sort of) Int-labled edges;+-- the edge labels serve to order the children of a node.++type WGraph = Gr WNode WEdge++type WContext = Context WNode WEdge++newtype WEdge = WEdge Int+           deriving (Eq, Read, Show)++instance Ord WEdge where+  compare (WEdge i) (WEdge j) = compare i j++-- | Two kinds of WNodes:+-- A WSimple node represents a node in an expression tree, e.g., "if", "+"+-- A WFrame node represents a panel or frame that displays an expression tree,+-- function call, or something similar.++data WNode = WSimple (LayoutNode ExprNode) +           | WFrame G.Node+             deriving (Eq, Show)++instance Repr WNode where+    repr (WSimple lnode) = repr (gnodeValue (nodeGNode lnode))+    repr (WFrame _) = "<frame>"++wgraphNew :: WGraph+wgraphNew = empty++isWSimple :: WNode -> Bool+isWSimple (WSimple _) = True+isWSimple _ = False++isWFrame :: WNode -> Bool+isWFrame (WFrame _) = True+isWFrame _ = False++-- | Print a description of the WGraph+printWGraph :: WGraph -> IO ()+printWGraph g = +    let vs = nodes g+        wnodeLabel v =+            case lab g v of +              Just (WFrame v') ->+                  "(WFrame with reference to vertex " ++ show v' ++ ")"+              Just (WSimple (LayoutNode {nodeGNode = gnode})) ->+                  repr (gnodeValue gnode)+              Nothing ->+                  "(unlabeled!)"+        printVertex v = do+          putStrLn $ "Vertex " ++ show v ++ +                     " with label " ++ wnodeLabel v+          putStrLn $ "   " ++ show (indeg g v) ++ " predecessors: " +++                     show [(v', wnodeLabel v') | v' <- pre g v]+          putStrLn $ "   " ++ show (outdeg g v) ++ " successors: " +++                     show [(v', wnodeLabel v') | v' <- suc g v]+    in do+      putStrLn $ "A WGraph with " ++ show (length vs) ++ " vertices"+      mapM_ printVertex vs++-- | Insert new node with given label into graph,+-- without any new edges;+-- return the new graph and the new node (number)+grInsertNode :: (DynGraph g) => g n e -> n -> (g n e, G.Node)+grInsertNode graph label =+    let (_, hi) = nodeRange graph+        newNode = succ hi+        nodeContext = ([], newNode, label, [])+        graph' = nodeContext & graph+    in (graph', newNode)++-- | Remove a node from the graph; return the updated graph.+grRemoveNode :: (DynGraph g) => g n e -> G.Node -> (g n e)+grRemoveNode graph node = +    let (mctx, g') = match node graph+    in case mctx of+         Nothing -> errcats ["grRemoveNode: node not found:", show node]+         Just _ -> g'++-- | Connect parent to child, using inlet as the order of the child+-- (0, 1, ...).  outlet is ignored, since there is only outlet 0.+-- As rendered, the parent's inlet-th inlet will have a line+-- to the child's outlet-th outlet.+-- This is achieved by inserting a labeled edge (parent, child, inlet)+-- and clearing any incompatible edge.  The incompatibles are:+-- a.  from same parent on same inlet to a different child.+-- b.  from the same parent on a different inlet to the same child.+-- c.  from same child (on same outlet) to a different parent.+--+-- NOTE: This is confusing, because, from the data flow perspective,+-- data flows OUT of the child INTO the parent, but from the+-- "tree in graph" perspective, links are directed OUT of the parent+-- INTO the child.  So beware!++grConnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> WGraph+grConnect g parent inlet child _outlet =+    let (mPcontext, g') = match parent g+    in case mPcontext of+      Nothing -> error "grConnect: parent not found"+      -- should parent below be same as parent above?+      Just (pins, jparent, plabel, pouts) ->+          -- jparent == parent+          let pouts' = filter (edgeNotTo child)+                              (filter (edgeNotEqual inlet) pouts)+              (mCcontext, g'') = match child g'+          in case mCcontext of+               Nothing -> error "grConnect: child not found"+               Just (_cins, jchild, clabel, couts) ->+                   -- jchild == child+                   -- remove ANY  links into the jchild (c)+                   let cins' = []+                   in                    +                     (pins, jparent, plabel, (inlet, jchild) : pouts') & +                     ((cins', jchild, clabel, couts) & g'')++edgeNotEqual :: WEdge -> (WEdge, G.Node) -> Bool+edgeNotEqual edge pair = edge /= fst pair++edgeNotTo :: G.Node -> (WEdge, G.Node) -> Bool+edgeNotTo node pair = node /= snd pair++-- | Removes a link between parent and child+-- where the edge was labeled inlet (order of child).+-- Ignores outlet, which should always be 0.+-- If child is not the inlet-th child of parent,+-- well, this is an error, but grDisconnect ignores it.+-- If toFrameP is true, the child node is+-- reconnected as a child to its frame+grDisconnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> Bool -> WGraph+grDisconnect g parent inlet child _outlet toFrameP =+    let (mcontext, g') = match parent g+        g'' = case mcontext of+                Nothing -> error "grDisconnect: parent not found"+                Just (ins, jparent, label, outs) ->+                    -- jparent == parent+                    let outs' = filter (/= (inlet, child)) outs+                    in (ins, jparent, label, outs') & g'+    in if toFrameP+       then connectToFrame child (nodeContainerFrameNode g parent) g''+       else g''++connectToFrame :: G.Node -> G.Node -> WGraph -> WGraph+connectToFrame child frameNode g =+    insEdge (frameNode, child, WEdge (outdeg g frameNode)) g++grAddGraph :: (DynGraph g) => g n e -> g n e -> g n e+grAddGraph g1 g2 =+    let (_, hi1) = nodeRange g1+        (lo2, _) = nodeRange g2+        diff = hi1 - lo2 + 1++        adjIncr :: Adj e -> Adj e+        adjIncr adj = [(x, node + diff) | (x, node) <- adj]++        ctxIncr :: Context n e -> Context n e+        ctxIncr (adjFrom, node, label, adjTo) = +            (adjIncr adjFrom, node + diff, label, adjIncr adjTo)++        loop :: (DynGraph g) => g n e -> g n e -> g n e+        loop ga gb =+            if isEmpty gb+            then ga+            else let (acontext, gb') = matchAny gb in+                 ctxIncr acontext & loop ga gb'+    in loop g1 g2++-- | Extract from a graph the expression with root node n, +-- returning a Tree of ExprNode.+-- Use only the WSimple nodes of the graph (and n had better be one).+grExtractExprTree :: WGraph -> G.Node -> Tree ExprNode+grExtractExprTree g = fmap layoutNodeSource . grExtractLayoutTree g++-- ------------------------------------------------------------+-- | Finding characteristics of the WNodes in a graph+-- It is an implicit error if there is no label for the node++-- | wlab is like lab with no Maybe: the node *must* have a label+wlab :: WGraph -> Node -> WNode+wlab g n = fromJust (lab g n)++-- | llab is the tree layout node of a WSimple node+llab :: WGraph -> Node -> LayoutNode ExprNode+llab g n = +    case wlab g n of+      WSimple lnode -> lnode+      WFrame _fnode ->+          errcat ["llab: node is not simple",+                  "\nnode ", (show n),+                  "\n in graph\n",+                  (show g)]++-- | The ExprNode represented by the graph node+nodeExprNode :: WGraph -> Node -> ExprNode+nodeExprNode g n = gnodeValue (nodeGNode (llab g n))++-- | The repr of the node's value+nodeText :: WGraph -> Node -> String+nodeText g n = tbText (head (gnodeTextBoxes (nodeGNode (llab g n))))++-- | The result of an evaluated node in an expression tree+nodeValue :: WGraph -> Node -> EvalResult+nodeValue g n = mvalue+    where ENode _ mvalue = nodeExprNode g n++-- | The node's BBox+nodeBBox :: WGraph -> Node -> BBox+nodeBBox g n = gnodeNodeBB (nodeGNode (llab g n))++nodePosition :: WGraph -> Node -> Position+nodePosition g = bbPosition . nodeBBox g++nodeInputValues :: WGraph -> Node -> EvalResult+nodeInputValues graph node = +   mapM (nodeValue graph) (nodeSimpleChildren graph node) >>= +   EvalOk . VList++-- | Find all parentless nodes in a graph+graphOrphans :: (Graph graph) => graph a b -> [Node]+graphOrphans g = filter (\ v -> pre g v == []) (nodes g)+   +-- | Connect the given children to a new parent+adoptChildren :: WGraph -> G.Node -> [G.Node] -> WGraph+adoptChildren g0 parent children =+    let adopt g child = insEdge (parent, child, WEdge (outdeg g parent)) g+    in foldl adopt g0 children++-- | Finding the children (nodes, numbers) of a node in a graph :+-- all children, only WSimple-labeled children, only WFrame-labeled children+-- When constructing the graph, ordered children of a tree node +-- get graph node numbers in ascending order; therefore,+-- sorting the graph nodes gives back the original order of+-- children in the tree (plus WFrames that are added later,+-- and those should always be after the simple children)++nodeAllChildren :: WGraph -> Node -> [Node]+nodeAllChildren g n = sort (suc g n) ++nodeSimpleChildren :: WGraph -> Node -> [Node]+nodeSimpleChildren g n = filter (nodeIsSimple g) (nodeAllChildren g n)++-- | All (proper and improper) descendants of a node in a graph+allDescendants :: (Graph graph) => graph a b -> Node -> [Node]+allDescendants g n = reachable n g++nodeAllSimpleDescendants :: WGraph -> Node -> [Node]+nodeAllSimpleDescendants g n = +    n : concatMap (nodeAllSimpleDescendants g) (nodeSimpleChildren g n)++nodeProperSimpleDescendants :: WGraph -> Node -> [Node]+nodeProperSimpleDescendants g n = tail (nodeAllSimpleDescendants g n)++nodeFrameChildren :: WGraph -> Node -> [Node]+nodeFrameChildren g n = filter (not . nodeIsSimple g) (nodeAllChildren g n)+    +nodeIsSimple :: WGraph -> Node -> Bool+nodeIsSimple g n = +    -- is node n of graph g a WSimple node?+    case lab g n of+      Just (WSimple _) -> True+      _ -> False++-- | An open node has a WFrame-labeled child+nodeIsOpen :: WGraph -> Node -> Bool+nodeIsOpen graph node = nodeFrameChildren graph node /= []++-- The root node of the tree in which node occurs.+-- This is a WSimple node, it may not back up to a WFrame node.+--+-- THIS CODE IS UNTESTED, AND CURRENTLY UNUSED (2009/2/4)++-- -- nodeTreeRoot: unused+-- nodeTreeRoot :: WGraph -> Node -> Node+-- nodeTreeRoot g n = findRoot n+--     where findRoot node = +--               case pre g node of+--                 [] -> (error "nodeTreeRoot: no simple root found")+--                 [parent] -> +--                     if not (nodeIsSimple g parent)+--                     then node+--                     else findRoot parent+--                 _ -> error "nodeTreeRoot: node has multiple parents"++-- -- The root (a WSimple node) of the tree in which a node occurs+-- -- Huh, don't need this!++-- -- nodeSimpleRoot: unused+-- nodeSimpleRoot :: WGraph -> Node -> Node+-- nodeSimpleRoot = undefined++-- | The graph node of the frame that contains the given node+nodeContainerFrameNode :: WGraph -> Node -> Node+nodeContainerFrameNode g n = +    let findFrame node =+            if not (nodeIsSimple g node)+            then node+            else case pre g node of+                   [parent] -> findFrame parent+                   [] -> err "has no parent but is not a frame node" node+                   _:_ -> err "has multiple parents" node+        err msg node =+            errcat["nodeContainerFrameNode: node ",+                   show node, " ", msg, "\n",+                   "in graph\n", show g]+        +    in findFrame n++-- | The parent (if any) of a node+nodeParent :: WGraph -> Node -> Maybe Node+nodeParent g n = +    case pre g n of+      [] -> Nothing+      [parent] -> Just parent+      _ -> error "nodeParent: multiple parents"+++grUpdateFLayout :: WGraph -> [G.Node] -> FunctoidLayout -> WGraph+grUpdateFLayout gr ns tlo =+    case tlo of+      FLayoutTree t -> +          case ns of+            [rootNode] -> grUpdateTreeLayout gr rootNode t+            _ -> error "grUpdateFLayout: tree tlo, but not a single root"+      FLayoutForest f _b ->+          let accum g (n, t) = grUpdateTreeLayout g n t+          in foldl accum gr (zip ns f)++-- | Replace the tree embedded in graph g with root n, with a new tree.+grUpdateTreeLayout :: WGraph -> G.Node -> TreeLayout ExprNode -> WGraph+grUpdateTreeLayout gr n0 t0 = updateTree gr n0 t0+    where updateTree g n (T.Node root subtrees) =+              case match n g of+                (Just (adjFrom, jn, WSimple _, adjTo), g1) ->+                    -- jn == n+                    let g2 = (adjFrom, jn, WSimple root, adjTo) & g1+                    in updateForest g2 (nodeSimpleChildren g jn) subtrees+                (Just (_adjFrom, _n, _, _adjTo), _) ->+                    error "grUpdateTreeLayout: root node is not a WSimple"+                (Nothing, _) -> +                    errcats ["grUpdateTreeLayout: no such node:", show n]++          updateForest g [] [] = g+          updateForest g (n:ns) (t:ts) = +              case lab g n of+                Just (WSimple _) -> updateForest (updateTree g n t) ns ts+                Just (WFrame _) -> updateForest g ns (t:ts) -- shouldn't happen!+                Nothing -> error "grUpdateTreeLayout: no label for node"++          updateForest _g _ [] = error "too many ns"+          updateForest _g [] _ = error "too many ts"++-- | Extract just the single tree layout node of the given graph node+grExtractLayoutNode :: WGraph -> G.Node -> LayoutNode ExprNode+grExtractLayoutNode g n =+    case lab g n of+      Just (WSimple lnode) -> lnode+      _ -> errcats ["grExtractLayoutNode:",+                    "no label for node, or node is not WSimple:",+                    "node", show n]++-- | Extract the tree layout (tree) descended from the given root node+grExtractLayoutTree :: WGraph -> G.Node -> TreeLayout ExprNode+grExtractLayoutTree g n =+    T.Node (grExtractLayoutNode g n)+           (map (grExtractLayoutTree g) (nodeSimpleChildren g n))+++-- | Translate the nodes forming a tree with the given root+translateTree :: Double -> Double -> WGraph -> G.Node -> WGraph+translateTree dx dy wgraph root = +    grUpdateTreeLayout wgraph root +                   (translate dx dy (grExtractLayoutTree wgraph root))+++translateNodes :: Double -> Double -> WGraph -> [G.Node] -> WGraph+translateNodes dx dy = foldl (translateNode dx dy)++translateNode :: Double -> Double -> WGraph -> G.Node -> WGraph+translateNode dx dy wg node =+    case match node wg of+      (Nothing, _) ->+          errcats ["translateNode: no such node:", show node]+      (Just (adjFrom, jnode, WSimple layoutNode, adjTo), g') ->+          -- jnode == node+          (adjFrom, jnode, WSimple (translate dx dy layoutNode), adjTo) & g'+      (Just _, _) ->+          errcats ["translateNode: node is not a WSimple:", show node]+++-- | Replace the label of a node in a graph+grRelabelNode :: (DynGraph g) => g a b -> G.Node -> a -> g a b+grRelabelNode g n newLabel =+    case match n g of+      (Just (adjFrom, jn, _oldLabel, adjTo), g') ->+          -- jn == n+          (adjFrom, jn, newLabel, adjTo) & g'+      (Nothing, _) -> errcats ["grRelabelNode: no such node:", show n]++-- | Get the parts of a Functoid.+-- See note on functionToParts (just below).+-- Seems to be unused ***++functoidParts :: Functoid -> WGraph -> G.Node -> Functoid+functoidParts functoid graph frameNode =+    case functoid of+      fp@FunctoidParts {} -> fp+      FunctoidFunc function -> functionToParts function graph frameNode++-- | Convert a function to its parts.+-- COULDN'T THIS BE DONE USING the function's implementation,+-- and not need to use the graph?  Then this could go in Functoid.hs+-- without circular import between it and WGraph+functionToParts :: Function -> WGraph -> G.Node -> Functoid+functionToParts (Function mname _atypes _rtype impl) graph frameNode  =+    case impl of +      Primitive _ -> error "functionToParts: function is primitive"+      Compound argnames _body ->+          FunctoidParts {fpName = case mname of+                                    Nothing -> "unnamed function"+                                    Just jname -> jname,+                         fpArgs = argnames, +                         fpNodes = nodeProperSimpleDescendants graph frameNode}++++-- | Filter the nodes of a graph++nfilter :: (Node -> Bool) -> Gr v e -> Gr v e+nfilter f g =+    nfilter' f g (nodes g)++nfilter' :: (Node -> Bool) -> Gr v e -> [Node] -> Gr v e+nfilter' _f g [] = g+nfilter' f g (n:ns) = nfilter' f (if f n then g else delNode n g) ns

@@ -0,0 +1,223 @@+module Graphics.Rendering.Sifflet.Draw+    (    +     Draw(..), DrawMode(..)+    , drawBox+    , drawTextBox+    , modeTextCol, modeEdgeCol, modeFillCol+    , setColor++    )++where++import Control.Monad+import Graphics.Rendering.Cairo hiding (translate)++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree+import Data.Sifflet.TreeLayout++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 ()++-- 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 FunctoidLayout where+    draw style mode (FLayoutTree t) = draw style mode t+    draw style mode (FLayoutForest f _) = draw style mode f++instance (Draw e) => Draw [e] where+    draw style mode = mapM_ (draw style mode)++instance (Draw e) => Draw (Tree e) where+    draw style mode t = do+      draw style mode (rootLabel t)+      draw style mode (subForest t)++instance Draw (LayoutNode e) where+    draw style mode (LayoutNode gnode _treeBB) = draw style mode gnode++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+          ++instance Draw TextBox where+    draw style mode =+        drawTextBox (Just (styleFont style))+                    (Just (modeFillCol mode style)) +                    Nothing+                    (modeTextCol mode style) ++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)) ++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 ??? ******++instance Draw Iolet where+    draw style mode (Iolet circle) = draw style mode 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) ++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+

@@ -0,0 +1,182 @@+-- | Tree graph rendering+module Graphics.Rendering.Sifflet.DrawTreeGraph+    (+     graphQuickView+     , graphWriteImageFile, graphRender, treeRender+     , treeWriteImageFile, gtkShowTree+    )++where++import System.IO+import Data.IORef+import System.Cmd+import Graphics.UI.Gtk.Gdk.EventM++import Graphics.Rendering.Cairo hiding (translate)+import Data.Graph.Inductive as G++import Graphics.UI.Sifflet.LittleGtk++import Data.Sifflet.Geometry+import Data.Sifflet.Tree+import Data.Sifflet.TreeGraph+import Data.Sifflet.TreeLayout+import Graphics.Rendering.Sifflet.Draw+import Text.Sifflet.Repr ()++-- ============================================================+-- GRAPH VIEWING AND RENDERING+-- ============================================================++-- Quick view of a graph using GraphViz++graphQuickView :: (Graph g, Show a, Show b) => g a b -> IO ()+graphQuickView g = +    let dot_src = graphviz g "graphQuickView" (6, 4) (1, 1) Portrait+        dot_file = "tmp.dot"+        png_file = "tmp.png"+    in do+      h <- openFile dot_file WriteMode+      hPutStr h dot_src+      hClose h+      _ <- system ("dot -Tpng -o" ++ png_file ++ " " ++ dot_file)+      _ <- system ("feh " ++ png_file)+      return ()+++graphWriteImageFile :: (Repr n) => +                       Style -> Maybe Node -> Maybe Node ->+                       Double -> Double -> +                       LayoutGraph n e -> String -> +                       IO String +graphWriteImageFile style mactive mselected dwidth dheight graph file = do+    withImageSurface FormatARGB32 (round dwidth) (round dheight) $ \surf -> do+      renderWith surf $ +        graphRender style mactive mselected graph+      surfaceWriteToPNG surf file+    return file++graphRender :: (Repr n) => +               Style -> Maybe Node -> Maybe Node -> LayoutGraph n e -> +               Render ()+graphRender style mactive mselected graph = do+  let renderNode :: Node -> Render ()+      renderNode node = do+        let Just layoutNode = lab graph node +            -- ^^ is this safe? it can't be Nothing?+            nodeBB = gnodeNodeBB (nodeGNode layoutNode)+            active = (mactive == Just node)+            selected = case mselected of+                         Nothing -> False+                         Just sel -> sel == node+            mode = if active then DrawActive+                   else if selected then DrawSelectedNode -- !!!+                        else DrawNormal+            xcenter = bbXCenter nodeBB+        draw style mode layoutNode+        connectParent node xcenter (bbTop nodeBB)+        return ()++      connectParent node x y = +        let parents = pre graph node in+            case parents of+              [] -> return ()+              [parent] -> do+                let Just playoutNode = lab graph parent+                    parentBB = gnodeNodeBB (nodeGNode playoutNode)+                    px = bbXCenter parentBB+                    py = bbBottom parentBB+                setColor (styleNormalEdgeColor style)+                moveTo px (py + snd (vtinypad style)) -- bottom of parent+                lineTo x (y - fst (vtinypad style))   -- top of node+                stroke++              _ -> error "Too many parents"+        +  setAntialias AntialiasDefault++  -- canvas background+  setColor (styleNormalFillColor style)+  let Just layoutNode = lab graph 1 -- root node, represents whole tree+      BBox x y bwidth bheight = nodeTreeBB layoutNode+  rectangle x y bwidth bheight+  fill++  -- draw the graph/tree+  setLineWidth (lineWidth style)+  mapM_ renderNode (nodes graph)++treeRender :: (Repr e) => Style -> TreeLayout e -> Render ()+treeRender style = graphRender style Nothing Nothing . orderedTreeToGraph++treeWriteImageFile :: (Repr e) => +  Style -> IoletCounter e -> Tree e -> String -> IO String++treeWriteImageFile style counter atree filename = do+  let tlo = treeLayout style counter atree+      Size surfWidth surfHeight = treeLayoutPaddedSize style tlo+  withImageSurface FormatARGB32 (round surfWidth) (round surfHeight) $ +    \ surf -> do+      renderWith surf $ treeRender style tlo+      surfaceWriteToPNG surf filename+  return filename++-- ============================================================+-- Simple tree viewing.+-- gtkShowTree displays a single tree very simply+-- Works for any kind of (Repr e, Show e) => Tree e.++gtkShowTree :: (Repr e, Show e) => +  Style -> IoletCounter e -> Tree e -> IO ()+gtkShowTree style counter atree = do+  let tlo = treeLayout style counter atree+      Size dwidth dheight = treeLayoutPaddedSize style tlo++  tloRef <- newIORef tlo++  _ <- initGUI++  -- init window+  window <- windowNew+  set window [windowTitle := "Test Cairo Tree"]+  _ <- onDestroy window mainQuit++  -- init vbox+  vbox <- vBoxNew False 5 -- width not homogeneous; spacing+  set window [containerChild := vbox]++  -- init canvas+  canvas <- layoutNew Nothing Nothing+  _ <- onSizeRequest canvas +       (return (Requisition (round dwidth) (round dheight)))+  widgetSetCanFocus canvas True -- to receive key events++  -- event handlers+  _ <- on canvas exposeEvent (updateCanvas style canvas tloRef)+  _ <- on canvas keyPressEvent (keyPress window)++  -- pack, show, and run+  boxPackStartDefaults vbox canvas+  widgetShowAll window+  mainGUI++updateCanvas :: (Repr e) => Style -> Layout -> IORef (TreeLayout e) +             -> EventM EExpose Bool+updateCanvas style canvas tloRef = +    tryEvent $ liftIO $ do+      {       +        tlo <- readIORef tloRef+      ; win <- layoutGetDrawWindow canvas+      ; renderWithDrawable win (treeRender style tlo)+      }++keyPress :: Window -> EventM EKey Bool+keyPress window =+    tryEvent $ do+      {+        kname <- eventKeyName+      ; case kname of+          "q" -> liftIO $ widgetDestroy window  -- implies mainQuit+          _ -> stopEvent+      }

@@ -0,0 +1,30 @@+{- Workspace.hs implements the graphical workspace of Sifflet -}++module Graphics.UI.Sifflet+    (+     module Graphics.UI.Sifflet.Frame+    , module Graphics.UI.Sifflet.LittleGtk+    , module Graphics.UI.Sifflet.RPanel+    , module Graphics.UI.Sifflet.Types+    , module Graphics.UI.Sifflet.Callback+    , module Graphics.UI.Sifflet.Canvas+    , module Graphics.UI.Sifflet.Tool+    , module Graphics.UI.Sifflet.Workspace+    , module Graphics.UI.Sifflet.GtkForeign+    , module Graphics.UI.Sifflet.GtkUtil+    , module Graphics.UI.Sifflet.Window+    )++where++import Graphics.UI.Sifflet.Callback+import Graphics.UI.Sifflet.Canvas+import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.Tool+import Graphics.UI.Sifflet.Workspace+import Graphics.UI.Sifflet.GtkForeign+import Graphics.UI.Sifflet.GtkUtil+import Graphics.UI.Sifflet.LittleGtk+import Graphics.UI.Sifflet.RPanel+import Graphics.UI.Sifflet.Types+import Graphics.UI.Sifflet.Window

@@ -0,0 +1,152 @@+module Graphics.UI.Sifflet.Callback+    (+     CBMgr, CBMgrAction, CBMgrCmd(..), mkCBMgr+    , MenuSpec(..), MenuItemSpec(..), MenuItemAction+    , createMenuBar, addMenu, createMenu, createMenuItem+    , modifyIORefIO+    ) ++where++import Data.IORef++import Graphics.UI.Gtk++import Graphics.UI.Sifflet.Types++-- | The CBMgr (Callback manager) encapsulates (in an enclosure, no less!)+-- an IORef VPUI.  It is used *solely* to set up callbacks+-- and similar stuff in Gtk, where the callback needs access+-- to the IORef.  By passing a CBMgr to a function, we can+-- avoid passing the IORef directly, and all the harm and+-- confusion that could result.+--+-- We only need *one* CBMgr for the application;+-- however, two CBMgrs with the same IORef are logically equivalent,+-- so there would be no harm in having two as long as they share one IORef.+type CBMgr = CBMgrCmd -> IO ()++type CBMgrAction = IORef VPUI -> IO ()++-- | Commands for the CBMgr+data CBMgrCmd+ =  -- window events+    OnWindowConfigure Window (IORef VPUI -> EventM EConfigure Bool)+  | OnWindowDestroy Window CBMgrAction+  | AfterWindowKeyPress Window (IORef VPUI -> EventM EKey Bool)+    -- layout events+  | OnLayoutExpose Layout (IORef VPUI -> EventM EExpose Bool)+  | OnLayoutMouseMove Layout (IORef VPUI -> EventM EMotion Bool)+  | OnLayoutButtonPress Layout (IORef VPUI -> EventM EButton Bool)+  | OnLayoutButtonRelease Layout (IORef VPUI -> EventM EButton Bool)+    -- other events+  | OnMenuItemActivateLeaf MenuItem (VPUI -> IO VPUI)+  | OnEntryActivate Entry CBMgrAction+  | AfterButtonClicked Button CBMgrAction++    -- Surrender the UIRef to an arbitrary action+  | WithUIRef CBMgrAction ++  | UMTest++-- | Create the CBMgr+mkCBMgr :: IORef VPUI -> CBMgr+mkCBMgr uiref cmd = +    case cmd of+      -- window events+      OnWindowConfigure window action ->+          on window configureEvent (action uiref) >> return ()+      OnWindowDestroy window action ->+          onDestroy window (action uiref) >> return ()+      AfterWindowKeyPress window action ->+          after window keyPressEvent (action uiref) >> return ()+      -- layout events+      OnLayoutExpose layout action ->+          on layout exposeEvent (action uiref) >> return ()+      OnLayoutMouseMove layout action ->+          on layout motionNotifyEvent (action uiref) >> return ()+      OnLayoutButtonPress layout action ->+          on layout buttonPressEvent (action uiref) >> return ()+      OnLayoutButtonRelease layout action ->+          on layout buttonReleaseEvent (action uiref) >> return ()+      -- other events+      OnMenuItemActivateLeaf menuItem action ->+          onActivateLeaf menuItem (modifyIORefIO action uiref) >> return ()+      OnEntryActivate entry action ->+         onEntryActivate entry (action uiref) >> return ()+      AfterButtonClicked button action ->+          afterClicked button (action uiref) >> return ()++      -- Not an event at all; the fact that I need this means the+      -- CBMgr concept was misguided!+      WithUIRef action -> action uiref++      UMTest -> +          putStrLn "UMTest"+++-- ============================================================+-- MENUS++-- Easy creation of menus from lists.+-- Originally from ~/src/haskell-etudes/gtk2hs/gMenu.hs++data MenuSpec = MenuSpec String [MenuItemSpec]+data MenuItemSpec = MenuItem String MenuItemAction+                  | SubMenu MenuSpec++type MenuItemAction = VPUI -> IO VPUI -- was just IO ()++createMenuBar :: [MenuSpec] -> CBMgr -> IO MenuBar+createMenuBar menuSpecs cbmgr = do+  bar <- menuBarNew+  mapM_ (addMenu bar cbmgr) menuSpecs+  return bar++addMenu :: MenuBar -> CBMgr -> MenuSpec -> IO ()+addMenu mbar cbmgr mspec@(MenuSpec name _itemSpecs) = do+  menuHead <- menuItemNewWithLabel name -- visible "item" at top of the menu+  menuShellAppend mbar menuHead+  -- Right-justify help menu.+  -- Deprecated (bad for right-to-left languages),+  -- but retained for compatibility with menus_hard.py.+  menuItemSetRightJustified menuHead (name == "Help") -- ??????++  -- menu = the container for menu items+  menu <- createMenu mspec cbmgr+  menuItemSetSubmenu menuHead menu++createMenu :: MenuSpec -> CBMgr -> IO Menu+createMenu (MenuSpec _name itemSpecs) cbmgr = do+  menu <- menuNew+  mapM_ (createMenuItem menu cbmgr) itemSpecs+  return menu++createMenuItem :: Menu -> CBMgr -> MenuItemSpec -> IO ()+createMenuItem menu cbmgr mispec = +    case mispec of+      MenuItem label action ->+          do+            {+              item <- menuItemNewWithLabel label+            ; cbmgr (OnMenuItemActivateLeaf item action)+              -- may need to read/write IORef here ***+            ; menuShellAppend menu item+            }+      SubMenu subspec@(MenuSpec label _itemSpecs) ->+          do+            {+              item <- menuItemNewWithLabel label+            ; submenu <- createMenu subspec cbmgr +            ; menuItemSetSubmenu item submenu+            ; menuShellAppend menu item+            }++-- | Read an IORef, update with IO, and write the updated value.+-- This is like (flip modifyIORef), but the type of the +-- first argument is (a -> IO a) instead of (a -> a).+-- Note that if a = VPUI, then updateIO :: VPUI -> IO VPUI+-- and consequently modifyIORefIO updateIO :: CBMgrAction.++modifyIORefIO :: (a -> IO a) -> IORef a -> IO ()+modifyIORefIO updateIO ref = readIORef ref >>= updateIO >>= writeIORef ref

@@ -0,0 +1,1011 @@+-- File: Canvas.hs+-- Canvas and CanvFrame data and operations++module Graphics.UI.Sifflet.Canvas+    (+      atLeastSize+    , cfContext+    , connect+    , defaultFileSaveClipBox+    , disconnect+    , drawCanvas+    , editFunction+    , frameChanged+    , nodeContainerFrame+    , pointSelection+    , renderCanvas+    , vcAddFrame+    , vcClearSelection+    , vcClearFrame+    , vcCloseFrame+    , vcEvalDialog+    , vcFrameAddFunctoidNode+    , vcFrameAddNode+    , vcFrameDeleteNode+    , vcFrameDeleteTree+    , vcFrameSubframes+    , vcGetFrame+    , vcInvalidateFrameWithParent+    , vcInvalidateBox+    , vcUpdateFrameAndGraph+    , vcanvasNew+    , vcanvasNodeAt+    , vcanvasNodeRect+    , whichFrame +    , callFrames+    )++where++-- debug imports+-- import System.IO.Unsafe++-- standard imports++import Control.Monad+import Data.List as List++import Data.Graph.Inductive as G++import Graphics.Rendering.Cairo hiding (translate)+import qualified Graphics.Rendering.Cairo as Cairo++-- Sifflet imports++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry as Geometry+import Data.Sifflet.Tree as T+import Data.Sifflet.TreeGraph+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+import Language.Sifflet.Parser++import Graphics.Rendering.Sifflet.Draw++import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.GtkUtil+import Graphics.UI.Sifflet.LittleGtk+import Graphics.UI.Sifflet.Types+import Language.Sifflet.Util++-- Experimental:+enableDoubleBuffering :: Bool+enableDoubleBuffering = True++vcanvasNew :: Style -> Double -> Double -> IO VCanvas+vcanvasNew style width height = do+  -- create gtkLayout (the "drawing canvas")+  gtkLayout <- layoutNew Nothing Nothing+  -- Turn double buffering on or off.  +  -- Normally, double buffering eliminates flicker,+  -- but if the rendering is through the network,+  -- it might be better to disable it.+  -- See docs for Graphics.UI.Gtk.Gdk.DrawWindow+  -- (drawWindow{Begin,End}PaintRegion), and+  -- Graphics.UI.Gtk.Abstract.Widget+  -- (widgetSetDoubleBuffered).+  widgetSetDoubleBuffered gtkLayout enableDoubleBuffering++  -- create the VCanvas+  let vCanvas = VCanvas {vcLayout = gtkLayout, vcStyle = style, +                         vcGraph = wgraphNew,+                         vcFrames = [],+                         -- vcSize is the requested size of the+                         -- canvas (Gtk.Layout)+                         vcSize = Size width height,+                         -- but this is the requested size;+                         -- how can I get the actual, current size?+                         -- Answer: +                         -- layoutGetSize :: Layout -> IO (Int, Int)+                         -- removed: vcLocalEnv = env,+                         vcMousePos = (0, 0), -- ???+                         vcTool = Nothing,+                         vcDragging = Nothing,+                         vcActive = Nothing,+                         vcSelected = Nothing++                        }+  -- Most essential event handlers+  _ <- onSizeRequest gtkLayout+       (return (Requisition (round width) (round height)))+  +  return vCanvas++nodeContainerFrame :: VCanvas -> WGraph -> G.Node -> CanvFrame+nodeContainerFrame vcanvas g = vcGetFrame vcanvas g . nodeContainerFrameNode g++-- Ask the VCanvas to find the frame whose frame node element is the+-- given Node; it is an error if not found or if there is more than one.+vcGetFrame :: VCanvas -> WGraph -> Node -> CanvFrame+vcGetFrame vcanvas graph frameNode = +    let frames = [f | f <- vcFrames vcanvas, cfFrameNode f == frameNode]+        err phrase = errcats ["vcGetFrame", phrase,+                              "frameNode:", show frameNode, +                              "\nframes:", show frames,+                              "\ngraph:\n", show graph]+    in case frames of+         [frame] -> frame+         [] -> err "no frame found"+         (_:_:_) -> err "multiple frames found"++-- | Ask the vcanvas to update the frame and install a new graph.+-- Frames are identified  by their frame nodes, so the new frame +-- must have the same frame node as the old.+-- It is an unreported error if there is not exactly one match.+vcUpdateFrameAndGraph :: VCanvas -> CanvFrame -> WGraph -> VCanvas+vcUpdateFrameAndGraph vcanvas newFrame newGraph =+  let frames = vcFrames vcanvas+      frameNode = cfFrameNode newFrame -- should match frameNode of old frame+      frames' = +          [if cfFrameNode f == frameNode then newFrame else f | f <- frames]+  in vcanvas {vcFrames = frames', vcGraph = newGraph}++-- | Like vcUpdateFrameAndGraph, but keep the canvas's old graph.+vcUpdateFrame :: VCanvas -> CanvFrame -> VCanvas+vcUpdateFrame vcanvas newFrame =+    vcUpdateFrameAndGraph vcanvas newFrame (vcGraph vcanvas)++-- Delete a frame from the vcanvas's frames ref+-- This does not update the graph -- see vcCloseFrame for that.+vcDeleteFrame :: VCanvas -> CanvFrame -> VCanvas+vcDeleteFrame vcanvas frame =+  let frames = vcFrames vcanvas+      node = cfFrameNode frame+      frames' = [f | f <- frames, cfFrameNode f /= node]+  in vcanvas {vcFrames = frames'}++-- RENDERING+-- perhaps ought to be its own module++-- Perhaps this ought to be called graphRenderFunctoid! ***++graphRenderFunctoidParts :: +    Style -> Maybe Node -> Maybe Selection -> WGraph -> CanvFrame -> Render ()+graphRenderFunctoidParts style mact msel graph frame = +  case cfFunctoid frame of+    FunctoidFunc _ -> error "graphRenderFunctoidParts: not an edit frame"+    FunctoidParts {} -> +        graphRenderForest style mact msel graph +                          (nodeProperSimpleDescendants graph +                                                       (cfFrameNode frame))++graphRenderForest :: +    Style -> Maybe Node -> Maybe Selection -> WGraph -> [G.Node] -> Render ()+graphRenderForest style mact msel graph roots = +  let renderNode node = graphRenderTree style mact msel graph node False+  in mapM_ renderNode roots++graphRenderTree :: Style -> Maybe Node -> Maybe Selection -> WGraph ->+                   G.Node -> Bool -> Render ()+graphRenderTree style mact msel graph rootNode fillBackground =+    let loop :: Maybe Iolet -> G.Node -> Render ()+        loop mInlet currentNode = do+          -- Render the root+          (inlets, outs) <-+              graphRenderNode style mact msel graph currentNode mInlet+          -- Render the subtrees+          loopWithInlets 0 inlets (sortBy adjCompareEdge outs)+                    +        -- loopWithInlets n inletPositions outs:+        --   n = the current inlet number, starting from 0+        --   inletPositions = the points to connect to on the parent+        --   outs = a list of (child, edge) pairs (adjs)+        --          going to *simple* children (i.e., not frame nodes)+        -- There must be at least as many inlets as there are outs.+        -- If the edge of the first outs equals n, we use the+        -- first inletPosition.  Otherwise we skip the inlet+        -- but not out.+        loopWithInlets :: Int -> [Iolet] -> [(G.Node, WEdge)] -> Render ()+        loopWithInlets _n _is [] = return ()+        loopWithInlets n (i:is) (a:as) =+            -- n: number of child, i: inlet, a: adjacency (node, edge)+            let (node, edge) = a in+            if edge == WEdge n+            then do+              loop (Just i) node -- draw node with current inlet+              loopWithInlets (n + 1) is as -- and draw the rest+            else -- skip current inlet+                loopWithInlets (n + 1) is (a:as) +                +        loopWithInlets n [] (a:as) = +            -- This should not happen, and is deliberately rendered+            -- with a strange look!+            -- This repeats some of graphRenderNode, slightly modified+            let ctx = context graph rootNode+                lnode :: LayoutNode ExprNode+                WSimple lnode = lab' ctx+                bb = gnodeNodeBB (nodeGNode lnode)+                defaultInlet = +                    Iolet (Geometry.Circle+                           (Position (bbXCenter bb) (bbYCenter bb)) 0)+                +            in loopWithInlets n [defaultInlet] (a:as)+    in do+      graphStartRender style graph rootNode fillBackground+      loop Nothing rootNode++graphStartRender :: Style -> WGraph -> G.Node -> Bool -> Render ()+graphStartRender style graph rootNode fillBackground = do+  -- global actions: can be done once for the whole drawing+  -- instead of once per subtree+  -- Choose: Antialias{Default,None,Gray,Subpixel}+  setAntialias AntialiasDefault++  -- draw the canvas background+  setColor (styleNormalFillColor style)+  let rootCtx = context graph rootNode+      WSimple lroot = lab' rootCtx+      BBox x y w' h' = nodeTreeBB lroot+  when fillBackground $ do { rectangle x y w' h'; fill}++  -- now set up for the rest+  -- setColor (styleNormalTextColor style)+  setLineWidth (lineWidth style)+++-- | Render a node.+-- Returns a list of inlets and a list of "outs":+-- a list of (child, edge) pairs (adjs) +-- going to *simple* children only (not to frames formed+-- by expanding a node).+-- This can then be used if we wish to render the children of+-- the node, as when rendering a tree.++graphRenderNode :: +    Style -> Maybe Node -> Maybe Selection -> WGraph ->+    G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)])+graphRenderNode style mact msel graph node mInlet = +  -- status of this node+  let nodeActive = mact == Just node+      mode = if nodeActive+             then DrawActive+             else case msel of+                    Nothing -> DrawNormal+                    Just sel ->+                        if selNode sel /= node then DrawNormal+                        else case sel of+                               SelectionNode _ -> DrawSelectedNode+                               SelectionInlet {selInEdge = WEdge i} ->+                                   DrawSelectedInlet i+                               SelectionOutlet {selOutEdge = WEdge o} ->+                                   DrawSelectedOutlet o+                     +      connectInlet :: Iolet -> Double -> Double -> Render ()+      connectInlet inlet tx ty = do+        -- draw the line from the parent inlet to this node's outlet+        let Position px py = ioletCenter inlet+        setColor (styleNormalEdgeColor style)+        moveTo px (py + snd (vtinypad style)) -- bottom of parent+        lineTo tx (ty - fst (vtinypad style)) -- top of this node+        stroke      ++      ctx = context graph node+      lnode :: LayoutNode ExprNode+      WSimple lnode = lab' ctx++      -- where to connect to this node+      nodeBB = gnodeNodeBB (nodeGNode lnode)+      xcenter = bbXCenter nodeBB+      inlets = gnodeInlets (nodeGNode lnode)+      -- children (nodes and edges)+      outs = lsuc' ctx :: [(G.Node, WEdge)]+      -- omit links to frames opened from a node+      outs' = [(child, edge) |+               (child, edge) <- outs, nodeIsSimple graph child]++      -- Do we need more inlets to match the outs' ?+      deficit = length outs' - length inlets+      -- The default inlet is lifted to the center+      -- to show something is not right!+      defaultInlet = Iolet (Geometry.Circle +                            (Position xcenter (bbYCenter nodeBB)) 0)+      inlets' = if deficit > 0+                then inlets ++ replicate deficit defaultInlet+                else inlets++  in do+    +       -- Render the node+       draw style mode lnode++       -- Connect to its parent (if any)+       case mInlet of+         Nothing -> return ()+         Just inlet -> connectInlet inlet xcenter (bbTop nodeBB) ++       return (inlets', outs')+++-- END OF RENDERING+-- ---------------------------------------------------------------------++-- | Make nothing be selected++vcClearSelection :: VCanvas -> IO VCanvas+vcClearSelection canvas =+  case vcSelected canvas of+    Nothing -> return canvas+    Just sel ->+        let node = selectionNode sel+        in do+          vcInvalidateSimpleNode canvas node+          return (canvas {vcSelected = Nothing})++-- | The Graph Node of a Selection+selectionNode :: Selection -> G.Node+selectionNode sel =+    case sel of+      SelectionNode n -> n+      SelectionInlet n _ -> n+      SelectionOutlet n _ -> n++-- | What is selected (if anything) at a point++pointSelection :: WGraph -> CanvFrame -> Position -> Maybe Selection+pointSelection graph frame point =+    -- Try to find something to select at the point,+    -- i.e., a node or an iolet on the node+    case cfFunctoid frame of+      FunctoidFunc _ -> error "graphFindFunctionPart: not an edit frame"+      FunctoidParts {fpNodes = grNodes} ->+          let layoutNodes = map (grExtractLayoutNode graph) grNodes+              tuples = zip grNodes layoutNodes++              loop :: [(G.Node, LayoutNode ExprNode)] -> Maybe Selection+              loop [] = Nothing+              loop (t:ts) = -- (n:ns) =+                  let (gn, ln) = t -- graph node, tlo node+                      gnode = nodeGNode ln+                      inlets = gnodeInlets gnode+                      outlets = gnodeOutlets gnode+                  in+                    -- look at the ports first,+                    case pointIolet point 0 inlets of+                      Just i ->+                          Just (SelectionInlet gn (WEdge i))+                      Nothing ->+                          case pointIolet point 0 outlets of+                            Just o ->+                                Just (SelectionOutlet gn (WEdge o))+                            Nothing ->+                                -- try in the node proper+                                if pointInGNode point gnode+                                then+                                    Just (SelectionNode gn)+                                else+                                    -- try the remaining tuples+                                    loop ts ++          in loop tuples++-- | Connect nodes++connect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas+connect canvas parent inlet child outlet = do+  -- if parent and child are different,+  -- connect the ith inlet of node parent+  -- to the oth outlet of node child+  -- provided that doing so would not create a cycle+  -- parent -> child -> ... -> parent++  let graph = vcGraph canvas+  if elem parent (reachable child graph)+    then +        do+          showErrorMessage "Sorry, this connection would create a cycle."+          return canvas+    else +        -- now we need to store a labeled edges (inlet -> outlet)+        -- and to clear any previous connections of the two.+        let graph' = grConnect graph parent inlet child outlet+        in return $ canvas {vcGraph = graph'}++-- | Disconnect nodes++-- disconnect wouldn't need to be in the IO monad,+-- except that it needs the same type signature as connect+disconnect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge +           -> IO VCanvas+disconnect canvas parent inlet child outlet = do+  -- Opposite of connect, except we don't have to check for cycles+  -- of any kind.  We also reconnect the child to the frame node+  -- as its "parent."+  let graph = vcGraph canvas+      graph' = grDisconnect graph parent inlet child outlet True+  return $ canvas {vcGraph = graph'}++vcFrameAddFunctoidNode :: +    VCanvas -> CanvFrame -> Functoid -> Double -> Double -> IO VCanvas+vcFrameAddFunctoidNode canvas frame nodeFunc x y = +  let exprNode = ENode (NSymbol (Symbol (functoidName nodeFunc))) EvalUntried+      args = functoidArgNames nodeFunc+  in vcFrameAddNode canvas frame exprNode args x y++vcFrameAddNode :: VCanvas -> CanvFrame -> ExprNode -> [String] +               -> Double -> Double -> IO VCanvas+vcFrameAddNode canvas frame exprNode inletLabels x y =+  case cfFunctoid frame of+    FunctoidFunc _function -> +        error "vcFrameAddNode: frame is not an edit frame"+    fp@FunctoidParts {fpNodes = ns} -> +        do+          let -- Converting to a tree to lay it out seems overkill--+              exprTree = T.Node exprNode []+              style = styleIncreasePadding (vcStyle canvas) 10+              counter = argIoletCounter inletLabels+              layoutTree = treeLayout style counter exprTree++          let graph = vcGraph canvas+              layoutTree' = layoutTreeMoveCenterTo x y layoutTree+              layoutRoot = rootLabel layoutTree'+              newNode = WSimple layoutRoot+              -- insert into graph+              (graph', gNodeId) = grInsertNode graph newNode+              frameNode = cfFrameNode frame+              edge = (frameNode, gNodeId, WEdge (outdeg graph frameNode + 1))+              graph'' = insEdge edge graph'+              -- insert into the fpNodes+              ns' = (gNodeId:ns)+              fp' = fp {fpNodes = ns'}++              {-+              -- DON'T!+              -- Adjust header and footer for new body size++              -- BUT: IS THERE ANYTHING HERE THAT I SHOULD KEEP+              -- WHEN I MAKE FRAMES KEEP A MINIMUM SIZE TO FIT+              -- THE LAYOUT OF THEIR BODIES?++              layoutNodes = map (grExtractLayoutNode graph') ns'+              bodyBB = -- layoutTreeBB layoutTree'+                bbMergeList (map nodeTreeBB layoutNodes)+              header' = alignHeader (cfHeader frame) bodyBB+              footer' = alignFooter (cfFooter frame) bodyBB+              -- grow box to fit new node+              box' = bbMergeList [tbBoxBB header', tbBoxBB footer', bodyBB]+              -- insert into frame+              frame' = frame {cfHeader = header',+                              cfFooter = footer',+                              cfBox = box', +                              cfFunctoid = fp'}+               -}+              frame' = frame {cfFunctoid = fp'}++              -- store new frame and graph into canvas+              canvas' = vcUpdateFrameAndGraph canvas frame' graph''++          -- Ready to redraw+          frameChanged canvas graph frame graph'' frame' ++          return canvas'++vcFrameDeleteNode :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas+vcFrameDeleteNode canvas frame node = +  let -- Remove the graph node from the frame and canvas,+      -- giving its orphaned children the frame as their new parent+      graph = vcGraph canvas+      frameNode = cfFrameNode frame+      children = nodeAllChildren graph node+      -- Remove node from graph+      graph' = grRemoveNode graph node+      -- Frame adopts orphans+      graph'' = foldl (\ g child -> connectToFrame child frameNode g) +                      graph' +                      children+      -- Remove node from funcparts+      fp@FunctoidParts {fpNodes = ns} = cfFunctoid frame+      fp' = fp {fpNodes = List.delete node ns}+      frame' = frame {cfFunctoid = fp'}+      +      -- Update references+      canvas' = vcUpdateFrameAndGraph canvas frame' graph''+  in do+    -- Ask to be redrawn+    frameChanged canvas graph frame graph'' frame'+    return canvas'++-- | Remove the (sub)tree rooted at the given node.+-- Removes it from the graph of the canvas+-- and from the FunctoidParts of the frame.+vcFrameDeleteTree :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas+vcFrameDeleteTree canvas frame rootNode = ++  let removeTree :: (WGraph, [G.Node]) -> G.Node -> (WGraph, [G.Node])+      removeTree (g, ns) root =+          let g' = grRemoveNode g root+              ns' = List.delete root ns+          in foldl removeTree (g', ns') (nodeAllChildren g root)+      +      graph = vcGraph canvas+      fp@FunctoidParts {fpNodes = fnodes} = cfFunctoid frame+      (graph', fnodes') = removeTree (graph, fnodes) rootNode+      frame' = frame {cfFunctoid = fp {fpNodes = fnodes'}}+      +      -- Update references+      canvas' = vcUpdateFrameAndGraph canvas frame' graph'+  in do+    -- Ask to be redrawn+    frameChanged canvas graph frame graph' frame'+    return canvas'+++-- | Add a frame representing a functoid to the canvas.+--+-- Use mvalues = Nothing if you do not want the frame to be evaluated+-- as a function call, otherwise mvalues = Just values.+-- +-- prevEnv is *supposed* to be the previous environment, +-- i.e., that of the+-- "parent" frame or the canvas, not of the new frame,+-- because vcAddFrame itself will extend the environment+-- with the new (vars, values).+-- But this is odd, because openNode calls vcAddFrame +-- apparently with the *new* environment as prevEnv,+-- and yet it works correctly.+--+-- Caution: I think it is necessary for the canvas to have been realized+-- before calling this function!++vcAddFrame :: VCanvas -> Functoid -> Maybe [Value] -> FrameType+           -> Env -> Double -> Double -> Double -> Maybe G.Node +           -> IO VCanvas+vcAddFrame canvas functoid mvalues mode prevEnv x y z mparent = do+  let graph = vcGraph canvas+      (_, hi) = nodeRange graph+      frameNode = hi + 1 -- implicit: root = hi + 2+      style = vcStyle canvas+      (newFrame, tlo) = frameNewWithLayout style (Position x y) z +                            functoid mvalues +                            CallFrame -- mode may change below+                            frameNode prevEnv mparent+      inAdj = case mparent of+                Nothing -> []+                Just parent -> +                    -- Adjacency (priority, parent)+                    [(WEdge (outdeg graph parent), parent)]+      -- add the new frame node, possibly linked to its parent,+      -- and the tree of the new frame+      graph' = grAddGraph +                ((inAdj, frameNode, WFrame frameNode, []) & graph)+                (flayoutToGraph tlo)+      -- connect the frame to the tree-layout roots+      layoutRoots = map (+ frameNode) (flayoutToGraphRoots tlo)+      outEdges = [(frameNode, root, WEdge priority) | +                (priority, root) <- zip [0..] layoutRoots]+      graph'' = insEdges outEdges graph'+      -- update the frames and the graph in the canvas+      frames = vcFrames canvas++      canvas' = canvas {vcFrames = (newFrame:frames)+                       , vcGraph = graph''}++      -- Make sure canvas is big enough to contain newFrame+      -- This is also done when the window is resized+      -- (../Callbacks.hs: configuredCallback).++      frameBB = cfBox newFrame+      canvas'' = +          atLeastSize (Size (bbRight frameBB) (bbBottom frameBB)) canvas'++  -- Request redraw of the region, including tether to parent, if any+  -- error occurs here if the widget is not yet realized, I think+  vcInvalidateFrameWithParent canvas graph'' newFrame+  case mode of+    CallFrame -> return canvas''+    EditFrame -> editFunction canvas'' newFrame ++-- | Return a canvas of at least the specified size+-- and otherwise like the given canvas.+atLeastSize :: Size -> VCanvas -> VCanvas+atLeastSize minSize@(Size minW minH) canvas =+    let Size w h = vcSize canvas+        frames = vcFrames canvas+        frames' = if canvasEditing canvas+                  then -- only one frame, expand it to fill desired size+                      [atLeastSizeFrame minSize (head frames)]+                  else frames+    in canvas {vcSize = Size (max w minW) (max h minH), vcFrames = frames'}++vcInvalidateFrameWithParent :: VCanvas -> WGraph -> CanvFrame -> IO ()+vcInvalidateFrameWithParent vcanvas graph frame =+    -- "Invalidate" the frame itself, and if it has a parent,+    -- the region between it and its parent, so that the frame+    -- and its tether will be redrawn+    let box1 = cfBox frame+        box2 = +            case cfParent frame of+              Just parent -> bbMerge (nodeBBox graph parent) box1+              Nothing -> box1+    in vcInvalidateBox vcanvas box2++vcInvalidateSimpleNode :: VCanvas -> G.Node -> IO ()+vcInvalidateSimpleNode vcanvas node = +    -- For WSimple nodes --+    -- Similarly, invalidate the node itself +    -- (but not yet its parent (if any))+    case wlab (vcGraph vcanvas) node of+      WFrame _ -> error "vcInvalidateSimpleNodeWithParent: node is not simple"+      WSimple layoutNode ->+          vcInvalidateBox vcanvas (gnodeNodeBB (nodeGNode layoutNode))++vcInvalidateBox :: VCanvas -> BBox -> IO ()+vcInvalidateBox vcanvas (BBox x y width height) = +    -- take into account the line width of the box as drawn+    -- and the radius of Iolets.  We'll do this even+    -- though frames do not have Iolets on their edges!+    -- This is also a little broader than necessary even for+    -- WSimple nodes, since the Iolets are on top and bottom,+    -- not on the side.+  let style = vcStyle vcanvas+      t = lineWidth style + styleIoletRadius style+      rect = bbToRect (BBox (x - t) (y - t) +                       (width + 2 * t) (height + 2 * t))      +  in do+    win <- layoutGetDrawWindow (vcLayout vcanvas)+    drawWindowInvalidateRect win rect False++frameChanged :: +    VCanvas -> WGraph -> CanvFrame -> WGraph -> CanvFrame -> IO ()+frameChanged vcanvas g f g' f' = +    -- (graph g, frame f) has been replaced by (g', f')+    do+      vcInvalidateFrameWithParent vcanvas g f -- old+      vcInvalidateFrameWithParent vcanvas g' f' -- new++-- MORE RENDERING+-- ---------------------------------------------------------------------++-- | Draw the canvas in its window, on screen+drawCanvas :: VCanvas -> Rectangle -> IO ()+drawCanvas canvas cliprect = do+  drawWin <- layoutGetDrawWindow (vcLayout canvas)+  renderWithDrawable drawWin $ renderCanvas canvas (bbFromRect cliprect) False++-- | Render the canvas in Cairo +-- (use with renderWith to provide an alternate surface, such as+-- an SVG file).++renderCanvas :: VCanvas -> BBox -> Bool -> Render ()+renderCanvas canvas clipbox translateClip =+    -- alternatively match {eventRegion = region}, from which you can get a+    -- list of rectangles++    let graph = vcGraph canvas+        mactive = vcActive canvas+        mselected = vcSelected canvas+        frames = vcFrames canvas+        Size w h = vcSize canvas+        style = vcStyle canvas++        setClip (BBox x y width height) = do+            rectangle x y width height+            clip++        drawBackground = do+            setColor (ColorRGB 0.4 0.4 0.4)+            rectangle 0 0 w h+            fill++        renderFrame frame = +          case frameType frame of+            EditFrame -> renderEditFrame frame+            CallFrame -> renderCallFrame frame++        renderEditFrame frame = do+            renderFrameHeader frame+            --   renderFrameFooter frame+            -- the body:+            setAntialias AntialiasDefault+            setColor (styleNormalFillColor style)+            drawBox (Just (styleNormalFillColor style)) Nothing +                        (frameBodyBox frame)+            -- now draw the nodes, if any:+            graphRenderFunctoidParts style mactive mselected graph frame+            renderFrameBorder frame+        -- end renderEditFrame++        renderCallFrame frame = do+            let frameRoot = cfRoot frame+                -- Just (WSimple _) = lab graph frameRoot -- can't be WFrame!+                -- BBox x y width height = nodeTreeBB layoutNode++            -- draw tether from parent (if any)+            -- drawTether (nodeParent graph (cfFrameNode frame)) frame+            fancyTether (nodeParent graph (cfFrameNode frame)) frame++            -- render the graph -- requires the graph, which is *not*+            -- in the frame!  That's why this is not a "frame method".+            graphRenderTree style mactive mselected graph frameRoot True++            -- render the header and footer+            -- MAYBE do this before the tether?+            -- Footer needs to be drawn after body+            -- in case the frame is resized too small+            renderFrameHeader frame+            renderFrameFooter frame        +            renderFrameBorder frame+        -- end renderCallFrame++        renderFrameHeader frame = drawtb cream black black (cfHeader frame)++        renderFrameFooter frame =+          drawtb cream black +                 (if cfEvalReady frame +                  then lightBlue +                  else styleAuxColor style)+                 (cfFooter frame)++        renderFrameBorder frame = drawBox Nothing (Just black) (cfBox frame)+        drawtb bgcolor framecolor textcolor tbox = +          drawTextBox (Just (styleFont style)) +                      (Just bgcolor) +                      (Just framecolor) +                      textcolor tbox+          +--         plainTether :: Maybe G.Node -> CanvFrame -> Render ()+--         plainTether Nothing _ = return ()+--         plainTether (Just parent) frame = +--           let pb = nodeBBox graph parent+--               fb = cfBox frame+--               line f1 f2 = do+--                       moveTo (f1 pb) (f2 pb) +--                       lineTo (f1 fb) (f2 fb)+--           in do+--               -- outline the frame's parent+--               drawBox Nothing (Just (styleTetherColor style)) pb+--               -- draw tether lines+--               setColor (styleTetherColor style)+--               line bbLeft bbTop+--               line bbLeft bbBottom+--               line bbRight bbTop+--               line bbRight bbBottom+--               stroke++        fancyTether :: Maybe G.Node -> CanvFrame -> Render ()+        fancyTether Nothing _ = return ()+        fancyTether (Just parent) frame = +          let pb = nodeBBox graph parent+              fb = cfBox frame+              side f1 f2 f3 f4 =+                  do+                    newPath+                    moveTo (f1 pb) (f2 pb)+                    lineTo (f1 fb) (f2 fb)+                    lineTo (f3 fb) (f4 fb)+                    lineTo (f3 pb) (f4 pb)+                    closePath+                    fill+          in do+              -- outline the frame's parent+              drawBox Nothing (Just (styleTetherColor style)) pb+              -- draw tether lines+              setColor (styleTetherColor style)+              side bbLeft bbTop bbRight bbTop+              side bbRight bbTop bbRight bbBottom+              side bbRight bbBottom bbLeft bbBottom+              side bbLeft bbBottom bbLeft bbTop+        -- end fancyTether++     -- end of let decls in renderCanvas+     +     -- main body of renderCanvas+     in do+        when translateClip+             (Cairo.translate (- (bbX clipbox)) (- (bbY clipbox)))+        setClip clipbox+        drawBackground+        -- sorting is a possible bottleneck?  +        mapM_ renderFrame (sortBy levelOrder frames)++defaultFileSaveClipBox :: VCanvas -> BBox+defaultFileSaveClipBox canvas =+    let bboxes = map cfBox (vcFrames canvas)+        BBox x1 y1 w1 h1 = bbMergeList bboxes -- contains all frames+        pad = exomargin (vcStyle canvas)+    in BBox (x1 - pad) (y1 - pad) (w1 + 2 * pad) (h1 + 2 * pad)++-- | Find the node, if any, at a given position on the canvas.+vcanvasNodeAt :: VCanvas -> Position -> Maybe G.Node+vcanvasNodeAt vcanvas point =+  +  -- searchFrames could be done with the Maybe monad, I guess+  let searchFrames :: [CanvFrame] -> Maybe G.Node+      searchFrames [] = Nothing+      searchFrames (f:fs) =+          case frameNodeAt f (vcGraph vcanvas) point of+            Nothing -> searchFrames fs+            Just node -> Just node+  +  in  searchFrames (vcFrames vcanvas)+      ++vcanvasNodeRect :: VCanvas -> G.Node -> Rectangle+vcanvasNodeRect vcanvas node =+    let Just (WSimple layoutNode) = lab (vcGraph vcanvas) node+    in bbToRect (gnodeNodeBB (nodeGNode layoutNode))++whichFrame :: VCanvas -> Double -> Double -> Maybe CanvFrame+whichFrame vcanvas x y = +  -- Find the frame, if any, in which (x, y) occurs.+  -- If there's more than one match, we should return the+  -- one "on top" or at the highest level -- this is not yet implemented.+  let frames = vcFrames vcanvas+      inFrame position = pointInBB position . cfBox+      matches = filter (inFrame (Position x y)) frames+  in case matches of+       [] -> Nothing+       [m1] -> Just m1+       (m1:_:_) -> +           -- multiple frames match, so here needs some additional work+           Just m1++-- | editFunction: reverse of defineFunction: replace the call frame by+-- an edit frame; does not change the VPUI (global env.), just the canvas..+editFunction :: VCanvas -> CanvFrame -> IO VCanvas+editFunction canvas frame = +  case frameType frame of+    EditFrame -> +        return canvas+                +    CallFrame ->+        let FunctoidFunc function = cfFunctoid frame+            parts = functionToParts function (vcGraph canvas) +                    (cfFrameNode frame)+            frame' = frame {cfFunctoid = parts, frameType = EditFrame}+            -- Make the frame fill the canvas.+            frame'' = atLeastSizeFrame (vcSize canvas) frame'+        in return $ vcUpdateFrame canvas frame''++-- | Find a frame's subframes, i.e., those that were expanded+-- to trace the execution of a function call.+-- Cannot be in an edit frame.+vcFrameSubframes :: VCanvas -> CanvFrame -> [CanvFrame]+vcFrameSubframes canvas frame =+    let graph = vcGraph canvas+        subframeNodes = +            case frameType frame of+              EditFrame -> []+              CallFrame -> grTreeSubframeNodes graph (cfRoot frame)+    in map (vcGetFrame canvas graph) subframeNodes+++-- | Given a graph with a rooted tree, collect list of "subframes,"+-- i.e., frames that are children of nodes in the tree+grTreeSubframeNodes :: WGraph -> G.Node -> [G.Node]+grTreeSubframeNodes g root =+    nodeFrameChildren g root ++ +    concatMap (grTreeSubframeNodes g) (nodeSimpleChildren g root)++vcEvalDialog :: VCanvas -> CanvFrame -> IO VCanvas+vcEvalDialog canvas frame =+  let FunctoidFunc function = cfFunctoid frame -- FunctoidParts shouldn't happen+      varnames = cfVarNames frame+  in if null varnames+     then evalFrame canvas frame [] -- skip dialog, no inputs+     else let argDefault env arg = +                  case envLookup env arg of+                    Nothing -> ""+                    Just v -> repr v+              defaults = map (argDefault (cfEnv frame)) varnames++              reader :: Reader [String] [Value]+              reader inputs = parseTypedInputs3 inputs varnames +                              (functionArgTypes function)+          in do+            dialog <- +                createEntryDialog "Input Values" varnames defaults reader (-1)+            result <- runEntryDialog dialog+            case result of+              Nothing -> return canvas+              Just values -> evalFrame canvas frame values++-- | Evaluate the frame, having gotten a list of values from the dialog++evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas+evalFrame canvas frame values = do+  -- Close subframes (those that were made by+  -- expanding a node of this frame)+  canvas' <- vcCloseSubframes canvas frame++  -- Re-evaluate expression tree and update display+  let graph = vcGraph canvas'++      -- Pop the current frame's values, if any, before+      -- extending with the new values.+      -- A frame with no values has a dummy extension,+      -- so this is still okay.+      frameNode = cfFrameNode frame+      -- It's a call frame, so it has a root+      root = cfRoot frame+      style = vcStyle canvas'+      headerTB = cfHeader frame++      -- The tlo may *change*, since showing values may require+      -- extra space.++      (frame', tlo') = frameNewWithLayout style +                       (bbPosition (tbBoxBB headerTB))+                       (cfLevel frame)+                       (cfFunctoid frame) (Just values) CallFrame+                       frameNode +                       (envPop (cfEnv frame))+                       Nothing++  -- Since the frame is a call frame, we should have a tree tlo.++  case tlo' of+    FLayoutTree _t ->+        do+          -- update the tree in the graph+          let graph' = grUpdateFLayout graph [root] tlo'+              canvas'' = vcUpdateFrameAndGraph canvas' frame' graph'+                                 +          -- request redrawing of old and new areas+          frameChanged canvas' graph frame graph' frame'+          +          return canvas''++    FLayoutForest _f _b ->+        error "vcEvalDialog: finishDialog: tlo is not a tree"++-- WORK HERE ***+-- This will be a lot like vcEvalDialog, except we are *un*-evaluating.+-- :-(++-- | vcClearFrame - clear a frame in a canvas; not yet implemented+-- What does this mean?++vcClearFrame :: VCanvas -> CanvFrame -> IO VCanvas+vcClearFrame canvas _frame = +  showInfoMessage "Sorry" "Stub: vcClear is not yet implemented" >>+  return canvas++-- | Close a frame and any subframes of it++vcCloseFrame :: VCanvas -> CanvFrame -> IO VCanvas+vcCloseFrame canvas frame = do+  -- close any subframes of this frame+  canvas' <- vcCloseSubframes canvas frame++  -- remove it from the frames list+  let canvas'' = vcDeleteFrame canvas' frame++      -- remove it and its edges from the graph+      graph = vcGraph canvas''+      graph' = delNodes (allDescendants graph (cfFrameNode frame)) graph+      canvas''' = canvas'' {vcGraph = graph'}++  -- graphically invalidate the region of the frame+  -- and its tether (i.e., to its parent)+  -- (yes, using the *old* vcanvas, graph, and frame)++  vcInvalidateFrameWithParent canvas (vcGraph canvas) frame+  return canvas'''++-- | Close any subframes of the frame, but not the frame itself+vcCloseSubframes :: VCanvas -> CanvFrame -> IO VCanvas+vcCloseSubframes canvas frame =+  foldM vcCloseFrame canvas (vcFrameSubframes canvas frame)+++cfContext :: CanvFrame -> ToolContext+cfContext frame =+   case frameType frame of+     EditFrame -> TCEditFrame frame+     CallFrame -> TCCallFrame frame++-- | Is our canvas editing a function?+canvasEditing :: VCanvas -> Bool+canvasEditing canvas =+    case vcFrames canvas of+      [oneFrame] -> frameType oneFrame == EditFrame+      _ -> False++-- | Find the frames that are calling the named function+callFrames :: VCanvas -> String -> [CanvFrame]+callFrames canvas funcName =+    let isCaller frame = functoidName (cfFunctoid frame) == funcName+    in filter isCaller (vcFrames canvas)

@@ -0,0 +1,332 @@+-- | A "panel" to be shown on the Function Editor, for adjusting the+-- arguments of the function being edited -- adding and deleting arguments,+-- or modifying their "kind" (number of inlets, needed for higher order+-- functions)++module Graphics.UI.Sifflet.EditArgsPanel+    (+     ArgSpecAction+    , EditArgsPanel+    , makeEditArgsPanel+    , editArgsPanelRoot+    , expandToFit+    )++where++import Data.IORef++import Graphics.UI.Gtk (EventBox, hButtonBoxNew, +                        containerRemove,+                        ButtonBoxClass, buttonActivated,+                        widgetGetParent,+                        widgetQueueResize)++import Language.Sifflet.Expr+import Graphics.UI.Sifflet.Callback+import Graphics.UI.Sifflet.LittleGtk+import Language.Sifflet.Util (SuccFail(..), parseInt)++type ArgSpecAction = [ArgSpec] -> IO ()++type PanelRoot = EventBox++data EditArgsPanel = +    EditArgsPanel {editArgsPanelRoot :: PanelRoot,+                   editArgsPanelAction :: ArgSpecAction}++type StateRef = IORef State++data State = State Model UI++newtype Model = Model [ArgSpec]+           deriving (Show)++data UI = UI PanelRoot Table Label [ArgRow]++data ArgRow = ArgRow Entry Entry Button+++-- | Create an EditArgsPanel+-- It currently returns a EditArgsPanel object, +-- and you can put the root of it into a container, e.g.,+--     set window [containerChild := editArgsPanelRoot panel]++-- I think it needs to return some more information than this, though,+-- and maybe know about its parent or larger context, so that when+-- applied, it can have a "global" effect.+-- Maybe just in the form of IO () actions, though.+-- +-- It has this structure (for n existing arguments):++-- EventBox ( = editArgsPanelRoot panel)+-- +----------------------------------++-- | Frame                            |+-- | +------------------------------+ |+-- | | VBox                         | |+-- | | +--------------------------+ | |+-- | | | Table (n+2 rows)x(3 cols)| | |+-- | | | +----------------------+ | | |+-- | | | |                      | | | |+-- | | | | (arguments)          | | | |+-- | | | +----------------------+ | | |+-- | | |                          | | |+-- | | | HButtonBox               | | |+-- | | | +----------------------+ | | |+-- | | | | (buttons)            | | | |+-- | | | +----------------------+ | | |+-- | | |                          | | |+-- | | | Label                    | | |+-- | | | +----------------------+ | | |+-- | | | | (status messages)    | | | |+-- | | | +----------------------+ | | |+-- | | +--------------------------+ | |+-- | +------------------------------+ |+-- +----------------------------------+++makeEditArgsPanel :: CBMgr -> [ArgSpec] -> ArgSpecAction+                  -> IO EditArgsPanel+makeEditArgsPanel cbMgr argSpecs okayAction = do+  root <- eventBoxNew         -- needed for everything to be visible!+  frame <- frameNew+  frameSetLabel frame "Edit Arguments"++  let panel = EditArgsPanel {editArgsPanelRoot = root,+                             editArgsPanelAction = okayAction}++  vbox <- vBoxNew False 5 -- non-homogeneous sizes,  5 pixels separation++  -- Create a table of n + 2 rows x 3 cols, non-homogeneous sizes+  table <- tableNew (length argSpecs + 2) 3 False +  status <- labelNew Nothing++  stateRef <- newIORef (State (Model argSpecs) (UI root table status []))+  dressTable stateRef++  btnBox <- hButtonBoxNew+  fillButtonBox cbMgr btnBox stateRef panel++  containerAdd root frame+  containerAdd frame vbox+  boxPackStartDefaults vbox table+  boxPackStartDefaults vbox btnBox+  boxPackStartDefaults vbox status++  widgetShowAll root+  return panel++-- | Fill the table with rows for each argument in the model and more++dressTable :: StateRef -> IO ()+dressTable sref = do+  -- read state+  State (Model args) ui@(UI root table status _rows) <- readIORef sref++  -- add "headings"+  argLabel <- labelNew (Just "Name")+  inputsLabel <- labelNew (Just "Inlets")+  tableAttachCell table argLabel 0 0+  tableAttachCell table inputsLabel 0 1++-- add rows for existing and new arguments+  let n = length args+  argRows <- mapM (uncurry (argRowNew sref)) +                  (zip (args ++ [ArgSpec "" 0]) [0 .. n])+  mapM_ (uncurry (attachRow table)) +        (zip argRows [1 .. n + 1])+  setStatusOK ui+  widgetShowAll table++  -- write state+  writeIORef sref (State (Model args) (UI root table status argRows))+++-- | Resize a widget to be at least as big as a(nother) widget.+-- Normally the widget being resized is one that contains the other.++expandToFit :: (WidgetClass v, WidgetClass w) => v -> w -> IO ()+expandToFit container widget = do+  Requisition w1 h1 <- widgetSizeRequest container+  Requisition w2 h2 <- widgetSizeRequest widget+  let (w, h) = (max w1 w2, max h1 h2)+  widgetSetSizeRequest container w h+  widgetQueueResize container++-- | Remove from table and destroy all arg rows+-- (does not alter model)++stripTable :: StateRef -> IO ()+stripTable sref = do+  State model ui@(UI root table status _rows) <- readIORef sref+  let stripWidget widget = +          do+            containerRemove table widget+            widgetDestroy widget++  widgets <- containerGetChildren table+  mapM_ stripWidget widgets+  -- Why is this /not/ equivalent to above two statements?+  --   liftM (mapM_ stripWidget) (containerGetChildren table)+  setStatusOK ui++  writeIORef sref (State model (UI root table status []))++attachRow :: Table -> ArgRow -> Int -> IO ()+attachRow table (ArgRow nameEntry nEntry btn) nrow = do+  tableAttachCell table nameEntry nrow 0+  tableAttachCell table nEntry nrow 1+  tableAttachCell table btn nrow 2++-- | Attach a widget to a table in a single cell, specified by its+-- row column (top lef = 0 0) coordinates++tableAttachCell :: (WidgetClass w) => Table -> w -> Int -> Int -> IO ()+tableAttachCell t w top left = +    tableAttachDefaults t w left (left + 1) top (top + 1)+++fillButtonBox :: (ButtonBoxClass b) => +                 CBMgr -> b -> StateRef -> EditArgsPanel -> IO ()+fillButtonBox cbMgr btnBox sref panel = +    let addButton (label, action) = do+          b <- buttonNewWithLabel label+          containerAdd btnBox b+          --   on b buttonActivated action+          cbMgr (AfterButtonClicked b action)                   +        addButton' label action = do+          b <- buttonNewWithLabel label+          containerAdd btnBox b+          _ <- on b buttonActivated action+          return ()++        applyAction :: IO ()+        applyAction = applyArgRows sref (editArgsPanelAction panel)++        okayAction = +            applyAction >> closePanel panel++    in do+      -- addButton' "OK" (cbMgr (WithUIRef okayAction))+      addButton' "OK" okayAction+      mapM_ addButton [+                       -- ("Strip", \ _ -> stripTable sref),+                       -- ("Dress", \ _ -> dressTable sref),+                       ("Cancel", \ _ -> closePanel panel)]++-- | Close (destroy) the panel.+-- I hope this also removes it from its parent.++closePanel :: EditArgsPanel -> IO ()+closePanel panel = widgetDestroy (editArgsPanelRoot panel)++-- | Create a new ArgRow+argRowNew :: StateRef -> ArgSpec -> Int -> IO ArgRow+argRowNew sref (ArgSpec name inlets) n = do+  e1 <- makeEntry name+  e2 <- makeEntry (show inlets)+  -- Create and set up button+  let (label, action) = +          case name of+            "" -> ("Add", addArg sref n)+            _ -> ("Remove", removeArg sref n)+  b <- buttonNewWithLabel label+  _ <- on b buttonActivated action+  return (ArgRow e1 e2 b)++-- | Add a new argument, nth in the model, from the (n+1)th row in the table++-- Still to do: make sure the name is non-blank, and doesn't duplicate+-- an existing argument (or global variable??)+-- and is a valid symbol name (not a number, etc.)?++addArg :: StateRef -> Int -> IO ()+addArg sref n = do+  State (Model argSpecs) ui@(UI root _table _status argRows) <- readIORef sref+  readResult <- readArgRow (argRows !! n)++  case readResult of++    Succ argTool -> +        do+          writeIORef sref (State (Model (argSpecs ++ [argTool])) ui)+          stripTable sref+          dressTable sref+          -- Make sure the container (layout) is big enough +          -- to show the enlarged panel+          mparent <- widgetGetParent root+          case mparent of+            Nothing -> return ()       -- shouldn't happen+            Just parent -> expandToFit parent root+          setStatusOK ui++    Fail msg -> setStatus ui $ "Add: " ++ msg++readArgRow :: ArgRow -> IO (SuccFail ArgSpec)+readArgRow (ArgRow e1 e2 _) = do+  name <- entryGetText e1+  case name of+    "" -> return $ Fail "blank name is not allowed"+    _ -> do+      inletsStr <- entryGetText e2+      return $ case parseInt ("Inlets for " ++ name) inletsStr of+                 Succ inlets -> Succ (ArgSpec name inlets)+                 Fail msg -> Fail msg++-- | Remove an argument, nth in the model, (n+1)th row in the table+removeArg :: StateRef -> Int -> IO ()+removeArg sref n = do+  State (Model argSpecs) ui <- readIORef sref+  writeIORef sref (State (Model (listRemove argSpecs n)) ui)+  stripTable sref+  dressTable sref+  setStatusOK ui++-- | Remove the nth element of a list (0 is the head)+listRemove :: [a] -> Int -> [a]+listRemove [] _ = error "listRemove: empty"+listRemove (_:xs) 0 = xs+listRemove (x:xs) n = x : (listRemove xs (n - 1))++makeEntry :: String -> IO Entry+makeEntry text = do+  entry <- entryNew+  entrySetText entry text+  return entry++applyArgRows :: StateRef -> ArgSpecAction -> IO ()+applyArgRows sref action = do+  State _model ui@(UI _root _table _status argRows) <- readIORef sref+  readResult <- readArgRows argRows+  case readResult of+    Succ newSpecs -> +        do+          setStatusOK ui+          writeIORef sref (State (Model newSpecs) ui)+          action newSpecs+    Fail msg ->+        setStatus ui ("Apply: " ++ msg) >> +        return ()+++-- Use a monad transformer or "lift" here???++readArgRows :: [ArgRow] -> IO (SuccFail [ArgSpec])+readArgRows [] = return (Succ []) -- shouldn't happen!+readArgRows (_:[]) = return (Succ []) -- last row is for the "add" button+readArgRows (row:rows) = do+  results <- readArgRows rows+  case results of+    Fail msg -> return $ Fail msg+    Succ specs -> +        do+          result <- readArgRow row+          case result of+            Fail msg -> return $ Fail msg+            Succ spec -> return $ Succ (spec:specs)+   +setStatusOK :: UI -> IO ()+setStatusOK ui = setStatus ui ""+           +setStatus :: UI -> String -> IO ()+setStatus (UI _ _ status _) msg = +    labelSetText status msg

@@ -0,0 +1,307 @@+module Graphics.UI.Sifflet.Frame+    (+     CanvFrame(..), FrameType(..)+    , argIoletCounter+    , atLeastSizeFrame+    , cfEvalReady+    , cfPointInHeader+    , cfPointInFooter+    , cfRoot+    , frameNewWithLayout+    , frameBodyBox+    , frameNodeAt+    , frameOffset+    , levelOrder+    , nodeCompoundFunction+    , pointIolet+    , resizeFrame+    , translateFrame+    , grTranslateFrameNodes+    )++where++import Data.Function+import Data.List++import Data.Graph.Inductive as G++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph+import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+import Language.Sifflet.Util++-- ---------------------------------------------------------------------+-- CanvFrame operations+-- ---------------------------------------------------------------------+++-- | A CanvFrame represents (indirectly, through cfRoot, and we+-- access to the graph which is provided by the VCanvas)+-- a "subgraph" such as the expression tree+-- of a function which is being edited or called.++data CanvFrame = CanvFrame {+      cfHeader :: TextBox       -- ^ top area of the frame+    , cfFooter :: TextBox       -- ^ bottom area+    , cfVarNames :: [String]    -- ^ variable (parameter) names+    , cfParent :: Maybe G.Node  -- ^ the node opened to make this frame+    , cfFrameNode :: G.Node     -- ^ this frame as a node in the graph;+                                --   also serves as the ID of the frame.+    , cfEnv :: Env              -- ^ environment for evaluation+    , cfBox :: BBox -- ^ box of the whole frame (header, tree, and footer)+    , cfLevel :: Double         -- ^ 0 = bottom level, 1 = next higher, etc.+    , cfFunctoid :: Functoid    -- ^ includes tlo for an edit frame+    , frameType :: FrameType    -- ^ edit or call frame+    }+                 deriving (Show)+                 +++-- | CanvFrame needs to be Eq in order to be Ord,+-- but maybe the Eq and Ord definitions should be more+-- in the same spirit?+instance Eq CanvFrame where (==) = (==) `on` cfFrameNode++data FrameType = EditFrame | CallFrame deriving (Eq, Read, Show)++-- | Use levelOrder for sorting frames before drawing them+levelOrder :: CanvFrame -> CanvFrame -> Ordering+levelOrder f1 f2 = compare (cfLevel f1) (cfLevel f2) ++-- | The root of the tree displayed in the frame+cfRoot :: CanvFrame -> G.Node+cfRoot frame = +    case frameType frame of+      EditFrame -> error "cfRoot: an edit frame has no root"+      CallFrame -> succ (cfFrameNode frame)++-- | A frame is "eval ready" -- that is, okay to run the Eval Frame dialog --+-- if it is a call frame with no parent+cfEvalReady :: CanvFrame -> Bool+cfEvalReady frame = +    (frameType frame == CallFrame) && (cfParent frame == Nothing)++cfPointInHeader :: CanvFrame -> Double -> Double -> Bool+cfPointInHeader frame x y = +    pointInBB (Position x y) (tbBoxBB (cfHeader frame))++cfPointInFooter :: CanvFrame -> Double -> Double -> Bool+cfPointInFooter frame x y = +    pointInBB (Position x y) (tbBoxBB (cfFooter frame))++frameBodyBox :: CanvFrame -> BBox+frameBodyBox frame =+    -- the space between the header and footer+    let hbb = tbBoxBB (cfHeader frame)+        fbb = tbBoxBB (cfFooter frame)+        top = bbBottom hbb+        bottom = bbTop fbb+    -- assuming both header and footer are left aligned and same width+    in BBox (bbLeft hbb) top (bbWidth hbb) (bottom - top)++editFrameNodes :: CanvFrame -> [G.Node]+editFrameNodes frame =+    case frameType frame of+      EditFrame -> fpNodes (cfFunctoid frame)+      CallFrame -> error "editFrameNodes: not an EditFrame"++frameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node+frameNodeAt frame graph point = +    case frameType frame of+      CallFrame -> callFrameNodeAt frame graph point+      EditFrame -> editFrameNodeAt frame graph point++editFrameNodeAt  :: CanvFrame -> WGraph -> Position -> Maybe G.Node+editFrameNodeAt _frame _graph _point = Nothing -- STUB ***+  -- this could probably make use of the function that finds ***+  -- a selection from a point ***++callFrameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node+callFrameNodeAt frame graph point = +    let search :: [G.Node] -> Maybe G.Node+        search [] = Nothing+        search (r:rs) =+            case lab graph r of+              Just (WFrame _) -> search rs+              Just (WSimple layoutNode) ->+                  let LayoutNode rootGNode treeBB = layoutNode+                  in+                    if pointInBB point treeBB +                    -- it's in the tree rooted at r+                    then if pointInBB point (gnodeNodeBB rootGNode) +                         -- it's in the root node+                         then Just r+                         else search (suc graph r) -- maybe in the subtrees+                    else search rs                 -- maybe in the siblings+              Nothing -> +                  errcats ["editFrameNodeAt: search: no label for node",+                           show r]+    -- since this is a call frame, it had better have a root+    in search [cfRoot frame]++atLeastSizeFrame :: Size -> CanvFrame -> CanvFrame+atLeastSizeFrame (Size minW minH) frame =+    let BBox _ _ width height = cfBox frame+        dwidth = if minW > width then minW - width else 0+        dheight = if minH > height then minH - height else 0+    in resizeFrame frame dwidth dheight++resizeFrame :: CanvFrame -> Double -> Double -> CanvFrame+resizeFrame frame dw dh = +    let BBox x y bwidth height = frameBodyBox frame+        -- do not shrink body to negative size+        bwidth' = max 0 (bwidth + dw)+        height' = max 0 (height + dh)+        bodyBB' = BBox x y bwidth' height'+        header' = alignHeader (cfHeader frame) bodyBB'+        footer' = alignFooter (cfFooter frame) bodyBB'+        frameBox' = bbMergeList [tbBoxBB header', tbBoxBB footer', bodyBB']+    in frame {cfHeader = header', cfFooter = footer', cfBox = frameBox'}+++translateFrame :: CanvFrame -> Double -> Double -> CanvFrame+translateFrame frame dx dy =+    frame {cfHeader = translate dx dy (cfHeader frame),+           cfFooter = translate dx dy (cfFooter frame),+           cfBox = translate dx dy (cfBox frame)}+++-- | Where to position a new frame that is grown out of an old frame?+-- This is a very rough draft of frameOffset+frameOffset :: Style -> CanvFrame -> Position+frameOffset style oldFrame = +    let bb = cfBox oldFrame+    in Position (bbRight bb + styleFramePad style) (bbTop bb - 40)++++nodeCompoundFunction :: WGraph -> CanvFrame -> Node -> Maybe Function+nodeCompoundFunction graph frame node = +    case lab graph node of+      Nothing -> error "nodeCompoundFunction: no label for node"+      Just (WFrame _) -> error "nodeCompoundFunction: node has a WFrame label"+      Just (WSimple layoutNode) ->+          case gnodeValue (nodeGNode layoutNode) of+            ENode (NSymbol (Symbol "if")) _mvalue -> Nothing -- not a function+            ENode (NSymbol (Symbol symbolName)) _mvalue ->+                case envLookup (cfEnv frame) symbolName of+                  Nothing -> Nothing -- unbound symbol okay, at least sometimes+                  Just (VFun func@(Function _ _ _ (Compound _ _))) -> Just func+                  Just _ -> Nothing -- not a compound function+            _ -> Nothing -- not a symbol++grTranslateFrameNodes :: WGraph -> CanvFrame -> Double -> Double -> WGraph+grTranslateFrameNodes wgraph frame dx dy =+    case frameType frame of+      CallFrame -> translateTree dx dy wgraph (cfRoot frame)+      EditFrame -> translateNodes dx dy wgraph (editFrameNodes frame)+      +pointIolet :: Position -> Int -> [Iolet] -> Maybe Int+pointIolet point n iolets =+    -- find the number of the iolet, if any, containing point+    case iolets of +      [] -> Nothing+      (p:ps) ->+          if pointInIolet point p +          then Just n+          else pointIolet point (n + 1) ps+++-- | argIoletCounter returns (no. of inlets, no. of outlets)+-- derived from the argument list of a function still being defined+argIoletCounter :: [String] -> ExprNode -> (Int, Int)+argIoletCounter labels _exprNode = (length labels, 1)++-- | Aligning a CanvFrame's header and footer with the body of the frame.+-- Aligns the header above, and the footer below, the body of the frame,+-- also matching the width if the body widened++alignHeader :: TextBox -> BBox -> TextBox+alignHeader header bodybox =+    let headerBB = tbBoxBB header+        y0 = bbBottom headerBB+        y1 = bbTop bodybox+        x0 = bbLeft headerBB+        x1 = bbLeft bodybox+    in translate (x1 - x0) (y1 - y0) (tbSetWidth header (bbWidth bodybox))++alignFooter :: TextBox -> BBox -> TextBox+alignFooter footer bodybox =+    let footerBB = tbBoxBB footer+        y0 = bbTop footerBB+        y1 = bbBottom bodybox+        x0 = bbLeft footerBB+        x1 = bbLeft bodybox+    in translate (x1 - x0) (y1 - y0) (tbSetWidth footer (bbWidth bodybox))+++-- | Figure out the frame layout for a function.  Returns the layout and frame.+-- Currently, the frame is marked as a "call frame"; if you want to edit it,+-- call (editFrame? editFunction?)++frameNewWithLayout :: Style -> Position -> Double+                   -> Functoid -> Maybe [Value] -> FrameType -- added arg+                   -> Node -> Env -> Maybe G.Node +                   -> (CanvFrame, FunctoidLayout) -- reversed tuple+frameNewWithLayout style (Position x y) z +                   functoid mvalues mode frameNode prevEnv mparent = +  -- Figure out the positions for a function call with the+  -- given function and (possibly) values as arguments+  let headerText = functoidHeader functoid+      vars = functoidArgNames functoid+      footerText = buildFooterText vars mvalues+      env = case mvalues of+              Nothing ->+                  -- dummy extension to be popped off+                  extendEnv [] [] prevEnv +              Just values ->+                  extendEnv vars values prevEnv+      -- body tlo+      layout0 = flayout style functoid env mvalues+      -- header and footer layouts+      headerTB0 = makeTextBox style headerText -- at 0 0+      footerTB0 = makeTextBox style footerText -- at 0 0++      -- make all three the same width+      Size lw lh = flayoutSize layout0+      fwidth = maximum [tbWidth headerTB0, lw, tbWidth footerTB0]+      -- The __widen functions ensure that each part +      -- (header, footer, tree tlo) have the desired width.+      headerTB1 = translate x y (widen headerTB0 fwidth)+      (dx, dy) = (x - hpad style, tbBottom headerTB1 - vpad style)+      layout1 = translate dx dy (flayoutWiden layout0 fwidth)+      footerTB1 = translate x (flayoutBottom layout1) +                  (widen footerTB0 fwidth)+      frameBox = BBox x y fwidth +                 (tbHeight headerTB0 + lh + tbHeight footerTB0)+      frame = CanvFrame {cfHeader = headerTB1,+                         cfFooter = footerTB1,+                         cfVarNames = vars,+                         cfParent = mparent,+                         cfFrameNode = frameNode,+                         cfEnv = env, +                         cfBox = frameBox,+                         cfLevel = z,+                         cfFunctoid = functoid,+                         frameType = mode}+  in (frame, layout1)++++buildFooterText :: [String] -> Maybe [Value] -> String+buildFooterText vars mvalues = +    let items =+            case mvalues of+              Nothing -> vars+              Just [] -> vars+              Just values ->+                  if length vars /= length values+                  then error "buildFooterText: mismatched lists"+                  else [var ++ " = " ++ repr value |+                        (var, value) <- zip vars values]+    in concat (intersperse ", " items)

@@ -0,0 +1,123 @@+{-# LANGUAGE ForeignFunctionInterface, CPP #-}++-- |  Provides a function to set the cursor to a specified shape.+-- Generalized from an example in email+--    Re: [Gtk2hs-users] Changing the mouse cursor shape+--    From: Chris Mears <chris@cm...> - 2007-05-22 07:48+-- found on+-- https://sourceforge.net/mailarchive/forum.php?thread_name=87ps50ie9o.fsf%40loki.cmears.id.au&forum_name=gtk2hs-users+-- and modified by removing the definition of data Cursor+-- since that is now part of gtk2hs/gtk+-- although the enum values are not :-(++-- The CursorType type itself is now exported from+-- Graphics.UI.Gtk.Gdk.Cursor, as also cursorNew+-- and cursorNewFromPixmap.++module Graphics.UI.Sifflet.GtkForeign (setCursor)+where++import System.Glib+import System.Glib.FFI+import Foreign.ForeignPtr ()++import Graphics.UI.Gtk++foreign import ccall "gdk_window_set_cursor" gdkWindowSetCursor :: +    Ptr DrawWindow -> Ptr Cursor -> IO ()++foreign import ccall "gdk_cursor_new" gdkCursorNew :: Int -> IO (Ptr Cursor)++-- | Set the X Window cursor for a window to a specified type+setCursor :: Window -> CursorType -> IO ()+setCursor window cursorType = do+  c <- gdkCursorNew (cursorTypeNumber cursorType)+  d <- widgetGetDrawWindow window+  let GObject fp = toGObject d+  withForeignPtr (castForeignPtr fp) $ \ptr -> gdkWindowSetCursor ptr c++-- These numbers are from /usr/include/gtk-2.0/gdk/gdkcursor.h++cursorTypeNumber :: CursorType -> Int+cursorTypeNumber cursorType =+    case cursorType of+      XCursor -> 0+      Arrow -> 2+      BasedArrowDown -> 4+      BasedArrowUp -> 6+      Boat -> 8+      Bogosity -> 10+      BottomLeftCorner -> 12+      BottomRightCorner -> 14+      BottomSide -> 16+      BottomTee -> 18+      BoxSpiral -> 20+      CenterPtr -> 22+      Circle -> 24+      Clock -> 26+      CoffeeMug -> 28+      Cross -> 30+      CrossReverse -> 32+      Crosshair -> 34+      DiamondCross -> 36+      Dot -> 38+      Dotbox -> 40+      DoubleArrow -> 42+      DraftLarge -> 44+      DraftSmall -> 46+      DrapedBox -> 48+      Exchange -> 50+      Fleur -> 52+      Gobbler -> 54+      Gumby -> 56+      Hand1 -> 58+      Hand2 -> 60+      Heart -> 62+      Icon -> 64+      IronCross -> 66+      LeftPtr -> 68+      LeftSide -> 70+      LeftTee -> 72+      Leftbutton -> 74+      LlAngle -> 76+      LrAngle -> 78+      Man -> 80+      Middlebutton -> 82+      Mouse -> 84+      Pencil -> 86+      Pirate -> 88+      Plus -> 90+      QuestionArrow -> 92+      RightPtr -> 94+      RightSide -> 96+      RightTee -> 98+      Rightbutton -> 100+      RtlLogo -> 102+      Sailboat -> 104+      SbDownArrow -> 106+      SbHDoubleArrow -> 108+      SbLeftArrow -> 110+      SbRightArrow -> 112+      SbUpArrow -> 114+      SbVDoubleArrow -> 116+      Shuttle -> 118+      Sizing -> 120+      Spider -> 122+      Spraycan -> 124+      Star -> 126+      Target -> 128+      Tcross -> 130+      TopLeftArrow -> 132+      TopLeftCorner -> 134+      TopRightCorner -> 136+      TopSide -> 138+      TopTee -> 140+      Trek -> 142+      UlAngle -> 144+      Umbrella -> 146+      UrAngle -> 148+      Watch -> 150+      Xterm -> 152+      LastCursor -> 153+      BlankCursor -> (-2)+      CursorIsPixmap -> (-1)

@@ -0,0 +1,224 @@+{-# LANGUAGE CPP #-}++module Graphics.UI.Sifflet.GtkUtil +    (suppressScimBridge+    , showChoicesDialog, defaultDialogPosition+    , runDialogM, runDialogS+     -- , runDialogHelper+    , showInputErrorMessage, showErrorMessage+    , showInfoMessage+    , showMessage+    , EntryDialog, Reader+    , createEntryDialog, runEntryDialog+    , addEntryWithLabel+    )++where++import Control.Monad++#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import System.Posix.Env+#endif++import Graphics.UI.Sifflet.LittleGtk+import Language.Sifflet.Util++-- SCIM Bridge causes problems, so shush it++suppressScimBridge :: IO ()+suppressScimBridge = +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +    return ()+#else+    putEnv "GTK_IM_MODULE=gtk-im-context-simple"+#endif++-- ============================================================+-- CUSTOMIZABLE DIALOGS++-- | Show a message and a set of choices;+-- run the action corresponding to the selected choice;+-- you might want to include a "Cancel" option with the action return ().+-- There *should* be as many actions as there are options.+showChoicesDialog :: String -> String -> [String] -> [IO a] -> IO a+showChoicesDialog title message options actions = do+  {+    -- Create basic dialog+    dialog <- dialogNew+  ; windowSetTitle dialog title+  ; widgetSetName dialog ("Sifflet-" ++ title)++  -- Add message+  ; vbox <- dialogGetUpper dialog+  ; label <- labelNew (Just message)+  ; boxPackStartDefaults vbox label+  ; widgetShowAll vbox++  -- Add buttons+  -- Work around bug in gtk2hs v. 0.10.0 and 0.10.1,+  -- which is fixed in darcs gtk2hs.+  -- fromResponse (ResponseUser i) requires i > 0.+  -- so zip [1..] instead of zip [0..]+  ; let indexOptions = zip [1..] options+        addButton (i, option) = +            dialogAddButton dialog option (ResponseUser i)+  ; forM_ indexOptions addButton+  ; dialogGetActionArea dialog >>= widgetShowAll++  -- Run dialog+  ; response <- dialogRun dialog+  ; widgetDestroy dialog -- here? or after handling response?+  ; case response of+      ResponseUser i -> +          let j = i - 1 -- work around bug described above+          in if j >= 0 && j < length actions+             then actions !! j+             else errcats ["showChoicesDialog: response index",+                           show j, "is out of range for actions"]+      _ -> errcats ["showChoicesDialog: expected a ResponseUser _ but got",+                    show response]+  }+          +createDialog :: String -> (VBox -> IO a) -> IO (Dialog, a)+createDialog title addContent = do+  -- Create basic dialog+  dialog <- dialogNew+  windowSetTitle dialog title+  widgetSetName dialog ("Sifflet-" ++ title)++  -- Add custom content+  vbox <- dialogGetUpper dialog+  content <- addContent vbox++  -- Add standard buttons+  _ <- dialogAddButton dialog "OK" ResponseOk+  _ <- dialogAddButton dialog "Cancel" ResponseCancel+  dialogSetDefaultResponse dialog ResponseOk -- has no effect?++  return (dialog, content)++-- | Where to put a dialog window.+-- Possible values are+-- WinPosNone WinPosCenter WinPosMouse WinPosCenterAlways +-- WinPosCenterOnParent++defaultDialogPosition :: WindowPosition+defaultDialogPosition = WinPosMouse++-- | Customizable framework for running a dialog++runDialogS :: Dialog -> a -> (a -> IO (SuccFail b)) -> IO (Maybe b)+runDialogS dialog inputs processInputs = +    runDialogHelper dialog inputs processInputs True++runDialogM :: Dialog -> a -> (a -> IO (Maybe b)) -> IO (Maybe b)+runDialogM dialog inputs processInputs =+    let process' inputs' = do+          result <- processInputs inputs'+          case result of+            Nothing -> return $ Fail "_Nothing_"+            Just value -> return $ Succ value+    in runDialogHelper dialog inputs process' False++runDialogHelper :: Dialog -> a -> (a -> IO (SuccFail b)) -> Bool -> IO (Maybe b)+runDialogHelper dialog inputs processInputs retryOnError = do+  -- Position and show the dialog+  windowSetPosition dialog defaultDialogPosition+  widgetShowAll dialog+  windowPresent dialog++  let run = do+        respId <- dialogRun dialog+        case respId of+          ResponseOk ->+              do+                result <- processInputs inputs+                case result of+                  Fail msg ->+                      if retryOnError+                      then do+                        showErrorMessage msg+                        run -- try again+                      else finish Nothing+                  Succ value -> finish (Just value)+          _ -> finish Nothing++      finish result = do+              widgetDestroy dialog+              return result++  run++showInputErrorMessage :: String -> IO ()+showInputErrorMessage message =+    showErrorMessage ("Input Error:\n" ++ message)++showErrorMessage :: String -> IO ()+showErrorMessage = showMessage (Just "Error") MessageError ButtonsClose++showInfoMessage :: String -> String -> IO ()+showInfoMessage title = showMessage (Just title) MessageInfo ButtonsClose++showMessage :: Maybe String -> MessageType -> ButtonsType -> String -> IO ()+showMessage mtitle messagetype buttonstype message = do+  {+    msgDialog <- +        messageDialogNew+        Nothing -- ? or (Just somewindow) -- what does this do?+        [] -- flags+        messagetype+        buttonstype+        message+  ; case mtitle of+      Nothing -> widgetSetName msgDialog "Sifflet-dialog"+      Just title -> windowSetTitle msgDialog title >>+                    widgetSetName msgDialog ("Sifflet-" ++ title)+  ; windowSetPosition msgDialog defaultDialogPosition+  ; windowPresent msgDialog+  ; _ <- dialogRun msgDialog+  ; widgetDestroy msgDialog+  }++-- ============================================================+-- INPUT DIALOGS++type Reader a b = (a -> SuccFail b)++data EntryDialog a = EntryDialog Dialog [Entry] (Reader [String] a)++createEntryDialog :: +    String -> [String] -> [String] -> (Reader [String] a) -> Int -> +    IO (EntryDialog a)+createEntryDialog title labels defaults reader width = do+  -- Interpret width = -1 as don't care++  (dialog, entries) <- +      createDialog title (addEntries labels defaults)+  windowSetDefaultSize dialog width (-1)+  return $ EntryDialog dialog entries reader++runEntryDialog :: (Show a) => EntryDialog a -> IO (Maybe a)+runEntryDialog (EntryDialog dialog entries reader) = +    let -- processInputs :: [Entry] -> IO (SuccFail a)+        -- weird error like in runComboBoxDialog    ^+        processInputs entries' = do+          inputs <- mapM entryGetText entries'+          return (reader inputs)++    in runDialogS dialog entries processInputs++addEntries :: [String] -> [String] -> VBox -> IO [Entry]+addEntries labels defaults vbox = do+  entries <- mapM (const entryNew) labels+  mapM_ (addEntryWithLabel vbox) (zip3 labels entries defaults)+  return entries++-- | Add a labeled text entry to the vbox.++addEntryWithLabel :: VBox -> (String, Entry, String) -> IO ()+addEntryWithLabel vbox (name, entry, defaultValue) = do+    label <- labelNew (Just name)+    entrySetText entry defaultValue+    boxPackStartDefaults vbox label+    boxPackStartDefaults vbox entry

@@ -0,0 +1,185 @@+-- | The purpose of this module is simply to re-export the+-- Gtk functions and types that I use, and avoid those+-- that I don't, particularly those that conflict with+-- names in Sifflet, like Layout.+-- Just hiding these is not enough, because Graphics.UI.Gtk+-- keeps changing what it exports.+-- For example, in 0.10.5 it no longer exports Function, fill,+-- function.++module Graphics.UI.Sifflet.LittleGtk+    (+     -- These are just directly re-exported from Gtk:++     -- Attributes+     AttrOp(..) -- for (:=)+    , get+    , set++    , adjustmentNew++    , boxPackEnd+    , boxPackStart+    , boxPackStartDefaults++    , Button+    , buttonNewWithLabel+    , buttonPressEvent++    , ButtonsType(..)++    , ContainerClass+    , castToContainer+    , containerAdd+    , containerChild+    , containerForeach+    , containerGetChildren++    , CursorType(..)+    , customStoreSetColumn++     -- Dialog+    , Dialog+    , dialogNew+    , dialogAddButton+    , dialogGetActionArea+    , dialogGetUpper     +    , dialogRun+    , dialogSetDefaultResponse+    , toDialog++    , DrawWindow+    , drawWindowInvalidateRect++    , entryCompletionInsertPrefix+    , entryCompletionModel+    , entryCompletionNew+    , entryCompletionSetTextColumn++    , Entry+    , entryGetText+    , entryGetCompletion+    , entryNew+    , entrySetCompletion+    , entrySetText++    , EventMask(..)++    , eventBoxNew++    , Expander+    , expanderNew+    , expanderSetExpanded++    , exposeEvent++    , fileChooserDialogNew+    , fileChooserGetFilename++    , FileChooserAction(..)++    , frameNew+    , frameSetLabel++    , grabAdd+    , grabRemove++    , HBox+    , hBoxNew++    , keyPressEvent++    , Label+    , labelNew+    , labelSetText++    , Layout+    , layoutGetDrawWindow+    , layoutNew+    , layoutPut+    , layoutSetSize++    , listStoreNew++    , makeColumnIdString++    , menuPopup++    , MessageType(..)+    , messageDialogNew++    , on+    , onDestroy+    , onSizeRequest++    , Packing(..)++    , PolicyType(PolicyAutomatic)++    , Rectangle(..)++    , renderWithDrawable++    , Requisition(..)++    , ResponseId(..)++    , ScrolledWindow+    , scrolledWindowNew+    , scrolledWindowSetPolicy++    , Statusbar+    , statusbarGetContextId+    , statusbarNew+    , statusbarPop+    , statusbarPush++    , Table+    , tableNew+    , tableAttachDefaults++    , VBox+    , vBoxNew++    , WidgetClass++    , widgetAddEvents+    , widgetClassPath+    , widgetDestroy+    , widgetGrabFocus+    , widgetSetCanFocus+    , widgetSetDoubleBuffered+    , widgetSetName+    , widgetSetSizeRequest+    , widgetShow+    , widgetShowAll+    , widgetSizeRequest+    , widgetVisible++    , Window+    , windowDeletable+    , windowMove+    , windowNew+    , windowPresent+    , windowSetDefaultSize+    , windowSetPosition+    , windowSetTitle+    , windowTitle++    , WindowPosition(..)+     -- General GTK stuff+    , initGUI+    , mainGUI+    , mainQuit++     -- These are renamed:+    , GtkFrame+    , GtkLayout+    )++where++import Graphics.UI.Gtk++type GtkFrame = Frame+type GtkLayout = Layout

@@ -0,0 +1,154 @@+-- | "Rowed Panel." +-- Expandable framed panel with a two-dimensional layout+-- (rows of widgets, but not with aligned columns like in a table).++module Graphics.UI.Sifflet.RPanel+    (+     RPanel, newRPanel, rpanelId, rpanelRoot, rpanelContent+    , rpanelAddWidget, rpanelAddWidgets, rpanelNewRow+    , rpanelAddRows+    )++where++import Control.Monad++import Graphics.UI.Sifflet.LittleGtk+import Language.Sifflet.Util++debugTracing :: Bool+debugTracing = False++data RPanel +    = RPanel {+        -- Public+        rpId :: String   -- ^ text for the expander button+      , rpRoot :: GtkFrame -- ^ use the root to add rpanel to a container+      , rpContent :: [[String]] -- ^ ids of widgets added, in rows++      -- Widgets that make up the RPanel+      , rpFrame :: GtkFrame -- ^ frame, same as root+      , rpExpander :: Expander -- ^ expander+      , rpVBox :: VBox         -- ^ vbox to contain the rows+      , rpCurrentRow :: HBox   -- ^ next element goes here if it fits++      -- Geometry book-keeping+      , rpCurrentRowFreeWidth :: Int -- ^ free width in current row+      , rpMaxWidth :: Int            -- ^ maximum row width+      , rpHPad :: Int -- ^ horizontal padding+      }++rpanelId :: RPanel -> String+rpanelId = rpId++rpanelRoot :: RPanel -> GtkFrame+rpanelRoot = rpRoot++rpanelContent :: RPanel -> [[String]]+rpanelContent = rpContent++newRPanel :: String -> Int -> Int -> Int -> IO RPanel+newRPanel cid hpad vpad maxWidth = do+  {+    frame <- frameNew -- adds a border (not labeled, since the expander is)+             +  ; expander <- expanderNew cid+  ; expanderSetExpanded expander True+  ; set frame [containerChild := expander]++  ; vbox <- vBoxNew False vpad  -- non-homogeneous heights+  ; widgetSetSizeRequest vbox maxWidth (-1) -- height = don't care+  ; set expander [containerChild := vbox]++  ; hbox <- hBoxNew False hpad  -- non-homogeoneous widths+  ; boxPackStart vbox hbox PackNatural 0++  ; return $ RPanel {rpId = cid+                    , rpRoot = frame+                    , rpFrame = frame+                    , rpExpander = expander+                    , rpVBox = vbox+                    , rpCurrentRow = hbox+                    , rpContent = [[]]+                    , rpCurrentRowFreeWidth = maxWidth - hpad+                    , rpMaxWidth = maxWidth - hpad+                    , rpHPad = hpad+                    }+              }++-- | Given a list of (name, widget) pairs, add each of the widgets+-- and its name to the rpanel+rpanelAddWidgets :: (WidgetClass widget) =>+                    RPanel -> [(String, widget)] -> IO RPanel+rpanelAddWidgets rp pairs = +    let addPair rp' (widgetId, widget) = rpanelAddWidget rp' widgetId widget+    in foldM addPair rp pairs++-- | Add a single named widget to the RPanel+rpanelAddWidget :: (WidgetClass widget) =>+                   RPanel -> String -> widget -> IO RPanel+rpanelAddWidget rp widgetId widget = do+  {+    Requisition widgetWidth _ <- widgetSizeRequest widget+  ; let freeWidth = rpCurrentRowFreeWidth rp+        freeWidth' = freeWidth - widgetWidth - rpHPad rp+  ; if freeWidth' >= 0 || freeWidth == rpMaxWidth rp+       -- Either there is room enough, OR we're at the start of a row+       -- so starting another won't help -- in fact it would lead to+       -- infinite recursion+    then do+      {+        let content' = insertLastLast (rpContent rp) widgetId+            packMode = -- PackNatural -- to left justify+                       PackGrow -- to fill+                       -- PackRepel -- to center++      ; boxPackStart (rpCurrentRow rp) widget packMode 0+      -- ; widgetShow widget -- do this here???+      ; when debugTracing $+             putStr (unlines ["Adding " ++ widgetId ++ +                              " width " ++ show widgetWidth+                             , "Free width = " ++ show freeWidth +++                              " -> " ++ show freeWidth'+                             , "Content -> " ++ show content'])++      ; return $ rp {rpContent = content'+                     , rpCurrentRowFreeWidth = freeWidth'}+      }+    else +        -- We're out of room, but not at the start of the current row,+        -- so start a new row+        do+      {+        rp' <- rpanelNewRow rp+      ; rpanelAddWidget rp' widgetId widget+      }+    }++-- | Force the RPanel to begin a new row++rpanelNewRow :: RPanel -> IO RPanel+rpanelNewRow rp = do+  {+    hbox <- hBoxNew False (rpHPad rp)+  ; boxPackStart (rpVBox rp) hbox PackNatural 0+  ; return $ rp {rpCurrentRow = hbox+                , rpContent = insertLast (rpContent rp) []+                , rpCurrentRowFreeWidth = rpMaxWidth rp}+  }++-- | Given a list of lists, each sublist representing a row of widgets,+-- add the widgets to the RPanel, preserving the row structure+-- as much as possible.+-- (Row structure will be broken if any intended row is too wide.)+rpanelAddRows :: (WidgetClass widget) =>+                 RPanel -> [[(String, widget)]] -> IO RPanel+rpanelAddRows rp rows = foldM rpanelAddRow rp rows++-- | Add a row of widgets to an RPanel.+-- This does not start a new row before the first widget,+-- but after the last, so at the end, the current row will be empty.+rpanelAddRow :: (WidgetClass widget) =>+                RPanel -> [(String, widget)] -> IO RPanel+rpanelAddRow rp row = +    rpanelAddWidgets rp row >>= rpanelNewRow

@@ -0,0 +1,585 @@+module Graphics.UI.Sifflet.Tool+    (+      ToolId(..)+    , checkMods+    , functionArgToolSpecs+    , functionTool+    , functionToolsFromLists+    , makeConnectTool+    , makeCopyTool+    , makeDeleteTool+    , makeDisconnectTool+    , makeIfTool+    , makeMoveTool+    , showFunctionEntry+    , showLiteralEntry+    , vpuiSetTool+    , vpuiWindowSetTool++    , vwAddFrame+    , vpuiAddFrame++    -- Statusbar+    , wsPopStatusbar, wsPushStatusbar++    -- frame context menu commands (do these belong elsewhere?)+    , dumpFrame+    , dumpGraph+    , dumpWorkWin+    , clearFrame+    , closeFrame+    )++where++import Control.Monad+import Control.Monad.Trans (liftIO)+import Data.IORef+import Data.List++import Data.Graph.Inductive as G++import Graphics.UI.Gtk.Gdk.EventM++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree (putTree, repr)+import Data.Sifflet.TreeGraph (graphToOrderedTreeFrom)+import Data.Sifflet.WGraph++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+import Language.Sifflet.Parser++import Graphics.UI.Sifflet.Callback+import Graphics.UI.Sifflet.Canvas+import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.LittleGtk +import Graphics.UI.Sifflet.Types++import Language.Sifflet.Util++data ToolId + = ToolConnect+ | ToolDisconnect+ | ToolIf+ | ToolMove+ | ToolDelete+ | ToolFunction String          -- ^ function name+ | ToolLiteral Expr+ | ToolArg String Int            -- ^ argument name, no. of inputs+   deriving (Eq, Show)+++functionArgToolSpecs :: Function -> [ArgSpec]+functionArgToolSpecs (Function _mname argTypes _rtype impl) =+    let atspec :: (String, Type) -> ArgSpec+        atspec (name, t) = ArgSpec name (typeInlets t)+        typeInlets :: Type -> Int+        typeInlets (TypeCons "Function" [_t1, t2]) = 1 + typeInlets t2+        typeInlets _ = 0+        argNames =+            case impl of+              Primitive _ -> ["arg" ++ show i | i <- [1 .. length argTypes]]+              Compound anames _body -> anames+    in map atspec (zip argNames argTypes)+          +-- Tools++vpuiSetTool :: ToolId -> WinId -> VPUI -> IO VPUI+vpuiSetTool toolId winId =+    vpuiUpdateWindowIO winId (vpuiWindowSetTool (toolIdToTool toolId))++vpuiWindowSetTool :: Tool -> VPUIWindow -> IO VPUIWindow+vpuiWindowSetTool tool vw =+  case vw of+    VPUIWorkWin ws _ ->+        do+          {+          ; wsPopStatusbar ws+          ; wsPushStatusbar ws ("Tool: " ++ toolName tool)+          ; let canvas' = (wsCanvas ws) {vcTool = Just tool}+          ; canvas'' <- toolActivated tool canvas'+          ; return $ vpuiWindowSetCanvas vw canvas''+          }+    _ -> return vw++toolIdToTool :: ToolId -> Tool+toolIdToTool toolId =+    case toolId of+      ToolConnect -> makeConnectTool+      ToolDisconnect -> makeDisconnectTool+      ToolIf -> makeIfTool+      ToolMove -> makeMoveTool+      ToolDelete -> makeDeleteTool+      ToolFunction funcname -> functionTool funcname+      ToolLiteral e -> makeBoundLiteralTool e+      ToolArg argname n -> makeBoundArgTool argname n+++defaultContextDescription :: String+defaultContextDescription = "default context"++wsPushStatusbar :: Workspace -> String -> IO ()+wsPushStatusbar ws msg = do +  {+    let sbar = wsStatusbar ws+  ; contextId <- statusbarGetContextId sbar defaultContextDescription+  ; _ <- statusbarPush sbar contextId msg+  ; return ()+  }++wsPopStatusbar :: Workspace -> IO ()+wsPopStatusbar ws = do+  {+    let sbar = wsStatusbar ws+  ; contextId <- statusbarGetContextId sbar defaultContextDescription+  ; statusbarPop sbar contextId+  }++makeMoveTool :: Tool+makeMoveTool = +    let move canv toolContext _mods x y = +            case toolContext of+              TCEditFrame frame ->+                  let graph = vcGraph canv+                  in case pointSelection graph frame (Position x y) of+                       sel@(Just (SelectionNode node)) ->+                         let dragging = +                                 Dragging {draggingNode = node,+                                           draggingPosition = Position x y}+                         in do+                           {+                             vcInvalidateFrameWithParent canv graph frame+                           ; return $ canv {vcSelected = sel,+                                            vcDragging = Just dragging}+                           }+                       _ ->     -- no node selected, do nothing+                           return canv+              _ ->+                  return canv     -- not an edit frame, do nothing+    in Tool "MOVE" return (toToolOpVW move)++makeDeleteTool :: Tool+makeDeleteTool = +    let del :: CanvasToolOp+        del canv toolContext mods x y =+            case toolContext of+              TCEditFrame frame -> +                  let graph = vcGraph canv+                  in case pointSelection graph frame (Position x y) of+                       Just (SelectionNode node) ->+                           if checkMods [Shift] mods+                           then vcFrameDeleteTree canv frame node+                           else vcFrameDeleteNode canv frame node+                       _ ->+                           return canv     -- no node selected, do nothing++              _ -> +                  return canv         --  not an edit frame, do nothing+          +    in Tool "DELETE" vcClearSelection (toToolOpVW del)++-- | Check that all required modifiers are in found+checkMods :: [Modifier] -> [Modifier] -> Bool+checkMods required found =+    all (\ r -> elem r found) required++makeConnectTool :: Tool+makeConnectTool = +    Tool "CONNECT" vcClearSelection (toToolOpVW (conn connect))+          +makeDisconnectTool :: Tool+makeDisconnectTool = +    Tool "DISCONNECT" vcClearSelection (toToolOpVW (conn disconnect))++conn :: (VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas)+     -> CanvasToolOp+conn action canvas toolContext _mods x y =+    case toolContext of+      TCEditFrame frame ->+          let oldSel = vcSelected canvas+              graph = vcGraph canvas+              requestRedraw =+                  vcInvalidateFrameWithParent canvas graph frame+          in case pointSelection graph frame (Position x y) of+                    +               -- Overall algorithm: If we're on a port and there's+               -- an opposite port selected, apply the action them+               -- and clear the selection.  Otherwise, if we're on+               -- a port, select it.  Otherwise do nothing.++               Just sel@(SelectionInlet parent inlet) ->+                   -- Case 1: we're on an inlet port, +                   -- opposite port = outlet+                   do +                     {+                       requestRedraw+                     ; case oldSel of+                         Just (SelectionOutlet child outlet) ->+                             do+                               {+                                 canvas' <- action canvas parent +                                            inlet child outlet+                               ; return $ canvas' {vcSelected = Nothing}+                               }+                         _ -> return $ canvas {vcSelected = Just sel}+                     }+               Just sel@(SelectionOutlet child outlet) ->+                   -- Case 2: we're on an outlet port, +                   -- opposite port = inlet+                   do+                     {+                       requestRedraw+                     ; case oldSel of+                         Just (SelectionInlet parent inlet) ->+                             do+                               {+                                 canvas' <- action canvas parent +                                            inlet child outlet+                               ; return $ canvas' {vcSelected = Nothing}+                               }+                         _ -> return $ canvas {vcSelected = Just sel}+                     }++               _ -> +                      -- Case 3: we're not on an iolet, do nothing+                      return canvas+      _ -> +          -- not in an edit frame, do nothing+          return canvas++makeBoundLiteralTool :: Expr -> Tool+makeBoundLiteralTool e =+    let enode node = ENode node EvalUntried+        addLitNode node vw toolContext _mods x y =+            case toolContext of+              TCEditFrame frame ->+                  vcFrameAddNode vw frame (enode node) [] x y+              _ ->+                  return vw -- Nothing+        mktool node =+            Tool ("Literal: " ++ repr e) +                 return +                 (toToolOpVW (addLitNode node))+    in case e of+         EBool b -> mktool (NBool b)+         EChar c -> mktool (NChar c)+         ENumber n -> mktool (NNumber n)+         EString s -> mktool (NString s)+         EList es -> if exprIsLiteral e+                     then mktool (NList es)+                     else errcats ["makeBoundLiteralTool: ",+                                   "non-literal list expression",+                                   show e]+         _ ->+             errcats ["makeBoundLiteralTool: non-literal or",+                      "extended expression", show e]++makeBoundArgTool :: String -> Int -> Tool+makeBoundArgTool label n = +    let node = ENode (NSymbol (Symbol label)) EvalUntried+        addArgNode vc toolContext _mods x y =+            case toolContext of+              TCEditFrame frame ->+                  vcFrameAddNode vc frame node (map show [1..n]) x y+              _ ->+                  return vc -- no effect+    in Tool ("Argument: " ++ label ++ "/" ++ show n) +            return+            (toToolOpVW addArgNode)++makeIfTool :: Tool+makeIfTool = +    let if_ vpui toolContext _mods x y =+            case toolContext of+              TCEditFrame frame ->+                  let node = ENode (NSymbol (Symbol "if")) EvalUntried+                      labels = ["test", "left", "right"]+                  in vcFrameAddNode vpui frame node labels x y+              _ ->+                  return vpui     -- do nothing+    in Tool "if" return (toToolOpVW if_)++makeCopyTool :: Tool+makeCopyTool = dummyTool "COPY"++dummyTool :: String -> Tool+dummyTool name = +    let op vpui _winId _context _mods x y =+            info ("dummyTool", name, x, y) >>+            return vpui+    in Tool ("*" ++ name ++ "*") return op++-- functionTool needs the VPUI in its op,+-- because it needs to get an environment.++functionTool :: String -> Tool+functionTool name =+     let op :: ToolOp+         op vpui winId toolContext _mods x y =  +             -- Some of these are not used in some cases,+             -- but with lazy evaluation it doesn't hurt to+             -- declare them all up here:+             let env = vpuiGlobalEnv vpui+                 func = envGetFunction env name+             in case toolContext of+                  TCCallFrame _ -> +                      return vpui     -- do nothing+                  TCEditFrame frame ->+                         let modify canvas =+                                 vcFrameAddFunctoidNode canvas frame+                                                        (FunctoidFunc func)+                                                        x y+                         in vpuiModCanvasIO vpui winId modify+                  TCExprNode ->+                      return vpui     -- do nothing+                  TCWorkspace ->+                      case functionImplementation func of+                        Primitive _ -> +                            return vpui -- do nothing+                        Compound _ _ -> +                            -- Add a call frame to the workspace+                            vpuiAddFrame vpui winId (FunctoidFunc func) +                                         Nothing CallFrame +                                         env x y 0 Nothing+    in Tool name return op+++-- | Add a frame representing a functoid to the canvas +-- of a particular window, specified by its window id (title).++vpuiAddFrame :: VPUI -> WinId -> Functoid -> Maybe [Value] -> FrameType+              -> Env -> Double -> Double -> Double -> Maybe G.Node +              -> IO VPUI+vpuiAddFrame vpui winId functoid mvalues mode prevEnv x y z mparent = +    let update vw = +            vwAddFrame vw functoid mvalues mode prevEnv x y z mparent+    in vpuiUpdateWindowIO winId update vpui++-- | Add a frame representing a functoid to the canvas +-- of a VPUIWindow (which ought to have a canvas, of course).+-- Otherwise like vcAddFrame.++vwAddFrame :: VPUIWindow -> Functoid -> Maybe [Value] -> FrameType +           -> Env -> Double -> Double -> Double -> Maybe G.Node +           -> IO VPUIWindow+vwAddFrame vw functoid mvalues mode prevEnv x y z mparent = +    let modify canvas = vcAddFrame canvas functoid mvalues mode prevEnv+                                   x y z mparent+    in vpuiWindowModCanvasIO vw modify++functionToolsFromLists :: [[String]] -> [[Tool]]+functionToolsFromLists = map2 functionTool+    +-- | Open an entry for user input of function name to select a function tool.+-- Returns unaltered VPUI, for convenience in menus and key callbacks.++showFunctionEntry :: WinId -> CBMgr -> VPUI -> IO VPUI+showFunctionEntry winId uimgr vpui = +    let env = vpuiGlobalEnv vpui+        fsymbols = (envFunctionSymbols env)+        -- Check whether the name is bound to a function+        checkFunctionName :: String -> SuccFail String+        checkFunctionName name =+            case envLookup env name of+              Nothing -> Fail $ name ++ ": unbound variable"+              Just (VFun _) -> Succ name+              _ -> Fail $ name ++ ": bound to non-function value"+    in showToolEntry winId "Function name" +           (Just fsymbols)    -- completions+           checkFunctionName  -- parser+           -- activateTool       -- action+           ToolFunction         -- tool type specifier+           uimgr              -- state+           vpui++-- | Show an entry for input of a literal value.+-- Returns unaltered VPUI, for convenience in menus and key callbacks.++showLiteralEntry :: WinId -> CBMgr -> VPUI -> IO VPUI+showLiteralEntry winId = +    -- Needs uimgr for action when entry is activated+    showToolEntry winId "Literal value" +                  Nothing              -- completions+                  parseLiteral      -- parser+                  -- activateTool         -- action+                  ToolLiteral          -- tool type specifier++-- | New, light replacement for most dialogs++-- | Prompt for input in a text entry.+--   When the user presses Return, attempt to parse the input text.+--   If parse succeeds, apply the toolType to the resulting value+--   to produce a ToolId and set the corresponding tool.+--   If user presses Escape, the input is closed with no action.+--   If mcompletions is (Just comps), comps is a list of possible+--   completions for the entry.+-- +-- Returns the vpui, with NO UPDATE, for convenience in callbacks and menus++-- *** Consider merging this with the other "light dialog"+-- in EditArgsPanel.hs++-- Note: this has been specialized; the action only sets a tool+-- on the window.  It can be generalized again+-- to any sort of action if needed.+showToolEntry :: WinId -> String -> Maybe [String] +              -> (String -> SuccFail a) -> (a -> ToolId)+              -> CBMgr -> VPUI+              -> IO VPUI+showToolEntry winId prompt mcompletions parser toolType uimgr vpui =+    let vw = vpuiGetWindow vpui winId+    in case vpuiWindowLookupCanvas vw of+         Nothing -> error "showToolEntry: no canvas!"+         Just canvas ->+             let layout = vcLayout canvas+                 (xx, yy) = vcMousePos canvas+             in do+               {+               ; root <- eventBoxNew     -- needed for Label visibility+               ; frame <- frameNew+               ; frameSetLabel frame prompt+               ; entry <- entryNew+               ; case mcompletions of+                   Nothing -> return ()+                   Just comps -> addEntryCompletions entry comps++               -- Organize as (eventbox (frame (entry)))+               ; containerAdd frame entry+               ; containerAdd root frame+               ; layoutPut layout root (round xx) (round yy)+               ; widgetShowAll root++               -- grab and handle events+               ; grabAdd entry -- all keyboard and mouse events of the app+               ; widgetGrabFocus entry -- grabs keyboard events, still necessary+               -- Set actions for TAB (entry completion) and ESC (cancel)+               ; _ <- on entry keyPressEvent (entryKeyPress root entry)+               ; uimgr (OnEntryActivate entry+                        (entryActivated root winId entry parser toolType))+               ; return vpui+               }++-- | When activated, send a message to set the current tool +entryActivated :: (ContainerClass c) => +                  c -> WinId -> Entry +               -> (String -> SuccFail a) -- parser+               -> (a -> ToolId)          -- tool type+               -> IORef VPUI    -- state+               -> IO ()+entryActivated container winId entry parser toolType uiref = do+-- This could be rewritten in the form of :: ... -> VPUI -> IO VPUI+-- and transformed in the CBMgr, "lifting" the readIORef/writeIORef,+-- in fact streamlining it to "mutateIORef"+  {+    text <- entryGetText entry+  ; case parser text of+      Fail msg -> info msg+      Succ v -> +          grabRemove entry >>+          widgetDestroy container >>+          readIORef uiref >>= +          vpuiSetTool (toolType v) winId >>=+          writeIORef uiref+  }++addEntryCompletions :: Entry -> [String] -> IO ()+addEntryCompletions entry comps = do+  {+    -- prepare the model+    model <- listStoreNew comps++  -- make EntryCompletion and set model and column+  ; ec <- entryCompletionNew+  ; set ec [entryCompletionModel := Just model]+  ; customStoreSetColumn model (makeColumnIdString 0) id+  ; entryCompletionSetTextColumn ec (makeColumnIdString 0)++  -- attach EntryCompletion to Entry+  ; entrySetCompletion entry ec+  ; return ()+  }++-- | Set actions for Tab and Escape+entryKeyPress :: (ContainerClass c) => c -> Entry -> EventM EKey Bool+entryKeyPress container entry =+    tryEvent $ do+      {+        kname <- eventKeyName+      ; case kname of+          "Escape" ->+              liftIO $ +              grabRemove entry >>+              widgetDestroy container+          "Tab" ->+              -- complete the entry as far as possible+              liftIO $+              entryGetCompletion entry >>=+              entryCompletionInsertPrefix+          _ -> stopEvent+      }          ++-- | For debugging (frame context menu command)+dumpFrame :: VPUI -> WinId -> CanvFrame -> IO ()+dumpFrame vpui winId frame = +    let vw = vpuiGetWindow vpui winId+        canv = vpuiWindowGetCanvas vw+        graph = vcGraph canv+        frameNode = cfFrameNode frame+        frame' = vcGetFrame canv graph frameNode -- ?? possibly different+        tree = graphToOrderedTreeFrom graph frameNode+    in +      info ("frame functoid:", cfFunctoid frame) >>+      info ("frame' functoid:", cfFunctoid frame') >>+      info ("frame' all descendants:", +            nodeAllSimpleDescendants graph frameNode) >>+      info "Tree rooted at frame:" >>+      putTree tree++-- | For debugging (frame context menu command)+dumpGraph :: VPUI -> WinId -> IO ()+dumpGraph vpui = +    printWGraph . vcGraph . vpuiWindowGetCanvas . vpuiGetWindow vpui++-- | For debugging the window's widget children+dumpWorkWin :: VPUI -> WinId -> IO ()+dumpWorkWin vpui winId =+    case vpuiTryGetWindow vpui winId of+      Nothing -> putStrLn ("dumpWorkWin: no window found with id " ++ winId)+      Just vpuiWindow ->+          let window = vpuiWindowWindow vpuiWindow+          in dumpWidget window >>+             containerForeach window dumpWidget++dumpWidget :: (WidgetClass w) => w -> IO ()+dumpWidget w = do+  {+    (_, path, _) <- widgetClassPath w+  ; cname <- widgetClassName w+  ; vis <- get w widgetVisible+  ; print (path, cname, vis)+  ; when (elem cname ["GtkVBox", "GtkHBox", "GtkLayout"]) $+         containerForeach (castToContainer w) dumpWidget+  }++widgetClassName :: (WidgetClass w) => w -> IO String+widgetClassName w = do+  {+    (_len, _path, rpath) <- widgetClassPath w+  ; return (case elemIndex '.' rpath of+              Nothing -> "Nil"+              Just n -> reverse (take n rpath))+  }++-- | Clear frame indicated by mouse location+clearFrame :: WinId -> CanvFrame -> VPUI -> IO VPUI+clearFrame winId frame vpui =+    let clear canvas = vcClearFrame canvas frame+    in vpuiModCanvasIO vpui winId clear++-- | Close frame (context menu command)+closeFrame :: VPUI -> WinId -> CanvFrame -> IO VPUI+closeFrame vpui winId frame =+    let close canvas = vcCloseFrame canvas frame+    in vpuiModCanvasIO vpui winId close