module Sifflet.UI.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 Sifflet.Data.Functoid import Sifflet.Data.Geometry import Sifflet.Data.Tree import Sifflet.Data.TreeLayout import Sifflet.Data.WGraph import Sifflet.Language.Expr import 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)