sifflet-2.3.0: lib/Graphics/UI/Sifflet/Frame.hs
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 ->
-- in case there are fewer values than vars,
-- pad out with "?"s
[var ++ " = " ++ rvalue |
(var, rvalue) <- zip vars (map repr values ++ repeat "?")]
in concat (intersperse ", " items)