diff --git a/CBMgr.hs b/CBMgr.hs new file mode 100644 --- /dev/null +++ b/CBMgr.hs @@ -0,0 +1,141 @@ +module CBMgr + ( + CBMgr, CBMgrCmd(..), mkCBMgr + , MenuSpec(..), MenuItemSpec(..), MenuItemAction + , createMenuBar, addMenu, createMenu, createMenuItem + , modifyIORefIO + ) + +where + +import Data.IORef + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.EventM + +import UITypes + +-- | 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 () + +-- | Commands for the CBMgr +data CBMgrCmd + = -- window events + OnWindowConfigure Window (IORef VPUI -> EventM EConfigure Bool) + | OnWindowDestroy Window (IORef VPUI -> IO ()) + | OnWindowKeyPress 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 (IORef VPUI -> IO ()) + | AfterButtonClicked Button (IORef VPUI -> IO ()) + + | 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 () + OnWindowKeyPress window action -> + on 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 uiref action) >> return () + OnEntryActivate entry action -> + onEntryActivate entry (action uiref) >> return () + AfterButtonClicked button action -> + afterClicked button (action uiref) >> return () + + 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 modifyIORef, but the type of the second argument is (a -> IO a) +-- instead of (a -> a). +modifyIORefIO :: IORef a -> (a -> IO a) -> IO () +modifyIORefIO ref updateIO = readIORef ref >>= updateIO >>= writeIORef ref diff --git a/Examples.hs b/Examples.hs new file mode 100644 --- /dev/null +++ b/Examples.hs @@ -0,0 +1,278 @@ +module Examples (exampleFunctions, exampleFunctionNames, exampleEnv + , eFoo, eMax, eFact -- must these be exported? + ) + +where + +-- standard libraries + +-- extra libraries + +-- sifflet libraries +import Expr +import Util + +-- TEST COMPOUND FUNCTIONS + +-- | grossProfit salesA salesB = 0.12 salesA + 0.25 salesB + +grossProfit :: Function +grossProfit = + Function (Just "grossProfit") [VpTypeNum, VpTypeNum] VpTypeNum + (Compound ["salesA", "salesB"] + (eCall "+" [eCall "*" [eFloat 0.12, eSymbol "salesA"], + eCall "*" [eFloat 0.25, eSymbol "salesB"]])) + +-- | bonus1 profit = if profit > 100000 +-- then 1000 + 0.0012 * profit +-- else 0 +bonus1 :: Function +bonus1 = + Function (Just "bonus1") [VpTypeNum] VpTypeNum + (Compound ["profit"] + (eIf (eCall ">" [eSymbol "profit", eInt 100000]) + (eCall "+" [eInt 1000, + eCall "*" [eFloat 0.0012, eSymbol "profit"]]) + (eInt 0))) + +-- | bonus2 salesA salesB = bonus1 (grossProfit salesA salesB) +bonus2 :: Function +bonus2 = + Function (Just "bonus2") [VpTypeNum, VpTypeNum] VpTypeNum + (Compound ["salesA", "salesB"] + (eCall "bonus1" [eCall "grossProfit" [eSymbol "salesA", + eSymbol "salesB"]])) + +-- foo a b = 2 * a + b +foo :: Function +foo = Function (Just "foo") [VpTypeNum, VpTypeNum] VpTypeNum + (Compound ["a", "b"] + (eCall "+" [eCall "*" [eInt 2, eSymbol "a"], + eSymbol "b"]) + ) + +eFoo :: Expr -> Expr -> Expr +eFoo e1 e2 = eCall "foo" [e1, e2] + +-- max x y = if x > y then x else y +max :: Function +max = let ex = eSymbol "x" + ey = eSymbol "y" + in Function (Just "max") [VpTypeNum, VpTypeNum] VpTypeNum + (Compound ["x", "y"] (eIf (eGt ex ey) ex ey)) + +eMax :: Expr -> Expr -> Expr +eMax e1 e2 = eCall "max" [e1, e2] + +-- fact n = if n == 0 then 1 else n * (fact (n - 1)) +fact :: Function +fact = let en = eSymbol "n" in + Function (Just "fact") [VpTypeNum] VpTypeNum + (Compound ["n"] + (eIf (eZerop en) + (eInt 1) + (eTimes en (eFact (eSub1 en))))) + +eFact :: Expr -> Expr +eFact e1 = eCall "fact" [e1] + +-- sum of the integers 0..n +-- Lewis and Loftus, Jave Software Solutions, 6th. ed. (they call it "sum") +sumFromZero :: Function +sumFromZero = let en = eSymbol "n" in + Function (Just "sumFromZero") [VpTypeNum] VpTypeNum + (Compound ["n"] + (eIf (eZerop en) + (eInt 0) + (ePlus en (eSumFromZero (eSub1 en))))) + +buggySumFromZero :: Function +buggySumFromZero = + let Succ body = stringToExpr "n + buggySumFromZero (n - 1)" + in Function (Just "buggySumFromZero") [VpTypeNum] VpTypeNum + (Compound ["n"] body) + +eFib1 :: Expr -> Expr +eFib1 en = eCall "fib1" [en] + +fib1 :: Function +fib1 = let en = eSymbol "n" + one = eInt 1 + two = eInt 2 + in Function (Just "fib1") [VpTypeNum] VpTypeNum + (Compound ["n"] + (eIf (eEq en one) + one + (eIf (eEq en two) + one + (ePlus (eFib1 (eMinus en two)) + (eFib1 (eMinus en one)))))) + +-- implying that there should be fib2 ... + +eSumFromZero :: Expr -> Expr +eSumFromZero en = eCall "sumFromZero" [en] + +-- rmul: multiplication by repeated addition. +-- The "multiply" function in Hanly and Koffman, +-- "Problem Solving and Program Design in C", 5th ed. + +eRmul :: Expr -> Expr -> Expr +eRmul em en = eCall "rmul" [em, en] + +rmul :: Function +rmul = let em = eSymbol "m" + en = eSymbol "n" + in Function (Just "rmul") [VpTypeNum, VpTypeNum] VpTypeNum + (Compound ["m", "n"] + (eIf (eZerop en) + (eInt 0) + (ePlus em (eRmul em (eSub1 en))))) + +eGcd :: Expr -> Expr -> Expr +eGcd em en = eCall "gcd" [em, en] + +gcd :: Function +gcd = let em = eSymbol "m" + en = eSymbol "n" + in Function (Just "gcd") [VpTypeNum, VpTypeNum] VpTypeNum + (Compound ["m", "n"] + (eIf (eZerop (eMod em en)) + en + (eGcd en (eMod em en)))) + + +-- Even and odd, the slow way + +-- Springer and Friedman, Scheme and the Art of Programming (??) +-- Rubio-Sanchez, Urquiza-Fuentes, and Pareja-Flores, +-- "A Gentle Introduction to Mutual Recursion", +-- in ITiCSE 2008: The 13th SIGCSE Conference on Innovation and +-- Technology in Computer Science Education, 2008. + +eEvenp, eOddp :: Expr -> Expr +eEvenp en = eCall "even?" [en] +eOddp en = eCall "odd?" [en] + +evenp, oddp :: Function + +evenp = let en = eSymbol "n" + in Function (Just "even?") [VpTypeNum] VpTypeBool + (Compound ["n"] + (eIf (eZerop en) + eTrue + (eOddp (eSub1 en)))) + +oddp = let en = eSymbol "n" + in Function (Just "odd?") [VpTypeNum] VpTypeBool + (Compound ["n"] + (eIf (eZerop en) + eFalse + (eEvenp (eSub1 en)))) + +-- Fibonacci series through mutual recursion +-- Rubio-Sanchez, Urquiza-Fuentes, and Pareja-Flores, "Gentle Introduction" + +eRabbitBabies, eRabbitAdults :: Expr -> Expr +eRabbitBabies en = eCall "rabbitBabies" [en] +eRabbitAdults en = eCall "rabbitAdults" [en] + +rabbitTotal, rabbitAdults, rabbitBabies :: Function + +rabbitTotal = let m = eSymbol "month" + in Function (Just "rabbitTotal") [VpTypeNum] VpTypeNum + (Compound ["month"] + (ePlus (eRabbitBabies m) (eRabbitAdults m))) + +rabbitAdults = let m = eSymbol "month" + zero = eInt 0 + one = eInt 1 + in Function (Just "rabbitAdults") [VpTypeNum] VpTypeNum + (Compound ["month"] + (eIf (eEq m one) + zero + (ePlus + (eRabbitAdults (eSub1 m)) -- all adults survive + (eRabbitBabies (eSub1 m))))) -- all babies grow up + +rabbitBabies = let m = eSymbol "month" + one = eInt 1 + in Function (Just "rabbitBabies") [VpTypeNum] VpTypeNum + (Compound ["month"] + (eIf (eEq m one) + one + (eRabbitAdults (eSub1 m)))) -- all adults reproduce + + +buggyLength :: Function +buggyLength = let xs = eSymbol "xs" + one = eInt 1 + in Function (Just "buggyLength") + [VpTypeList (VpTypeVar "e1")] VpTypeNum + (Compound ["xs"] + (eIf (eCall "null" [xs]) + one -- base case off by one, should be zero + (ePlus one + (eCall "buggyLength" + [eCall "tail" [xs]])))) + +listLength :: Function +listLength = let xs = eSymbol "xs" + one = eInt 1 + zero = eInt 0 + in Function (Just "length") + [VpTypeList (VpTypeVar "e1")] VpTypeNum + (Compound ["xs"] + (eIf (eCall "null" [xs]) + zero + (ePlus one + (eCall "length" + [eCall "tail" [xs]])))) + +listSum :: Function +listSum = + Function (Just "sum") [VpTypeList VpTypeNum] VpTypeNum + (Compound ["xs"] sumbody1) + +sumbody1, sumbody2 :: Expr +sumbody1 = let xs = eSymbol "xs" + zero = eInt 0 + in eIf (eCall "null" [xs]) + zero + (ePlus (eCall "head" [xs]) + (eCall "sum" [eCall "tail" [xs]])) + +sumbody2 = + let Succ body = + stringToExpr "if null xs then 0 else (head xs) + (sum' (tail xs))" + in body + +listSum' :: Function +listSum' = + Function (Just "sum'") + [VpTypeList VpTypeNum] VpTypeNum + (Compound ["xs"] sumbody2) + +buggySum :: Function +buggySum = let xs = eSymbol "xs" + in Function (Just "buggySum") + [VpTypeList VpTypeNum] VpTypeNum + (Compound ["xs"] + -- missing "if" and base case + (ePlus (eCall "head" [xs]) + (eCall "buggySum" [eCall "tail" [xs]]))) + +exampleFunctions :: [Function] +exampleFunctions = [grossProfit, bonus1, bonus2, + foo, Examples.max, fact, sumFromZero, rmul, fib1, + Examples.gcd, evenp, oddp, + rabbitBabies, rabbitAdults, rabbitTotal, + buggyLength, listLength, listSum, buggySum, + buggySumFromZero] + +exampleFunctionNames :: [String] +exampleFunctionNames = map functionName exampleFunctions + +exampleEnv :: Env +exampleEnv = + envInsertL baseEnv exampleFunctionNames (map VFun exampleFunctions) diff --git a/Expr.hs b/Expr.hs new file mode 100644 --- /dev/null +++ b/Expr.hs @@ -0,0 +1,1032 @@ +module Expr (stringToExpr, exprToValue, stringToValue, + stringToLiteral, + Symbol(..), + Expr(..), eSymbol, eInt, eString, eChar, eFloat, + eBool, eFalse, eTrue, eIf, + eList, eCall, + exprSymbols, exprVarNames, + ExprTree, ExprNode(..), ExprNodeLabel(..), + exprNodeIoletCounter, -- needs work ****** get rid of it??? + exprToTree, treeToExpr, exprToReprTree, + EvalResult, EvalRes(EvalOk, EvalError, EvalUntried), + evalTree, unevalTree, + Value(..), valueFunction, + Function(..), functionName, functionNArgs, + functionArgTypes, functionResultType, + functionArgNames, functionBody, functionImplementation, + FunctionDefTuple, functionToDef, functionFromDef, + FunctionImpl(..), + VpType(..), typeCheck, vpTypeOf, + Env, makeEnv, extendEnv, envInsertL, envPop, + envIns, envSet, envGet, + envGetFunction, envLookup, envLookupFunction, + envSymbols, envFunctionSymbols, + eval, apply, + decideTypes, newUndefinedFunction, undefinedTypes, + ePlus, eTimes, eMinus, eDiv, eMod, + eAdd1, eSub1, + eEq, eNe, eGt, eGe, eLt, eLe, + eZerop, ePositivep, eNegativep, + baseEnv) + +where + +-- ****** drop this after debugging: +import System.IO.Unsafe(unsafePerformIO) + +import Language.Haskell.Syntax +import Language.Haskell.Parser +{- +import Language.Haskell.Pretty +-} + + +import Data.Map as Map hiding (filter, map, null) +import Data.List as List + +import Tree as T +import Util + +{- +testHsParse = do + let (ParseOk (HsModule srcLoc pmod mExports imports decls)) = parseModule "foo x y = x + y" + print $ length decls + print $ decls!!0 + putStrLn "Wow, this is complex." +-} + +stringToExpr :: String -> SuccFail Expr +stringToExpr string = + case parseModule ("x = " ++ string) of + ParseOk (HsModule + _srcLoc -- (SrcLoc ...) + _module -- (Module "Main") + _justMain -- (Just [HsEVar (UnQual (HsIdent "main"))]) + _ -- [] + result) + -> + case result of + [HsPatBind _ _ (HsUnGuardedRhs expr) []] -> + hsExpToVp expr + _ -> + error $ "stringToExpr: unexpected parse result " ++ + "from string " ++ show string ++ + "; result = " ++ show result + + ParseFailed _ str -> Fail str -- not very informative + +hsExpToVp :: HsExp -> SuccFail Expr +hsExpToVp hsExp = + case hsExp of + + HsVar (UnQual (HsSymbol name)) -> Succ $ eSymbol name -- e.g. "+" + HsVar (UnQual (HsIdent name)) -> Succ $ eSymbol name -- e.g. "head" + + HsLit (HsInt i) -> Succ $ eInt i + HsLit (HsFrac r) -> Succ $ eFloat (fromRational r) + HsLit (HsChar a) -> Succ $ eChar a + HsLit (HsString s) -> Succ $ eString s + + HsCon (UnQual (HsIdent "False")) -> Succ eFalse + HsCon (UnQual (HsIdent "True")) -> Succ eTrue + + HsList items -> + case hsListItemsToVps [] items of + Fail msg -> Fail msg + Succ items' -> Succ (eList items') + + HsNegApp hslit -> hsExpToVp hslit >>= eNegate + + HsApp (HsVar (UnQual (HsIdent name))) hsArg -> + do + arg <- hsExpToVp hsArg + Succ $ eCall name [arg] -- ??? *** + HsApp (HsApp hsApp1 hsArg1) hsArg2 -> + do + call1 <- hsExpToVp (HsApp hsApp1 hsArg1) + arg2 <- hsExpToVp hsArg2 + let ECall f args = call1 + Succ $ ECall f (args ++ [arg2]) + HsInfixApp hsArg1 (HsQVarOp (UnQual (HsSymbol op))) hsArg2 -> + do + arg1 <- hsExpToVp hsArg1 + arg2 <- hsExpToVp hsArg2 + Succ $ eCall op [arg1, arg2] + + HsIf hsExp1 hsExp2 hsExp3 -> + do + expr1 <- hsExpToVp hsExp1 + expr2 <- hsExpToVp hsExp2 + expr3 <- hsExpToVp hsExp3 + Succ $ eIf expr1 expr2 expr3 + + HsParen hsExp1 -> hsExpToVp hsExp1 + + _ -> Fail ("hsExpToVp: unknown expression type: " ++ show hsExp) + +eNegate :: Expr -> SuccFail Expr +eNegate expr = + case expr of + ELit (VInt i) -> Succ $ ELit (VInt (negate i)) + ELit (VFloat x) -> Succ $ ELit (VFloat (negate x)) + _ -> Fail $ "eNegate: cannot handle" ++ show expr + +hsListItemsToVps :: [Expr] -> [HsExp] -> SuccFail [Expr] +hsListItemsToVps result items = + case items of + [] -> Succ (reverse result) + (x:xs) -> + case hsExpToVp x of + Fail msg -> Fail msg + Succ x' -> hsListItemsToVps (x':result) xs + +-- Symbols have names, and may or may not have values, +-- but the value is stored in an environment, not in the symbol itself. + +data Symbol = Symbol String -- symbol name + deriving (Eq, Read, Show) + +instance Repr Symbol where repr (Symbol s) = s + +-- The Haskell representations of V's primitive data types +type OInt = Integer +type OStr = String +type OBool = Bool +type OChar = Char +type OFloat = Double + +stringToLiteral :: String -> SuccFail Expr +stringToLiteral s = stringToValue s >>= valueToLiteral + +-- | A more highly "parsed" type of expression +-- +-- ELit (literals) are "primitive" (self-evaluating) expressions, +-- in the sense that if x is a literal, then eval x env = EvalOk x +-- for any environment env. + +data Expr = EUndefined + | ESymbol Symbol + | ELit Value + | EIf Expr Expr Expr -- if test branch1 branch2 + | EList [Expr] -- needed for hsExpToVp case HsList + | ECall Symbol [Expr] -- function name, arglist + -- A function expression other than a symbol will + -- be hard to visualize: + -- | ECall [Expr] -- (function:args) + deriving (Eq, Read, Show) + +instance Repr Expr where + repr EUndefined = "*undefined*" + repr (ESymbol s) = repr s + repr (ELit x) = repr x + repr (EIf t a b) = par "if" (map repr [t, a, b]) + repr (EList items) = par "EList" (map repr items) + repr (ECall (Symbol fname) args) = par fname (map repr args) + +eSymbol :: String -> Expr +eSymbol = ESymbol . Symbol + +eInt :: OInt -> Expr +eInt = ELit . VInt + +eString :: OStr -> Expr +eString = ELit . VStr + +eChar :: OChar -> Expr +eChar = ELit . VChar + +eFloat :: OFloat -> Expr +eFloat = ELit . VFloat + +eBool :: Bool -> Expr +eBool = ELit . VBool + +eFalse, eTrue :: Expr +eFalse = eBool False +eTrue = eBool True + +eIf :: Expr -> Expr -> Expr -> Expr +eIf = EIf + +eList :: [Expr] -> Expr +eList = EList + +-- | Example: +-- ePlus_2_3 = eCall "+" [eInt 2, eInt 3] +eCall :: String -> [Expr] -> Expr +eCall = ECall . Symbol + + +-- EXPRESSION TREES +type ExprTree = Tree ExprNode +data ExprNode = ENode ExprNodeLabel EvalResult + deriving (Eq, Show) + +data ExprNodeLabel = NUndefined | NSymbol Symbol | NLit Value + deriving (Eq, Show) + +instance Repr ExprNode where + reprl (ENode label evalRes) = + case label of + NUndefined -> + case evalRes of + EvalUntried -> ["undefined"] + EvalError e -> ["undefined", "error: " ++ e] + EvalOk _ -> + error $ "reprl of ExprNode: NUndefined with EvalOk " ++ + "should not happen!" + NSymbol s -> + case evalRes of + EvalOk v -> [repr s, repr v] + EvalError e -> [repr s, "error: " ++ e] + EvalUntried -> reprl s + NLit l -> reprl l + +-- This was +-- exprNodeIoletCounter :: Env -> IoletCounter ExprNode +-- but IoletCounter is not available here, so use equivalent type. +-- Returns (no. of inlets, no. of outlets) +exprNodeIoletCounter :: Env -> ExprNode -> (Int, Int) +exprNodeIoletCounter env (ENode nodeLabel _nodeResult) = + case nodeLabel of + NUndefined -> (0, 1) + NSymbol (Symbol "if") -> (3, 1) + NSymbol (Symbol s) -> + case envLookup env s of + Nothing -> (0, 1) -- probably a parameter of the function + Just value -> + case value of + VFun function -> (functionNArgs function, 1) + _ -> (0, 1) -- symbol bound to non-function value + NLit _ -> (0, 1) + +exprToTree :: Expr -> ExprTree +exprToTree expr = + case expr of + -- EUndefined, ESymbol, ELit map direclty to NUndefined, NSymbol, NLit + EUndefined -> T.Node (ENode NUndefined EvalUntried) [] + ESymbol s -> T.Node (ENode (NSymbol s) EvalUntried) [] + ELit l -> T.Node (ENode (NLit l) EvalUntried) [] + -- EIf maps to symbol "if" at the root, 3 subtrees + EIf t a b -> T.Node (ENode (NSymbol (Symbol "if")) EvalUntried) + (map exprToTree [t, a, b]) + -- ECall maps to symbol f (function name) at the root, + -- each argument forms a subtree + ECall f args -> T.Node (ENode (NSymbol f) EvalUntried) + (map exprToTree args) + -- EList maps to the *symbol* (yes!) "[]" or to a ":" (cons) expression + EList [] -> T.Node (ENode (NSymbol (Symbol "[]")) EvalUntried) [] + EList (x:xs) -> exprToTree (ECall (Symbol ":") [x, EList xs]) + +-- | Convert an expression tree (back) to an expression +-- It will not give back the *same* expression in the case of an EList. +treeToExpr :: ExprTree -> Expr +treeToExpr (T.Node (ENode label _) trees) = + let wrong msg = + error $ concat ["treeToExpr: ", msg, ": node label = ", + show label, "; trees = ", show trees] + in case label of + NUndefined -> EUndefined + NSymbol s -> + if s == Symbol "if" + then case trees of + [q, a, b] -> + EIf (treeToExpr q) (treeToExpr a) (treeToExpr b) + _ -> wrong "'if' node with /= 3 subtrees" + else + -- VVV Do I really need to distinguish these two cases? + if null trees + then + -- s = terminal symbol + ESymbol s + else -- s = function symbol in function call + ECall s (map treeToExpr trees) + NLit lit -> if null trees then ELit lit + else wrong "literal node with non-empty subtrees" + +-- Convert an expression to a repr tree (of string elements) +-- (Why?) + +exprToReprTree :: Expr -> Tree String +exprToReprTree = fmap repr . exprToTree + +-- Evaluation results (or non-results) + +type EvalResult = EvalRes Value + +data EvalRes e = EvalOk e | EvalError String | EvalUntried + deriving (Eq, Show) + +instance Monad EvalRes where + EvalOk value >>= f = f value + EvalError e >>= _f = EvalError e + EvalUntried >>= _f = EvalUntried + return = EvalOk + fail = EvalError + +-- Evaluate an expression tree showing the evaluation at each node. +-- There's a lot of redundancy in this computation, but does it matter? + +evalTree :: ExprTree -> Env -> ExprTree +evalTree atree env = evalTreeWithLimit atree env stackSize + +evalTreeWithLimit :: ExprTree -> Env -> Int -> ExprTree +evalTreeWithLimit atree env stacksize = + + let T.Node root subtrees = atree + ss' = pred stacksize + in case root of + ENode (NSymbol (Symbol "if")) _ -> + case subtrees of + [tt, ta, tb] -> + let tt' = evalTreeWithLimit tt env ss' + ENode _ testResult = rootLabel tt' + subEval subtree = + let subtree' = evalTreeWithLimit subtree env ss' + ENode _ subresult = rootLabel subtree' + in (subresult, subtree') + ifNode result = ENode (NSymbol (Symbol "if")) result + in case testResult of + EvalOk (VBool True) -> + let (taValue, ta') = subEval ta in + T.Node (ifNode taValue) [tt', ta', tb] + + EvalOk (VBool False) -> + let (tbValue, tb') = subEval tb in + T.Node (ifNode tbValue) [tt', ta, tb'] + + EvalError msg -> + T.Node (ifNode (EvalError msg)) [tt', ta, tb] + + _ -> error $ "evalTreeWithLimit (if): " ++ + "unexpected test result" + + _ -> error "evalTreeWithLimit: if: wrong number of subtrees" + + ENode rootOper _ -> + T.Node (ENode rootOper (evalWithLimit (treeToExpr atree) env ss')) + [evalTreeWithLimit s env ss' | s <- subtrees] + +-- remove the values from the ExprNodes +-- "inverse" of evalTree +unevalTree :: ExprTree -> ExprTree +unevalTree atree = + let unevalNode (ENode oper _) = ENode oper EvalUntried + in fmap unevalNode atree + +-- VALUES AND EVALUATION + +data Value = VBool OBool + | VChar OChar + | VInt OInt + | VFloat OFloat + | VStr OStr + | VFun Function + | VList [Value] + deriving (Eq, Read, Show) + -- no Read for Function + +instance Repr Value where + repr (VBool b) = show b + repr (VChar c) = show c + repr (VInt i) = show i + repr (VFloat x) = show x + repr (VStr s) = show s + repr (VFun f) = show f + repr (VList l) = + "[" ++ + concat (intersperse ", " (map repr l)) ++ + "]" + +valueFunction :: Value -> Function +valueFunction value = + case value of + VFun function -> function + _ -> error "valueFunction: non-function value" + +-- | The value of an expression in the base environment. + +exprToValue :: Expr -> SuccFail Value +exprToValue expr = + case eval expr baseEnv of + EvalOk value -> Succ value + EvalError msg -> Fail msg + EvalUntried -> error "exprToValue: eval resulted in EvalUntried" + +valueToLiteral :: Value -> SuccFail Expr +valueToLiteral v = + case v of + VFun _f -> Fail "cannot convert a function to a literal" + _ -> Succ (ELit v) + +stringToValue :: String -> SuccFail Value +stringToValue s = + case stringToExpr s of + Succ expr -> exprToValue expr + Fail errmsg -> Fail errmsg + +data VpType = VpTypeString + | VpTypeChar + | VpTypeNum + | VpTypeBool + | VpTypeList VpType -- list with fixed type of elements + | VpTypeFunction [VpType] VpType -- argument, result types + | VpTypeVar String -- named type variable + deriving (Eq, Read, Show) + + +type TypeEnv = Map String VpType + +-- | Try to match a single type and value, +-- may result in binding a type variable in a new environment +-- or just the old environment +typeMatch :: VpType -> Value -> TypeEnv -> SuccFail TypeEnv +typeMatch vptype value env = + let sorry x etype = + Fail $ repr x ++ ": " ++ etype ++ " expected" + in case (vptype, value) of + -- easy cases + (VpTypeBool, VBool _) -> Succ env + (VpTypeBool, x) -> sorry x "True or False" + (VpTypeChar, VChar _) -> Succ env + (VpTypeChar, x) -> sorry x "character" + (VpTypeNum, VInt _) -> Succ env + (VpTypeNum, VFloat _) -> Succ env + (VpTypeNum, x) -> sorry x "number" + (VpTypeString, VStr _) -> Succ env + (VpTypeString, x) -> sorry x "string" + -- VV Harder + -- VV Are the avalues below supposed to be equal to the value above? + (VpTypeVar name, avalue) -> + case Map.lookup name env of + Nothing -> + -- bind type variable + vpTypeOf avalue >>= \ vtype -> Succ $ Map.insert name vtype env + Just concreteType -> typeMatch concreteType avalue env + (VpTypeList etype, VList lvalues) -> + case lvalues of + [] -> Succ env + v:vs -> + typeMatch etype v env >>= + typeMatch (VpTypeList etype) (VList vs) + (VpTypeFunction _atypes _rtype, _) -> + -- this will require matching type variables with type variables! + error "typeMatch: unimplemented case for VpTypeFunction" + _ -> Fail $ "type mismatch: " ++ show (vptype, value) + + +-- | Determine the type of a value. +-- May result in a type variable. + +vpTypeOf :: Value -> SuccFail VpType +vpTypeOf v = + case v of + VBool _ -> Succ VpTypeBool + VChar _ -> Succ VpTypeChar + VInt _ -> Succ VpTypeNum + VFloat _ -> Succ VpTypeNum + VStr _ -> Succ VpTypeString + VFun (Function _ atypes rtype _) -> Succ $ VpTypeFunction atypes rtype + + VList [] -> Succ $ VpTypeList $ VpTypeVar "list_element" + VList (x:xs) -> + do + xtype <- vpTypeOf x + xstypes <- mapM vpTypeOf xs + if filter (/= xtype) xstypes == [] + then Succ $ VpTypeList xtype + else Fail "list with diverse element types" + +-- | Check whether the values agree with the types (which may be abstract) +-- +-- This is *probably* too lenient in the case of type variables: +-- it can pass a mixed-type list. + +typeCheck :: [String] -> [VpType] -> [Value] -> SuccFail [Value] +typeCheck names types values = + let check :: TypeEnv -> [String] -> [VpType] -> [Value] -> SuccFail [Value] + check _ [] [] [] = Succ [] + check env (n:ns) (t:ts) (v:vs) = + case typeMatch t v env of + Succ env' -> check env' ns ts vs >>= Succ . (v:) + Fail msg -> Fail $ "For variable " ++ n ++ ":\n" ++ msg + check _ _ _ _ = error "typeCheck: mismatched list lengths" + in check empty names types values + +-- | A function may have a name and always has an implementation +data Function = Function (Maybe String) -- function name + [VpType] -- argument types + VpType -- result type + FunctionImpl -- implementation + deriving (Read, Show) + +data FunctionImpl = Primitive ([Value] -> EvalResult) -- a Haskell function + | Compound [String] Expr -- arguments, body + +instance Show FunctionImpl where + show (Primitive _) = "" + show (Compound args body) = + concat ["Compound function, args = " ++ show args ++ + "; body = " ++ show body] + +instance Read FunctionImpl where + readsPrec _ _ = error "readsPrec not implemented for FunctionImpl" + +instance Repr Function where + repr (Function mname _ _ _) = + case mname of + Nothing -> "" + Just name -> "" + +newUndefinedFunction :: String -> [String] -> Function +newUndefinedFunction name argnames = + let (atypes, rtype) = undefinedTypes argnames + impl = Compound argnames EUndefined + in Function (Just name) atypes rtype impl + +functionName :: Function -> String +functionName (Function mname _ _ _) = + case mname of + Just name -> name + Nothing -> "anonymous function" + +functionNArgs :: Function -> Int +functionNArgs = length . functionArgTypes + +functionArgTypes :: Function -> [VpType] +functionArgTypes (Function _ argtypes _ _) = argtypes + +functionResultType :: Function -> VpType +functionResultType (Function _ _ rtype _) = rtype + +-- -- | Type type of a function, a tuple of (arg types, result type) +-- -- Unused +-- functionType :: Function -> ([VpType], VpType) -- (args., result type) +-- functionType f = (functionArgTypes f, functionResultType f) + +functionImplementation :: Function -> FunctionImpl +functionImplementation (Function _ _ _ impl) = impl + +functionArgNames :: Function -> [String] +functionArgNames f = case functionImplementation f of + Primitive _ -> + ["dummy" | _t <- functionArgTypes f] + Compound args _body -> args + +type FunctionDefTuple = (String, [String], [VpType], VpType, Expr) + +functionToDef :: Function -> FunctionDefTuple +functionToDef (Function mname argTypes resType impl) = + case impl of + Primitive _ -> error "functionToDef: primitive function" + Compound argNames body -> + case mname of + Nothing -> error "functionToDef: unnamed function" + Just name -> (name, argNames, argTypes, resType, body) + +functionFromDef :: FunctionDefTuple -> Function +functionFromDef (name, argNames, argTypes, resType, body) = + Function (Just name) argTypes resType (Compound argNames body) + +functionBody :: Function -> Expr +functionBody f = case functionImplementation f of + Primitive _fp -> + error ("functionBody: " ++ + "no body available for primitive function") + Compound _args body -> body + +instance Eq Function where + Function Nothing _ _ _ == Function Nothing _ _ _ = + error "Function (==): equality of nameless functions is undecidable" + Function mname _ _ _ == Function mname' _ _ _ = mname == mname' + +-- | An Environment contains variable bindings and may be linked to +-- a next environment +-- +-- Perhaps it may also be used to generate Vp type variables (with int id's) + +type EnvFrame = Map String Value +type Env = [EnvFrame] -- should be NON-empty +type Binding = (String, Value) + +makeEnv :: [String] -> [Value] -> Env +makeEnv names values = extendEnv names values [] + +extendEnv :: [String] -> [Value] -> Env -> Env +extendEnv names values env = fromList (zip names values) : env + +-- | Insert names and values from lists into an environment +envInsertL :: Env -> [String] -> [Value] -> Env +envInsertL env names values = + case env of + [] -> error "envInsertL: empty list" + f : fs -> + let ins :: EnvFrame -> Binding -> EnvFrame + ins frame (name, value) = Map.insert name value frame + in foldl ins f (zip names values) : fs + +envIns :: Env -> String -> Value -> Env +envIns env name value = + case env of + [] -> error "envIns: empty list" + f : fs -> Map.insert name value f : fs + +envSet :: Env -> String -> Value -> Env +envSet env name value = + -- If name is bound in some map in the environment, update the binding + -- in that map; otherwise insert it into the "front" map + let loop :: Env -> Maybe Env + loop env1 = + case env1 of + [] -> Nothing + f:fs -> + case Map.lookup name f of + Just _ -> Just (envIns env1 name value) + Nothing -> + do -- in the Maybe monad: + fs' <- loop fs + return (f:fs') + + in case loop env of + Just result -> result + Nothing -> envIns env name value + +-- | Get the value of a variable from an environment +envGet :: Env -> String -> Value +envGet env name = case envLookup env name of + Just value -> value + Nothing -> error ("envGet: unbound variable: " ++ name) + +envGetFunction :: Env -> String -> Function +envGetFunction env name = func + where VFun func = envGet env name + +envLookup :: Env -> String -> Maybe Value +envLookup env name = + case env of + [] -> Nothing + f:fs -> + case Map.lookup name f of + Just value -> Just value + Nothing -> envLookup fs name + +envLookupFunction :: Env -> String -> Maybe Function +envLookupFunction env name = + case envLookup env name of + Nothing -> Nothing + Just value -> + case value of + VFun function -> Just function + _ -> Nothing + +-- | List of all symbols bound in the environment +envSymbols :: Env -> [String] +envSymbols env = + case env of + [] -> [] + f : fs -> keys f ++ envSymbols fs + +-- | List of all symbols bound to functions in the environment +envFunctionSymbols :: Env -> [String] +envFunctionSymbols env = + let isFunction s = case envGet env s of + VFun _ -> True + _ -> False + in [s | s <- envSymbols env, isFunction s] + +-- | Return to the environment prior to an extendEnv +envPop :: Env -> Env +envPop env = + case env of + [] -> error "envPop: empty list" + _f:fs -> fs + +unbound :: String -> Env -> Bool +unbound name env = envLookup env name == Nothing + +-- EVALUATING EXPRESSIONS + +-- Limit the stack size for recursion, since we are helping +-- novice programmers to learn + +stackSize :: Int +stackSize = 1000 + +eval :: Expr -> Env -> EvalResult +eval expr env = evalWithLimit expr env stackSize + +evalWithLimit :: Expr -> Env -> Int -> EvalResult + +-- Evaluate an expression in an environment with a limited stack + +evalWithLimit expr env stacksize = + if stacksize <= 0 + then EvalError "stack overflow" + else + let stacksize' = pred stacksize in + case expr of + EUndefined -> EvalError "undefined" + ESymbol (Symbol name) -> + case envLookup env name of + Nothing -> EvalError $ "unbound variable: " ++ name + Just value -> EvalOk value + + ELit value -> EvalOk value + + EIf t a b -> + case evalWithLimit t env stacksize' of + EvalOk (VBool True) -> evalWithLimit a env stacksize' + EvalOk (VBool False) -> evalWithLimit b env stacksize' + result -> result + + ECall fsym args -> + -- evaluating a function call + -- *I assume that call expressions have *symbols* for the + -- functions. + -- To relax this assumption: change the definition of ECall, + -- but how will you visualize it? + + case evalWithLimit (ESymbol fsym) env stacksize' of + EvalOk f -> + case mapM (\ a -> evalWithLimit a env stacksize') args of + EvalOk argvalues -> apply f argvalues env stacksize' + -- why doesn't this work? err -> err + EvalError e -> EvalError e + EvalUntried -> EvalUntried + err -> err + + EList elist -> + case mapM (\ elt -> evalWithLimit elt env stacksize') elist of + EvalOk values -> EvalOk (VList values) + EvalError e -> EvalError e + EvalUntried -> EvalUntried + +-- | Apply a function fvalue to a list of actual arguments args +-- in an environment env and with a limited stack size stacksize +apply :: Value -> [Value] -> Env -> Int -> EvalResult +apply fvalue args env stacksize = + case fvalue of + VFun f -> + case functionImplementation f of + Primitive pf -> pf args + Compound formalArgs body -> + evalWithLimit body (extendEnv formalArgs args env) stacksize + not_a_function -> + EvalError ("apply: first arg is not a function: " ++ + show not_a_function) + +-- Shortcuts for making expressions that call the primitive functions +ePlus :: Expr -> Expr -> Expr +ePlus e1 e2 = eCall "+" [e1, e2] + +eTimes :: Expr -> Expr -> Expr +eTimes e1 e2 = eCall "*" [e1, e2] + +eMinus, eDiv, eMod :: Expr -> Expr -> Expr +eMinus e1 e2 = eCall "-" [e1, e2] +eDiv e1 e2 = eCall "div" [e1, e2] +eMod e1 e2 = eCall "mod" [e1, e2] + +eAdd1, eSub1 :: Expr -> Expr +eAdd1 e1 = eCall "add1" [e1] +eSub1 e1 = eCall "sub1" [e1] + +eEq, eNe, eGt, eGe, eLt, eLe :: Expr -> Expr -> Expr +eEq e1 e2 = eCall "==" [e1, e2] +eNe e1 e2 = eCall "/=" [e1, e2] +eGt e1 e2 = eCall ">" [e1, e2] +eGe e1 e2 = eCall ">=" [e1, e2] +eLt e1 e2 = eCall "<" [e1, e2] +eLe e1 e2 = eCall "<=" [e1, e2] + + +eZerop, ePositivep, eNegativep :: Expr -> Expr +eZerop e1 = eCall "zero?" [e1] +ePositivep e1 = eCall "positive?" [e1] +eNegativep e1 = eCall "negative?" [e1] + +-- A good base environment to get started with + +primitiveFunctions :: [Function] +primitiveFunctions = [ + -- Arithmetic + primN2N "+" (+) (+), -- Integer (+), Double (+) + primN2N "-" (-) (-), + primN2N "*" (*) (*), + primIntDiv, + primIntMod, + primFloatDiv, + + primN1N "add1" succ succ, + primN1N "sub1" pred pred, + + -- Comparison + primN2B "==" (==) (==), + primN2B "/=" (/=) (/=), + primN2B ">" (>) (>), + primN2B ">=" (>=) (>=), + primN2B "<" (<) (<), + primN2B "<=" (<=) (<=), + + primN1B "zero?" (== 0) (== 0.0), + primN1B "positive?" (> 0) (> 0.0), + primN1B "negative?" (< 0) (< 0.0), + + -- List operations + + -- null xs tells if xs is an empty list + prim "null" [VpTypeList (VpTypeVar "a")] + VpTypeBool primNull, + + prim "head" [VpTypeList (VpTypeVar "c")] + (VpTypeVar "c") + primHead, + prim "tail" [VpTypeList (VpTypeVar "c")] + (VpTypeList (VpTypeVar "c")) + primTail, + prim ":" [VpTypeVar "d", VpTypeList (VpTypeVar "d")] + (VpTypeList (VpTypeVar "d")) + primCons + ] + +type PFun = [Value] -> EvalResult + +-- Primitive functions of arbitrary type +prim :: String -> [VpType] -> VpType -> PFun -> Function +prim name atypes rtype = Function (Just name) atypes rtype . Primitive + +-- Primitive arithmetic functions + +-- | Integer div and mod operations, for exact integers only. +-- Using an inexact (floating point) argument is an error, +-- even if the argument is "equal" to an integer (e.g., 5.0). +-- Division (div or mod) by zero is an error. +primIntDivMod :: String -> (OInt -> OInt -> OInt) -> Function +primIntDivMod name oper = + let func args = + let err msg = EvalError $ concat [name, ": ", msg, + " (", show args, ")"] + in case args of + [VInt a, VInt b] -> + if b == 0 + then err "zero divisor" + else EvalOk $ VInt (oper a b) + [VFloat _, _] -> err "arguments must be exact numbers" + [_, VFloat _] -> err "arguments must be exact numbers" + _ -> error "wrong type or number of arguments" + in prim name [VpTypeNum, VpTypeNum] VpTypeNum func + +primIntDiv, primIntMod :: Function +primIntDiv = primIntDivMod "div" div +primIntMod = primIntDivMod "mod" mod + +-- | Floating point division. +-- Integer arguments are coerced to floating point, +-- and the result is always floating point. +-- operands are ints. +-- x / 0 is NaN if x == 0, Infinity if x > 0, -Infinity if x < 0. +primFloatDiv :: Function +primFloatDiv = + let divide args = + case args of + [VInt ix, VInt iy] -> + EvalOk $ VFloat (fromIntegral ix / fromIntegral iy) + [VInt ix, VFloat y] -> EvalOk $ VFloat (fromIntegral ix / y) + [VFloat x, VInt iy] -> EvalOk $ VFloat (x / fromIntegral iy) + [VFloat x, VFloat y] -> EvalOk $ VFloat (x / y) + _ -> EvalError $ "/: invalid args: " ++ show args + in prim "/" [VpTypeNum, VpTypeNum] VpTypeNum divide + +-- Primitive functions for lists + +primArgError :: String -> EvalResult +primArgError name = + error $ name ++ ": wrong number of arguments in primitive function" + +primNull :: PFun +primNull [VList list] = EvalOk $ VBool (List.null list) +primNull _ = primArgError "primNull" + +primHead :: PFun +primHead [VList list] = + case list of + x : _xs -> EvalOk x + [] -> EvalError "head: empty list" +primHead _ = primArgError "primHead" + +primTail :: PFun +primTail [VList list] = + case list of + _x : xs -> EvalOk $ VList xs + [] -> EvalError "tail: empty list" +primTail _ = primArgError "primTail" + +primCons :: PFun +primCons [x, VList xs] = EvalOk $ VList (x:xs) +primCons _ = primArgError "primCons" + +-- Functions for constructing Functions of common types + +-- | Primitive function with 2 number arguments yield an number value +-- fi = integer function to implement for integer operands. +-- fx = float function to implement for float operands. +primN2N :: String -> (OInt -> OInt -> OInt) -> (OFloat -> OFloat -> OFloat) + -> Function +primN2N name fi fx = + let impl args = + case args of + [VInt ix, VInt iy] -> EvalOk $ VInt (fi ix iy) + [VInt ix, VFloat y] -> EvalOk $ VFloat (fx (fromIntegral ix) y) + [VFloat x, VInt iy] -> EvalOk $ VFloat (fx x (fromIntegral iy)) + [VFloat x, VFloat y] -> EvalOk $ VFloat (fx x y) + _ -> EvalError $ name ++ ": invalid args: " ++ show args + in prim name [VpTypeNum, VpTypeNum] VpTypeNum impl + +-- | Primitive unary functions number to number +primN1N :: String -> (OInt -> OInt) -> (OFloat -> OFloat) -> Function +primN1N name fi fx = + let impl args = + case args of + [VInt ix] -> EvalOk $ VInt (fi ix) + [VFloat x] -> EvalOk $ VFloat (fx x) + _ -> EvalError $ name ++ ": invalid args: " ++ show args + in prim name [VpTypeNum] VpTypeNum impl + +-- Primitive frunctions with 2 number args and a boolean result +primN2B :: String -> (OInt -> OInt -> OBool) -> (OFloat -> OFloat -> OBool) + -> Function +primN2B name fi fx = + let impl args = + case args of + [VInt x, VInt y] -> EvalOk $ VBool (fi x y) + [VInt ix, VFloat y] -> EvalOk $ VBool (fx (fromIntegral ix) y) + [VFloat x, VInt iy] -> EvalOk $ VBool (fx x (fromIntegral iy)) + [VFloat x, VFloat y] -> EvalOk $ VBool (fx x y) + _ -> EvalError $ name ++ ": invalid args: " ++ show args + in prim name [VpTypeNum, VpTypeNum] VpTypeBool impl + + +-- Primitive unary functions number to boolean +primN1B :: String -> (OInt -> Bool) -> (OFloat -> OBool) -> Function +primN1B name fi fx = + let impl args = + case args of + [VInt ix] -> EvalOk $ VBool (fi ix) + [VFloat x] -> EvalOk $ VBool (fx x) + _ -> EvalError $ name ++ ": invalid args: " ++ show args + in prim name [VpTypeNum] VpTypeBool impl + +baseEnv :: Env +baseEnv = + makeEnv (map functionName primitiveFunctions) + (map VFun primitiveFunctions) + +-- | Given an expression, return the list of names of variables +-- occurring n the expression +exprSymbols :: Expr -> [Symbol] +exprSymbols expr = + nub $ case expr of + EUndefined -> [] -- is *not* a variable + ESymbol s -> [s] + ELit _ -> [] + EIf t a b -> nub $ concat [exprSymbols t, + exprSymbols a, + exprSymbols b] + ECall f args -> + case args of + [] -> [f] + a:as -> nub $ concat [exprSymbols a, + exprSymbols (ECall f as)] + EList items -> nub $ concatMap exprSymbols items + +-- | exprVarNames expr returns the names of variables in expr +-- that are UNBOUND in the base environment. This may not be ideal, +-- but it's a start. + +exprVarNames :: Expr -> [String] +exprVarNames expr = [name | (Symbol name) <- exprSymbols expr, + unbound name baseEnv] + +-- | decideTypes tries to find the argument types and return type +-- of an expression considered as the body of a function, +-- at the same time checking for consistency of inputs and +-- outputs between the parts of the expression. +-- It returns Right (argtypes, returntype) if successful; +-- Left errormessage otherwise. + +decideTypes :: Expr -> [String] -> Env -> Either String ([VpType], VpType) +decideTypes expr args _env = + unsafePerformIO $ do + { + print "Fudged the decideTypes" + ; print expr + ; return (if True + then Right (undefinedTypes args) + else Left "decideTypes: not implemented") + } + +undefinedTypes :: [String] -> ([VpType], VpType) +undefinedTypes argnames = + let atypes = [VpTypeVar ('_' : name) | name <- argnames] + rtype = VpTypeVar "_result" + in (atypes, rtype) diff --git a/Geometry.hs b/Geometry.hs new file mode 100644 --- /dev/null +++ b/Geometry.hs @@ -0,0 +1,131 @@ +module 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) + ) + +where + +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 diff --git a/GtkForeign.hs b/GtkForeign.hs new file mode 100644 --- /dev/null +++ b/GtkForeign.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE ForeignFunctionInterface, CPP #-} +{-# INCLUDE /usr/include/gtk-2.0/gtk/gtk.h #-} +{-# INCLUDE /usr/include/gtk-2.0/gdk/gdk.h #-} + +-- NOTE: START GHCI AS FOLLOWS: +-- ghci -lgtk-x11-2.0 -lgdk-x11-2.0 +-- ================================ + +-- File: GtkForeign.hs +-- Foreign functions from Gtk + +-- CURSOR SHAPES +-- Original source: https://sourceforge.net/mailarchive/forum.php?thread_name=87ps50ie9o.fsf%40loki.cmears.id.au&forum_name=gtk2hs-users +-- Copyright status ?????? + +{- +Re: [Gtk2hs-users] Changing the mouse cursor shape +From: Chris Mears - 2007-05-22 07:48 +Hi Axel, + +Axel Simon writes: + +> We haven't done that yet. +> The functions required are a few in Gdk for creating cursors and looking +> up stock cursors. Also, in Gdk.DrawWindow the function +> gdk_window_set_cursor would need to be bound. If changing cursors would +> be useful for your application, then I can add these functions into the +> next minor release which Duncan wants to do soon. + +Thanks for the information. With your pointers, I was able to hack up +the following code to suit my needs: + +data Cursor = Cursor +type CursorPtr = Ptr Cursor +foreign import ccall "gdk_window_set_cursor" gdkWindowSetCursor :: Ptr DrawWindow -> CursorPtr -> IO () +foreign import ccall "gdk_cursor_new" gdkCursorNew :: Int -> IO CursorPtr +setCursor :: Window -> IO () +setCursor window = do +c <- gdkCursorNew 34 -- the 'crosshair' cursor +d <- widgetGetDrawWindow window +withForeignPtr (unDrawWindow d) $ \ptr -> gdkWindowSetCursor ptr c + +I tried briefly to add some of the bindings to the library, but I don't +understand the build system or the library design well enough to do it +properly. I can confirm that adding the cursor bindings is not very +hard. If you could add them, that would be great, but you needn't do it +solely on my account. + +Chris +-} + +-- Gtk2hs has added a definition of CursorType in version 0.10.1, +-- but in version 0.10.0 and lower, we have to do it ourselves. + +#if MIN_VERSION_gtk(0,10,1) +#define GTK_HAS_CURSOR_TYPE 1 +#else +#define GTK_HAS_CURSOR_TYPE 0 +#endif + +module GtkForeign + ( +#if GTK_HAS_CURSOR_TYPE + Graphics.UI.Gtk.CursorType(..) +#else + CursorType(..) +#endif + , setCursor) +where + +import System.Glib +import System.Glib.FFI +import Foreign.ForeignPtr (castForeignPtr) +import Graphics.UI.Gtk + +-- type CursorPtr = Ptr Cursor + +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 + +#if ! GTK_HAS_CURSOR_TYPE +-- Cursor types are added to gtk2hs in v. 0.10.1, but we need this for +-- earlier versions including 0.10.0. +-- For illustrations, see +-- http://www.pygtk.org/docs/pygtk/class-gdkcursor.html + +data CursorType = XCursor + | Arrow + | BasedArrowDown + | BasedArrowUp + | Boat + | Bogosity + | BottomLeftCorner + | BottomRightCorner + | BottomSide + | BottomTee + | BoxSpiral + | CenterPtr + | Circle + | Clock + | CoffeeMug + | Cross + | CrossReverse + | Crosshair + | DiamondCross + | Dot + | Dotbox + | DoubleArrow + | DraftLarge + | DraftSmall + | DrapedBox + | Exchange + | Fleur + | Gobbler + | Gumby + | Hand1 + | Hand2 + | Heart + | Icon + | IronCross + | LeftPtr + | LeftSide + | LeftTee + | Leftbutton + | LlAngle + | LrAngle + | Man + | Middlebutton + | Mouse + | Pencil + | Pirate + | Plus + | QuestionArrow + | RightPtr + | RightSide + | RightTee + | Rightbutton + | RtlLogo + | Sailboat + | SbDownArrow + | SbHDoubleArrow + | SbLeftArrow + | SbRightArrow + | SbUpArrow + | SbVDoubleArrow + | Shuttle + | Sizing + | Spider + | Spraycan + | Star + | Target + | Tcross + | TopLeftArrow + | TopLeftCorner + | TopRightCorner + | TopSide + | TopTee + | Trek + | UlAngle + | Umbrella + | UrAngle + | Watch + | Xterm + | LastCursor + | CursorIsPixmap + deriving (Eq, Read, Show) +#endif + +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 -> (-1) + CursorIsPixmap -> (-1) diff --git a/GtkUtil.hs b/GtkUtil.hs new file mode 100644 --- /dev/null +++ b/GtkUtil.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE CPP #-} + +module GtkUtil (suppressScimBridge, + createDialog, defaultDialogPosition, + runDialogM, runDialogS, + -- runDialogHelper, + showInputErrorMessage, showErrorMessage, showInfoMessage, + showMessage, + EntryDialog, Reader, + createEntryDialog, runEntryDialog, + addEntryWithLabel + ) + +where + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import System.Posix.Env +#endif +import Graphics.UI.Gtk + +import 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 + +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 + return Nothing + 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Sifflet License + +Copyright (C) 2010 Gregory D. Weber +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + +- Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,36 @@ +Sifflet -- README -- Sifflet + +Rights +------ + +Copyright (C) 2010 Gregory D. Weber + +BSD3 license -- see the file "LICENSE" for details + +Installation +------------ + +1. Configure, either for system-wide installation: + + $ runghc Setup configure + + or for installation in a user directory: + + $ runghc Setup configure --user --prefix=~/where/to/install/ + +2. Build and install: + + $ runghc Setup build + $ runghc Setup install + +Documentation +------------- + +Please see the Sifflet home page for documentation: + + http://mypage.iu.edu/~gdweber/software/sifflet/ + +and especially the tutorial: + + http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html + diff --git a/RPanel.hs b/RPanel.hs new file mode 100644 --- /dev/null +++ b/RPanel.hs @@ -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 RPanel + ( + RPanel, newRPanel, rpanelId, rpanelRoot, rpanelContent + , rpanelAddWidget, rpanelAddWidgets, rpanelNewRow + , rpanelAddRows + ) + +where + +import Control.Monad +import Graphics.UI.Gtk + +import Util + +debugTracing :: Bool +debugTracing = False + +data RPanel + = RPanel { + -- Public + rpId :: String -- ^ text for the expander button + , rpRoot :: Frame -- ^ use the root to add rpanel to a container + , rpContent :: [[String]] -- ^ ids of widgets added, in rows + + -- Widgets that make up the RPanel + , rpFrame :: Frame -- ^ 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 -> Frame +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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +-- Simple setup +import Distribution.Simple +main = defaultMain diff --git a/SiffML.hs b/SiffML.hs new file mode 100644 --- /dev/null +++ b/SiffML.hs @@ -0,0 +1,394 @@ +-- | SiffML : Sifflet Markup Language. +-- An XML application for storing and retrieving Sifflet programs +-- and libraries. + +module SiffML + ( + ToXml(..) + , produceFile + , consumeFile + , Functions(..) + , xmlToFunctions + , testOut -- testing + , xmlToX -- testing + , testIn, testFromFile -- testing + ) + +where + +import Text.XML.HXT.Arrow +import Text.XML.HXT.DOM.FormatXmlTree + +import Expr +import Examples + +class ToXml a where + toXml :: a -> Producer + +-- | A Producer produces XML +type Producer = IOSLA (XIOState ()) XmlTree XmlTree + +-- | A Consumer consumes XML +type Consumer a b = IOSLA (XIOState ()) a b + +defaultOptions = [(a_indent, v_yes), (a_validate, v_no)] + +produceStdout :: (ToXml a) => a -> IO () +produceStdout src = produceFile src "-" + +produceFile :: (ToXml a) => a -> FilePath -> IO () +produceFile src path = + let arrow :: Producer + arrow = toXml src + options = defaultOptions + in do + { + putStrLn "" + ; [rc] <- runX (root [] [arrow] >>> + writeDocument options path >>> + getErrStatus) + ; putStrLn (case rc of + 0 -> "Okay" + _ -> "Failed") + + } + +produceXmlTrees :: (ToXml a) => a -> IO [XmlTree] +produceXmlTrees src = + let arrow :: Producer + arrow = toXml src + options = defaultOptions + in do + { + putStrLn "" + ; docs <- runX (root [] [arrow] >>> writeDocument options "-") + ; case docs of + [] -> putStrLn "Failed" + doc : _ -> + print doc + ; return docs + + } + + +consumeFile :: Consumer XmlTree a -> FilePath -> IO [a] +consumeFile fromXml filePath = + let options = defaultOptions + in runX (readDocument options filePath >>> fromXml) + +consumeStdin :: Consumer XmlTree a -> IO [a] +consumeStdin fromXml = consumeFile fromXml "-" + +-- | testFromXml :: (ToXml a, Show a) => a -> Consumer XmlTree a -> IO () +-- VVV This type generalization (a, a to a, b) is for debugging, undo it later: +testFromXml :: (ToXml a, Show b) => a -> Consumer XmlTree b -> IO () +testFromXml src consumer = do + { + produceFile src "test.xml" + ; results <- runX (readDocument defaultOptions "test.xml" >>> + isElem >>> -- document root + getChildren >>> + consumer) + ; case results of + [] -> putStrLn "Failed" + result : _ -> print result + } + +testToXmlAndBack :: (ToXml a, Show a) => a -> Consumer XmlTree a -> IO () +testToXmlAndBack = testFromXml + +-- | Symbols + +instance ToXml Symbol where + toXml = symbolToXml + +symbolToXml :: Symbol -> Producer +symbolToXml (Symbol name) = + selem "symbol" [txt name] + +xmlToSymbol :: Consumer XmlTree Symbol +xmlToSymbol = + isElem >>> hasName "symbol" >>> -- symbol element + getChildren >>> isText >>> -- text element + getText >>> -- String + arr Symbol -- quasi (return . Symbol) + +testXmlToSymbol :: Symbol -> IO () +testXmlToSymbol sym = testFromXml sym xmlToSymbol + + +-- | Expr + +instance ToXml Expr where + toXml = exprToXml + +exprToXml :: Expr -> Producer +exprToXml expr = + case expr of + EUndefined -> + eelem "undefined" + ESymbol (Symbol name) -> + selem "symbol" [txt name] + -- ** To simplify, collapse 2.5 + -- to 2.5, and similarly with other + -- literal values? + ELit value -> + selem "literal" [toXml value] + EIf e1 e2 e3 -> + selem "if" [toXml e1, toXml e2, toXml e3] + EList xs -> + selem "list" (map toXml xs) + ECall (Symbol name) xs -> + selem "call" + (selem "symbol" [txt name] : + map toXml xs) + +xmlToExpr :: Consumer XmlTree Expr +xmlToExpr = + isElem >>> + ( + (hasName "undefined" >>> constA EUndefined) <+> + (hasName "symbol" >>> getChildren >>> isText >>> getText >>> + arr (ESymbol . Symbol)) <+> + (hasName "literal" >>> getChildren >>> xmlToValue >>> arr ELit) <+> + (hasName "if" >>> listA (getChildren >>> xmlToExpr) >>> + arr (\ [a, b, c] -> EIf a b c)) <+> + (hasName "list" >>> listA (getChildren >>> xmlToExpr) >>> arr EList) <+> + -- VVV Would be less awkward if ECall :: Symbol -> [Expr] -> Expr + -- were changed to ECall :: Expr -> [Expr] -> Expr + (hasName "call" >>> listA (getChildren >>> xmlToExpr) >>> + arr (\ (ESymbol symf : args) -> ECall symf args)) + ) + +exampleIfExpr = (EIf (ELit (VBool False)) -- (eCall ">" [eInt 32, eInt 61]) + (ELit (VStr "yes")) + (ELit (VStr "no"))) + +exampleListExpr = EList [ELit (VInt 1), ELit (VInt 2), ELit (VInt 3)] + +exampleCallExpr = ECall (Symbol "foo") [ESymbol (Symbol "x"), ELit (VInt 2)] + +-- | Values + +instance ToXml Value where + toXml = valueToXml + +valueToXml :: Value -> Producer +valueToXml value = + case value of + VBool b -> + -- or + -- complicate? selem "bool" [txt (show b)] + eelem (show b) + VChar c -> + selem "char" [txt [c]] + VStr s -> + selem "string" [txt s] + VInt i -> + selem "int" [txt (show i)] + VFloat x -> + selem "float" [txt (show x)] + -- *** Are VFun and VList needed??? + VFun f -> + selem "function" [toXml f] + VList vs -> + selem "list" (map toXml vs) + +exampleVList :: Value +exampleVList = VList [VInt 32, VInt 64, VInt 69] + +xmlToValue :: Consumer XmlTree Value +xmlToValue = + isElem >>> + ((hasName "True" >>> constA (VBool True)) <+> + (hasName "False" >>> constA (VBool False)) <+> + (hasName "char" >>> getChildren >>> isText >>> getText >>> + arr (VChar . head)) <+> + (hasName "string" >>> getChildren >>> isText >>> getText >>> + arr VStr) <+> + (hasName "int" >>> getChildren >>> isText >>> getText >>> + arr (VInt . read)) -- dangerous? + <+> + (hasName "float" >>> getChildren >>> isText >>> getText >>> + arr (VFloat . read)) -- dangerous? + + <+> + (hasName "function" >>> getChildren >>> xmlToFunction >>> arr VFun) + + <+> + -- listA arr collects the results of arr into a list, so to speak; + -- note that listA (arr1 >>> arr2) + -- does not equal listA arr1 >>> listA arr2 + -- and probably will not even have a well-defined type. + -- In particular: + -- getChildren --> [child1] + -- listA getChildren --> [childi for i = 1 to n] + -- listA getChildren >>> xmlToValue + -- --> [child1] if child1 passes xmlToValue (it does not) + -- listA (getChildren >>> xmlToValue) + -- --> [childi for i = 1 to n if childi passes xmlToValue] + (hasName "list" >>> listA (getChildren >>> xmlToValue) >>> + arr VList) + ) + +-- | VpTypes + +instance ToXml VpType where + toXml = vpTypeToXml + +vpTypeToXml :: VpType -> Producer +vpTypeToXml vtype = + case vtype of + VpTypeString -> eelem "string-type" + VpTypeChar -> eelem "char-type" + VpTypeNum -> eelem "num-type" + VpTypeBool -> eelem "bool-type" + VpTypeList eltType -> selem "list-type" [vpTypeToXml eltType] + VpTypeVar typeVarName -> selem "type-variable" [txt typeVarName] + +xmlToVpType :: Consumer XmlTree VpType +xmlToVpType = + isElem >>> + ((hasName "string-type" >>> constA VpTypeString) <+> + (hasName "char-type" >>> constA VpTypeChar) <+> + (hasName "num-type" >>> constA VpTypeNum) <+> + (hasName "bool-type" >>> constA VpTypeBool) <+> + (hasName "list-type" >>> getChildren >>> xmlToVpType >>> + arr VpTypeList) <+> + (hasName "type-variable" >>> getChildren >>> + isText >>> getText >>> arr VpTypeVar) + ) + +-- | Functions + +instance ToXml Function where + toXml = functionToXml + +functionToXml :: Function -> Producer +functionToXml (Function mName argTypes retType impl) = + case impl of + Primitive _ -> + -- shouldn't happen + error ("functionToXml: primitive functions cannot be exported to XML" + ++ show (mName, argTypes, retType)) + Compound argNames body -> + selem "compound-function" + (let name name = selem "name" [txt name] + rest = + [selem "return-type" [vpTypeToXml retType], + selem "arg-types" (map vpTypeToXml argTypes), + selem "arg-names" (map name argNames), + selem "body" [toXml body]] + in case mName of + Nothing -> rest + Just fName -> name fName : rest + ) + +xmlToFunction :: Consumer XmlTree Function +xmlToFunction = + let getChildElem :: Consumer XmlTree XmlTree + getChildElem = getChildren >>> isElem + + getFuncName :: Consumer XmlTree String + getFuncName = hasName "name" >>> getChildren >>> isText >>> getText + + getReturnType :: Consumer XmlTree VpType + getReturnType = hasName "return-type" >>> getChildren >>> xmlToVpType + + getArgTypes :: Consumer XmlTree [VpType] + getArgTypes = hasName "arg-types" >>> + listA (getChildren >>> xmlToVpType) + + getArgNames :: Consumer XmlTree [String] + getArgNames = hasName "arg-names" >>> + listA (getChildElem >>> getFuncName) + + getBody :: Consumer XmlTree Expr + getBody = hasName "body" >>> getChildren >>> xmlToExpr + + in + isElem >>> hasName "compound-function" >>> + -- NOTE: + -- If arr1 "produces" a, and arr2 "produces" b, + -- then (arr1 &&& arr2) "produces" (a, b). + ( + ( -- function name is optional, though it *should* be in the XML file + listA (getChildElem >>> getFuncName)) &&& + (getChildElem >>> getReturnType) &&& + (getChildElem >>> getArgTypes) &&& + (getChildElem >>> getArgNames) &&& + (getChildElem >>> getBody) + ) + >>> + (arr (\ (names, (returnType, (argTypes, (argNames, body)))) -> + Function (case names of + [] -> Nothing + (fname : _) -> (Just fname) + ) + argTypes + returnType (Compound argNames body))) + +exampleFunction = + let esym = ESymbol . Symbol + in Function (Just "cincr") + [VpTypeBool, VpTypeNum, VpTypeNum] + VpTypeNum + (Compound ["incr", "a", "b"] + (EIf (esym "incr") + (ECall (Symbol "+") [esym "a", esym "b"]) + (esym "a"))) + +-- | A collection of functions, to be saved or read from a file + +data Functions = Functions [Function] + deriving (Eq, Show) + +functionsToXml :: Functions -> Producer +functionsToXml (Functions fs) = + selem "functions" (map toXml fs) + +xmlToFunctions :: Consumer XmlTree Functions +xmlToFunctions = + isElem >>> -- document root + getChildren >>> + hasName "functions" >>> + listA (getChildren >>> xmlToFunction) >>> + arr Functions + + +-- | This is for testing, when I don't know the type +-- of the result I'm getting +xmlToX :: Consumer XmlTree Functions -- [Function] -- XmlTree +xmlToX = + isElem -- document root + >>> + getChildren + >>> + hasName "functions" + >>> + listA (getChildren >>> xmlToFunction) + >>> + arr Functions + +instance ToXml Functions where + toXml = functionsToXml + +-- | Tests + +testOut :: IO () +testOut = + produceStdout (Functions [exampleFunctions !! 0, exampleFunctions !! 1]) + + +testFromFile :: (Show a) => Consumer XmlTree a -> FilePath -> IO () +testFromFile fromXml filePath = do + { + results <- consumeFile fromXml filePath + ; putStrLn "" + ; print (length results) + ; print results + ; putStrLn "" + } + +testIn :: (Show a) => Consumer XmlTree a -> IO () +testIn fromXml = testFromFile fromXml "-" diff --git a/Tree.hs b/Tree.hs new file mode 100644 --- /dev/null +++ b/Tree.hs @@ -0,0 +1,97 @@ +-- Tree.hs +-- General (not binary) trees + +module 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) +where + +import Data.Tree as T + +-- 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. +-} + +-- class Repr: representable by a String or a list of Strings + +-- repr x is a String representation of x. +-- reprl x is a [String] representation of x, +-- where the first element should be the same as repr x, +-- and the extra values, if any, provide auxiliary information, +-- such as the value of x. +-- reprs x is a reduction of reprl x to a single String. +-- +-- Minimal complete implementation: define repr, or define reprl. + +class Repr a where + + repr :: a -> String + repr = head . reprl + + reprl :: a -> [String] + reprl x = [repr x] + + reprs :: a -> String + reprs = unwords . reprl + +instance Repr Int where repr = show +instance Repr Integer where repr = show +instance Repr Float where repr = show +instance Repr Double where repr = show + +-- instance Repr String won't work because String is a type synonym, +-- unless you ask ghc nicely, which I'd prefer not to do. +-- Use Name data type in Testing/Tree.hs instead, or Symbol in Expr.hs +-- I don't know if I can use Expr.Symbol here, since Expr.hs also +-- imports Tree.hs (this file) -- is mutual import allowed? + +data Name = Name String + deriving (Eq, Read, Show) + +instance Repr Name where + repr (Name s) = s + +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 . drawTree . fmap show diff --git a/TreeGraph.hs b/TreeGraph.hs new file mode 100644 --- /dev/null +++ b/TreeGraph.hs @@ -0,0 +1,416 @@ +module 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, + + -- Tree graph rendering + graphQuickView, + graphWriteImageFile, graphRender, treeRender, + treeWriteImageFile, gtkShowTree + ) + +where + +import IO +import Data.IORef +import Data.List (sort, sortBy) +import System.Cmd + +import Data.Graph.Inductive as G + +import Graphics.UI.Gtk hiding (Function, Style, fill, lineWidth) +import Graphics.UI.Gtk.Gdk.EventM + +import Graphics.Rendering.Cairo hiding (translate) + +import Geometry +import Tree as T +import TreeLayout +import Expr +import Util +import Workspace.Functoid +import Workspace.WGraph + +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 -> + error $ "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))) + _ -> error ("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} -> + let roots = suc graph frameNode + expr = treeToExpr $ graphToExprTree graph (head roots) + impl = Compound args expr + in + -- Check whether the frame contains a single tree + if length roots /= 1 + then Fail "The graph structure is not a tree!" + else case decideTypes expr args env of + Left errmsg -> Fail errmsg + Right (atypes, rtype) -> + Succ (Function (Just name) atypes rtype impl) + + +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) + + + +-- ============================================================ +-- 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 + } diff --git a/TreeLayout.hs b/TreeLayout.hs new file mode 100644 --- /dev/null +++ b/TreeLayout.hs @@ -0,0 +1,854 @@ +module TreeLayout + (VColor(..), white, cream, black, lightBlue, lightBlueGreen, + lightGray, mediumGray, darkGray, + yellow, darkBlueGreen, blueGreen, + Style(..), VFont(..), defaultStyle, style0, style1, style2, style3, + wstyle, + styleIncreasePadding, + FontTextExtents(..), setFont, ftExtents, + TextBox(..), makeTextBox, tbWidth, tbHeight, tbBottom, drawTextBox, + tbCenter, tbTextCenter, tbBoxCenter, offsetTextBoxCenters, + tbSetWidth, + setColor, + treeSizes, + GNode(..), treeGNodes, gnodeText, gnodeTextBB, + Iolet(..), ioletCenter, makeIolets, makeIoletsRow, + pointInIolet, + IoletCounter, zeroIoletCounter, + makeGNode, + TreeLayout, LayoutNode(..), layoutNodeSource, layoutRootBB, layoutTreeBB, + treeLayout, + treeLayoutPaddedSize, treeLayoutSize, treeLayoutWidth, + layoutTreeMoveCenterTo, + pointInLayoutNode, pointInGNode, findRect, + Draw(..), DrawMode(..), modeTextCol, modeEdgeCol, modeFillCol, + drawBox, + treeLayoutWiden + ) +where + +import System.IO.Unsafe + +import Graphics.Rendering.Cairo hiding (translate) +import Graphics.UI.Gtk (Rectangle) +import Control.Monad (when) +import Data.Traversable () -- imports only instance declarations + +import Geometry +import Tree as T hiding (tree) +import Util + +data VColor = ColorRGB Double Double Double | + ColorRGBA Double Double Double Double + +black, white, cream, lightBlue, lightBlueGreen :: VColor + +black = ColorRGB 0 0 0 +white = ColorRGB 1 1 1 +cream = ColorRGB 0.94902 0.94902 0.82745 +lightBlue = ColorRGB 0.43529 0.43922 0.95686 +lightBlueGreen = ColorRGB 0 1 1 + +lightGray, mediumGray, darkGray :: VColor +lightGray = ColorRGBA 0.75 0.75 0.75 0.5 +mediumGray = ColorRGB 0.5 0.5 0.5 +darkGray = ColorRGB 0.25 0.25 0.25 + +yellow, darkBlueGreen, blueGreen :: VColor + +yellow = ColorRGB 0.9 0.9 0 +darkBlueGreen = ColorRGB 0 0.3 0.3 +blueGreen = ColorRGB 0 0.4 0.4 + +-- darkRed = ColorRGB 0.5 0 0, -- dark red + +data VFont = VFont {vfontFace :: String, vfontSlant :: FontSlant, + vfontWeight :: FontWeight, + vfontSize :: Double} + +data Style = + Style {styleFont :: VFont, + lineWidth :: Double, + textMargin :: Double, -- in box on all four sides + hpad, vpad :: Double, -- internode (interbox) spacing + exomargin :: Double, -- margin of the tree within the window + vtinypad :: (Double, Double), -- node-edge spacing (above, below) + styleFramePad :: Double, -- pad between frames + styleNormalTextColor, styleNormalFillColor, + styleNormalEdgeColor, + styleActiveTextColor, styleActiveFillColor, + styleActiveEdgeColor, + styleSelectedTextColor, styleSelectedFillColor, + styleSelectedEdgeColor, + styleTetherColor :: VColor, + -- auxiliary text style, e.g., the value of an ExprNode + styleAuxOffset :: Position, -- center-to-center offset dx dy + styleAuxColor :: VColor, + styleAuxFont :: VFont, + styleIoletRadius :: Double, -- *** could extend to other shapes + styleShowNodeBoxes :: Bool, -- draw a box around expr nodes + styleShowNodePorts :: Bool -- draw the I/O ports of expr nodes + } + +styleIncreasePadding :: Style -> Double -> Style +-- increase hpad, vpad of style by multiplication +styleIncreasePadding style factor = + style {hpad = factor * hpad style, + vpad = factor * vpad style} + +style0, style1, style2, style3, defaultStyle :: Style + +style0 = + let green = ColorRGB 0.1 0.9 0.1 + veryDarkGray = ColorRGB 0.1 0.1 0.1 + brighterGreen = ColorRGB 0.5 0.95 0.5 + in Style {styleFont = VFont "serif" FontSlantNormal FontWeightNormal 18, + lineWidth = 2, + textMargin = 18.0, -- text within its box + hpad = 27, vpad = 36, -- inter-node separation + exomargin = 0, + vtinypad = (4.5, 4.5), -- node-edge separation + styleFramePad = 35, -- padding between frames + -- Foreground and background colors + styleNormalTextColor = green, + styleNormalEdgeColor = green, + styleNormalFillColor = veryDarkGray, + styleActiveTextColor = brighterGreen, + styleActiveEdgeColor = brighterGreen, + styleActiveFillColor = mediumGray, + styleSelectedTextColor = blueGreen, + styleSelectedEdgeColor = blueGreen, + styleSelectedFillColor = darkGray, + styleTetherColor = white, + styleAuxOffset = Position 0.0 (-20.0), + styleAuxColor = lightGray, + styleAuxFont = + VFont "serif" FontSlantItalic FontWeightNormal 12, + styleIoletRadius = 5, + styleShowNodeBoxes = True, -- draw a box around expr nodes + styleShowNodePorts = True -- draw the I/O ports of expr nodes + } + +style1 = + let veryDarkBlue = ColorRGB 0 0 0.1 + pinkIHope = ColorRGB 1 0.9 0.9 + in style0 {styleNormalTextColor = veryDarkBlue, + styleNormalEdgeColor = veryDarkBlue, + styleNormalFillColor = lightGray, + styleActiveTextColor = pinkIHope, + styleActiveEdgeColor = pinkIHope + } + +style2 = + let darkPink = ColorRGB 1 0.5 0.5 + in style1 {styleNormalFillColor = white, + styleActiveTextColor = darkPink, + styleActiveEdgeColor = darkPink} + +style3 = + let semiTranspBlue = ColorRGBA 0 0.2 0.9 0.5 + in style0 {exomargin = 10, + styleNormalTextColor = yellow, + styleNormalEdgeColor = yellow, + styleNormalFillColor = darkBlueGreen, + styleActiveTextColor = yellow, + styleActiveEdgeColor = yellow, + styleActiveFillColor = blueGreen, + styleAuxColor = semiTranspBlue + } + +defaultStyle = style3 + +wstyle :: Style +wstyle = + style3 { + -- smaller to allow multiple frames on one canvas + styleFont = VFont "serif" FontSlantNormal FontWeightNormal 14, + textMargin = 8.0, + hpad = 10.0, vpad = 24.0, + vtinypad = (0.0, 0.0), + exomargin = 10.0, -- between tree and window edges + styleFramePad = 15, + + -- colors + styleNormalTextColor = yellow, + styleNormalEdgeColor = mediumGray, + styleNormalFillColor = darkBlueGreen, + + styleActiveTextColor = yellow, + styleActiveEdgeColor = mediumGray, + styleActiveFillColor = blueGreen, + + styleSelectedTextColor = black, + styleSelectedEdgeColor = lightBlueGreen, + styleSelectedFillColor = lightBlueGreen, + + styleTetherColor = + ColorRGBA 0.7 0.7 0.7 0.3, -- light gray + + -- node values + styleAuxOffset = Position 0 (-16), + styleAuxFont = VFont "serif" FontSlantItalic FontWeightNormal 12, + styleAuxColor = ColorRGBA 0.9 0.5 0.5 1.0, + -- ColorRGBA 1 0.9 0.9 0.75 + styleIoletRadius = 5 + } + + +pointInLayoutNode :: Position -> LayoutNode e -> Bool +pointInLayoutNode point = pointInGNode point . nodeGNode + +pointInGNode :: Position -> GNode e -> Bool +pointInGNode point = pointInBB point . gnodeNodeBB + +-- UNUSED: findNode (except in findRect) +-- find the node, if any, containing a point +-- ****** might need to adjust this to take iolets into account ****** +findNode :: Position -> TreeLayout e -> Maybe (LayoutNode e) +findNode point (T.Node node@(LayoutNode _rootGNode treeBB) sublayouts) = + if pointInBB point treeBB + then if pointInLayoutNode point node + then Just node + else findInSubs point sublayouts + else Nothing + + where findInSubs :: Position -> [TreeLayout e] -> Maybe (LayoutNode e) + findInSubs _p [] = Nothing + findInSubs p (l:ls) = + let found = findNode p l in + case found of + (Just _) -> found + Nothing -> findInSubs p ls + +-- UNUSED: findRect +findRect :: Position -> TreeLayout e -> Maybe Rectangle +findRect point tlo = + case findNode point tlo of + Nothing -> Nothing + Just node -> Just (bbToRect (gnodeNodeBB (nodeGNode node))) + +setFont :: VFont -> Render () +setFont (VFont face slant weight size) = do + selectFontFace face slant weight + setFontSize size + +data FontTextExtents = FontTextExtents { + fontAscent::Double, fontDescent::Double, fontHeight::Double, + fontMaxXadvance::Double, fontMaxYadvance::Double, + textXbearing::Double, textYbearing::Double, + extTextWidth::Double, extTextHeight::Double, + textXadvance::Double, textYadvance::Double} + deriving (Eq, Read, Show) + +-- Rationale for unsafePerformIO: +-- font extents of a string will not change unless the font itself +-- changes, which is extremely unlikely + +styleTextExtents :: Style -> String -> FontTextExtents +styleTextExtents style str = + unsafePerformIO $ + withImageSurface FormatARGB32 0 0 $ \ surface -> + renderWith surface $ + setFont (styleFont style) >> + ftExtents str + +-- | ftExtents: used for what? +ftExtents :: String -> Render FontTextExtents +ftExtents text = do + FontExtents asc desc fheight maxxadv maxyadv <- fontExtents + TextExtents xbear ybear twidth theight xadv yadv <- textExtents text + return (FontTextExtents asc desc fheight maxxadv maxyadv + xbear ybear twidth theight xadv yadv) + +-- UNUSED +-- -- | measureText is not used; should it be? + +-- measureText :: Style -> String -> Size +-- measureText style str = extentsSize (styleTextExtents style str) + +-- -- | extentsSize: unused; should it be? +-- extentsSize :: FontTextExtents -> Size +-- extentsSize ftExts = Size (textXadvance ftExts) (fontHeight ftExts) + + +data TextBox = TextBox {tbText :: String, + tbTextBB :: BBox, -- BBox of text without margins + tbBoxBB :: BBox -- of text with margins + } + deriving (Eq, Read, Show) + +makeTextBox :: Style -> String -> TextBox +makeTextBox style text = + let extents = styleTextExtents style text + margin = textMargin style + textW = textXadvance extents + textH = fontHeight extents + fontDescent extents + + boxW = textW + 2.0 * margin -- max (textW + 2.0 * margin) minWidth + boxH = textH + 2.0 * margin + + boxX = 0 + boxY = 0 + + textX = (boxW - textW) / 2.0 + -- raise text slightly, by a fraction of its font descent + -- (why? because it just looks better!) + -- Maybe this should be made an aspect of style? + raise = 0.5 * fontDescent extents + textY = fontHeight extents + (boxH - textH) / 2.0 - raise + + textBB = BBox textX textY textW textH + boxBB = BBox boxX boxY boxW boxH + + in TextBox text textBB boxBB + +instance Widen TextBox where + widen tb@(TextBox _text textBB boxBB) minWidth = + let w = bbWidth boxBB + in if w >= minWidth + then tb + else let dw = minWidth - w + in tb {tbTextBB = translate (dw / 2) 0 textBB, + tbBoxBB = widen boxBB minWidth} + + +tbWidth :: TextBox -> Double +tbWidth = bbWidth .tbBoxBB + +tbSetWidth :: TextBox -> Double -> TextBox +tbSetWidth tbox w = + let TextBox text textBB boxBB = tbox + boxBB' = bbSetWidth boxBB w + (dx, dy) = positionDelta (bbCenter boxBB) (bbCenter boxBB') + in TextBox text (translate dx dy textBB) boxBB' + +tbHeight :: TextBox -> Double +tbHeight = bbHeight . tbBoxBB + +tbBottom :: TextBox -> Double +tbBottom = bbBottom . tbBoxBB + +-- The geometric "center" of a TextBox is the center of its "BoxBB" +tbCenter :: TextBox -> Position +tbCenter = tbBoxCenter + +tbBoxCenter :: TextBox -> Position +tbBoxCenter = bbCenter . tbBoxBB + +-- and the center of its text should have the same x coordinate, +-- but due to the way text is positioned, maybe not the same y. +-- But do we ever need this? +tbTextCenter :: TextBox -> Position +tbTextCenter = bbCenter . tbTextBB + +offsetTextBoxCenters :: Position -> TextBox -> TextBox -> TextBox +offsetTextBoxCenters offset anchor floater = + -- Position the floater text box so that its center differs + -- from the anchor text box by the given offset. + -- (The offset argument comes first, like dx dy in translate.) + let Position ax ay = tbBoxCenter anchor + Position fx fy = tbBoxCenter floater + Position ox oy = offset + -- translate floater by (dx, dy), where fx + dx = ax + ox, + -- so dx = ax + ox - fx; and dy similarly + dx = ax + ox - fx + dy = ay + oy - fy + in translate dx dy floater + + +-- GNode = graphical node, suitable for drawing +data GNode e = GNode {gnodeValue :: e, + gnodeTextBoxes :: [TextBox], -- one or two only + gnodeNodeBB :: BBox, -- encloses all textboxes + gnodeInlets :: [Iolet], -- input connectors + gnodeOutlets :: [Iolet] -- output connectors + } + deriving (Eq) + +gnodeText :: GNode e -> String +gnodeText = tbText . head . gnodeTextBoxes + +gnodeTextBB :: GNode e -> BBox +gnodeTextBB = tbTextBB . head . gnodeTextBoxes + +instance (Show e) => Show (GNode e) where + show (GNode v tbs nodeBB inlets outlets) = + par "GNode" [show v, show tbs, show nodeBB, show inlets, show outlets] + +-- An IoletCounter returns (no. of inlets, no. of outlets) +type IoletCounter e = e -> (Int, Int) + +-- A sort of "default" IoletCounter returning zeroes +zeroIoletCounter :: IoletCounter e +zeroIoletCounter _node = (0, 0) + +-- An IoletsMaker ??? +-- type IoletsMaker e = Style -> e -> ([Position], [Position]) + +makeGNode :: (Repr e) => Style -> IoletCounter e -> e -> GNode e +makeGNode style countIolets value = + -- The function countIolets creates a tuple (# of inlets, # of outlets) + -- for the node, of course being (0, 0) if we don't want any. + let textboxes1 = map (makeTextBox style) (reprl value) + textboxes2 = case textboxes1 of + [_tb] -> textboxes1 + [tb1, tb2] -> + [tb1, + offsetTextBoxCenters (styleAuxOffset style) tb1 tb2] + _ -> wrong textboxes1 + nodeBB = case textboxes2 of + [tb] -> tbBoxBB tb + [tb1, tb2] -> bbMerge (tbBoxBB tb1) (tbBoxBB tb2) + _ -> wrong textboxes2 + wrong tbs = + error $ "makeGNode: wrong no. of text boxes; " ++ + "expected 1 or 2, but got " ++ show (length tbs) + (inlets, outlets) = makeIolets style nodeBB (countIolets value) + in GNode value textboxes2 nodeBB inlets outlets + +makeIolets :: Style -> BBox -> (Int, Int) -> ([Iolet], [Iolet]) +makeIolets style bbox (nin, nout) = + -- make the (inlets, outlets) + (makeIoletsRow style (bbXCenter bbox) (bbBottom bbox) nin, + makeIoletsRow style (bbXCenter bbox) (bbTop bbox) nout) + +makeIoletsRow :: Style -> Double -> Double -> Int -> [Iolet] +makeIoletsRow style cx cy n = + -- make a row of n Iolets, centered at (cx, cy) + let radius = styleIoletRadius style + diam = 2 * radius -- diameter + w = fromIntegral n * diam + x1 = cx - w / 2 + radius -- the center of the first iolet + x i = x1 + fromIntegral (i - 1) * diam + make i = Iolet (Circle (Position (x i) cy) radius) + in map make [1..n] + +data Iolet = Iolet Circle + -- | other shapes could be added + deriving (Eq, Read, Show) + +ioletCenter :: Iolet -> Position +ioletCenter (Iolet circle) = circleCenter circle + +pointInIolet :: Position -> Iolet -> Bool +pointInIolet point (Iolet circle) = pointInCircle point circle + +-- Build a Tree of node Sizes parallel to the Repr tree, +-- each node in the Size tree is the size of +-- the corresponding node in the repr tree. + +-- treeSizes: given a tree of *node* sizes, for the root nodes of the tree +-- and its subtrees, returns a tree of *tree* sizes + +treeSizes :: Style -> Tree (GNode e) -> Tree Size +treeSizes style gTree = + let subtreeSizes = map (treeSizes style) (subForest gTree) + (BBox _ _ rootWidth rootHeight) = gnodeNodeBB (rootLabel gTree) + treeWidth = max rootWidth (paddedWidth style subtreeSizes) + treeHeight = rootHeight + paddedHeight style subtreeSizes + in T.Node (Size treeWidth treeHeight) subtreeSizes + +-- (paddedWidth style subtrees) and (paddedHeight style subtrees) +-- compute the total size of all subtrees +-- of of a Size tree, including padding. +paddedWidth :: Style -> [Tree Size] -> Double +paddedWidth _style [] = 0 +paddedWidth style subtrees = + sum [w | (T.Node (Size w _h) _) <- subtrees] + + hpad style * fromIntegral (length subtrees - 1) + +-- UNUSED: +-- -- | pairSum is unused; should it be? +-- pairSum :: (Double, Double) -> Double +-- pairSum (a, b) = a + b + +paddedHeight :: Style -> [Tree Size] -> Double +paddedHeight _style [] = 0 +paddedHeight style subtrees = + vpad style + maximum [h | (T.Node (Size _w h) _) <- subtrees] + +-- A TreeLayout is a Tree of LayoutNodes. +-- The root node in a TreeLayout identifies the root of the source Tree +-- (nodeSource) and the node's bounding box (nodeNodeBB). +-- It also tells the bounding box of the whole tree (nodeTreeBB). +-- The subtrees of the TreeLayout are the TreeLayouts +-- of the subtrees of the source Tree. + +type TreeLayout e = Tree (LayoutNode e) + +data LayoutNode e = LayoutNode {nodeGNode :: GNode e, + nodeTreeBB :: BBox} + deriving (Eq) + +layoutNodeSource :: LayoutNode e -> e +layoutNodeSource = gnodeValue . nodeGNode + +instance (Show e) => Show (LayoutNode e) where + show (LayoutNode gnode treebb) = par "LayoutNode" [show gnode, show treebb] + +instance Widen (LayoutNode e) where + widen node@(LayoutNode gNode treeBB) minWidth = + let dw = bbWidth treeBB - minWidth + in if dw <= 0 + then node + else LayoutNode (translate (dw / 2) 0 gNode) + (widen treeBB minWidth) + +{- try this, it's tough! +instance (Draw n, Widen n) = Widen (Tree n) where + ... +-} + +-- UNUSED +-- -- | layoutRootSource: unused +-- layoutRootSource :: TreeLayout e -> e +-- layoutRootSource tree = layoutNodeSource (rootLabel tree) + +layoutRootBB :: TreeLayout e -> BBox +layoutRootBB = gnodeNodeBB . nodeGNode . rootLabel + +layoutTreeBB :: TreeLayout e -> BBox +layoutTreeBB = nodeTreeBB . rootLabel + +treeLayout :: (Repr e) => Style -> IoletCounter e -> Tree e -> TreeLayout e +treeLayout style counter tree = + let t1 = treeGNodes style counter tree + t2 = treeSizes style t1 + start = Position (hpad style) (vpad style) + t3 = treeLayout2 style start tree t1 t2 + in treeLayoutAddMargin t3 (exomargin style) + + +-- treeGNodes produces a tree of (GNode e), +-- based on a top left corner at (0, 0) which, of course, will need +-- to be translated in the final tlo. + +treeGNodes :: Repr e => + Style -> IoletCounter e -> Tree e -> Tree (GNode e) +treeGNodes style counter tree = fmap (makeGNode style counter) tree + +treeLayout2 :: (Repr e) => + Style -> Position -> Tree e -> Tree (GNode e) -> Tree Size -> TreeLayout e + +treeLayout2 style + (Position startX startY) -- top left after padding + (T.Node _root subtrees) -- the tree being laid out + -- ^^ actually we don't need the tree as an argument; + -- it's implied by the GNode tree + (T.Node gnode subGNodes) -- "node sizes" + (T.Node (Size treeWidth treeHeight) subTreeSizes) -- tree Sizes + = + let + nodeHeight = bbHeight (gnodeNodeBB gnode) + -- center the root in its level + -- UNUSED: + -- nodeCenterX = startX + treeWidth / 2 + -- nodeCenterY = startY + nodeHeight + + -- center the subtrees (may be wider or narrower than the root) + subtreesTotalWidth = paddedWidth style subTreeSizes + subX = startX + (treeWidth - subtreesTotalWidth) / 2 -- first subtree + subY = startY + nodeHeight + vpad style + + sublayouts :: (Repr e) => + Double -> [Tree e] -> [Tree (GNode e)] -> [Tree Size] -> + [TreeLayout e] + sublayouts _ [] [] [] = [] + sublayouts x (t:ts) (g:gs) (s:ss) = + treeLayout2 style (Position x subY) t g s : + sublayouts (x + sizeW (rootLabel s) + hpad style) ts gs ss + sublayouts _ _ _ _ = error "treeLayout2: mismatched list lengths" + + in T.Node (LayoutNode -- root node + (centerGNode gnode startX startY treeWidth nodeHeight) -- node + (BBox startX startY treeWidth treeHeight)) -- whole tree + (sublayouts subX subtrees subGNodes subTreeSizes) + +-- | Center a GNode in a rectangular area +centerGNode :: GNode e -> Double -> Double -> Double -> Double -> GNode e +centerGNode gnode startx starty awidth aheight = + let cx = startx + awidth / 2 -- desired center + cy = starty + aheight / 2 + Position cgx cgy = bbCenter (gnodeNodeBB gnode) + in translate (cx - cgx) (cy - cgy) gnode + +treeLayoutPaddedSize :: Style -> TreeLayout e -> Size +treeLayoutPaddedSize style tlo = + let Size w h = treeLayoutSize tlo + in Size (w + 2.0 * hpad style) (h + 2.0 * vpad style) + +treeLayoutSize :: TreeLayout e -> Size +treeLayoutSize tlo = + let BBox _x _y w h = layoutTreeBB tlo in Size w h + +layoutTreeMoveCenterTo :: + Double -> Double -> TreeLayout e -> TreeLayout e +layoutTreeMoveCenterTo newX newY layoutTree = + let Position oldX oldY = bbCenter (nodeTreeBB (rootLabel layoutTree)) + in translate (newX - oldX) (newY - oldY) layoutTree + +treeLayoutAddMargin :: TreeLayout e -> Double -> TreeLayout e +treeLayoutAddMargin tree margin = + let LayoutNode {nodeGNode = rootGNode, nodeTreeBB = treeBB} = + rootLabel tree + subtrees = subForest tree + BBox x y w h = treeBB + treeBB' = BBox (x - margin) (y - margin) + (w + 2 * margin) (h + 2 * margin) + root' = translate margin margin (LayoutNode rootGNode treeBB') + subtrees' = translate margin margin subtrees + in T.Node root' subtrees' + + + +treeLayoutWidth :: TreeLayout e -> Double +treeLayoutWidth = bbWidth . layoutTreeBB + +treeLayoutWiden :: TreeLayout e -> Double -> TreeLayout e +treeLayoutWiden tlo minWidth = + let w = treeLayoutWidth tlo + in + if w >= minWidth + then tlo + else let dw = minWidth - w + T.Node root subs = translate (dw / 2) 0 tlo + LayoutNode rootGNode treeBB = root + root' = LayoutNode rootGNode + (translate (-dw / 2) + 0 + (widen treeBB minWidth)) + in T.Node root' subs + +setColor :: VColor -> Render () + +setColor (ColorRGB red green blue) = + setSourceRGB red green blue + +setColor (ColorRGBA red green blue alpha) = + setSourceRGBA red green blue alpha + + +-- Drawing things +-- ****** THINK: is this class well conceived? +-- A lot of things could be done with draw and translate +-- if it were not tied to Style and DrawMode + +class Draw a where + draw :: Style -> DrawMode -> a -> Render () + translate :: Double -> Double -> a -> a + +-- VV DrawMode is now very awkward, since +-- a node needs to know not only if it is selected, +-- but which port(s) are selected + +data DrawMode = DrawNormal | DrawActive + | DrawSelectedNode + | DrawSelectedInlet Int + | DrawSelectedOutlet Int + deriving (Eq) + +instance (Draw e) => Draw [e] where + draw style mode = mapM_ (draw style mode) + translate dx dy = map (translate dx dy) + +{- Tree must be an instance of Draw, + in order for translate to work in treeLayoutWiden, + but again, this is a bad combination (draw + translate). +-} + +instance (Draw e) => Draw (Tree e) where + draw style mode tree = do + draw style mode (rootLabel tree) + draw style mode (subForest tree) + translate dx dy tree = + T.Node (translate dx dy (rootLabel tree)) + (translate dx dy (subForest tree)) + +instance Draw (LayoutNode e) where + draw style mode (LayoutNode gnode _treeBB) = draw style mode gnode + + translate dx dy (LayoutNode gnode treeBB) = + LayoutNode (translate dx dy gnode) + (translate dx dy treeBB) + +instance Draw (GNode e) where + + draw style mode (GNode _value textboxes nodeBB inlets outlets) = + do + -- draw node box + let (nodeTextCol, nodeEdgeCol, nodeFillCol) = + case mode of + DrawActive -> + (styleActiveTextColor, + styleActiveEdgeColor, + styleActiveFillColor) + DrawSelectedNode -> + (styleSelectedTextColor, + styleSelectedEdgeColor, + styleSelectedFillColor) + _ -> (styleNormalTextColor, + styleNormalEdgeColor, + styleNormalFillColor) + + -- (overall box for the node) + when (styleShowNodeBoxes style) $ + drawBox (Just (nodeFillCol style)) + (Just (nodeEdgeCol style)) nodeBB + + + -- assert textboxes has one or two elements + -- draw the first text box + drawTextBox (Just (styleFont style)) + (Just (nodeFillCol style)) -- background + Nothing -- frame color + (nodeTextCol style) -- text color + (head textboxes) + + -- draw the second textbox, if any, using "aux" style + case (tail textboxes) of + [tbAux] -> + drawTextBox (Just (styleAuxFont style)) + Nothing + Nothing + (styleAuxColor style) + tbAux + _ -> return () + + + -- Draw the iolets + when (styleShowNodePorts style) $ do + drawInlets style mode inlets + drawOutlets style mode outlets + + + translate dx dy (GNode value textboxes nodeBB inlets outlets) = + GNode value + (map (translate dx dy) textboxes) + (translate dx dy nodeBB) + (translate dx dy inlets) + (translate dx dy outlets) + +instance Draw TextBox where + + draw style mode = + drawTextBox (Just (styleFont style)) + (Just (modeFillCol mode style)) + Nothing + (modeTextCol mode style) + + translate dx dy (TextBox text textBB boxBB) = + TextBox text (translate dx dy textBB) (translate dx dy boxBB) + +drawTextBox :: Maybe VFont -> Maybe VColor -> Maybe VColor -> VColor -> + TextBox -> Render () +drawTextBox mfont mbgcolor mframecolor textcolor + (TextBox text textBB boxBB) = do + let BBox textX textY _textW _textH = textBB + drawBox mbgcolor mframecolor boxBB + setColor textcolor + case mfont of + (Just font) -> setFont font + _ -> return () + moveTo textX textY + showText text + +instance Draw BBox where + draw style mode = + drawBox (Just (modeFillCol mode style)) + (Just (modeEdgeCol mode style)) + translate dx dy (BBox x y w h) = BBox (x + dx) (y + dy) w h + +drawBox :: Maybe VColor -> Maybe VColor -> BBox -> Render () +drawBox mBgColor mFgColor (BBox x y w h) = + -- draw the BBox, in the specified colors, irrespective of style + let setup color = + do + rectangle x y w h + setColor color + in case (mBgColor, mFgColor) of + (Just bgColor, Just fgColor) -> + do + setup bgColor + fillPreserve + setColor fgColor + stroke + (Just bgColor, Nothing) -> + do + setup bgColor + fill + (Nothing, Just fgColor) -> + do + setup fgColor + stroke + _ -> return () + +instance Draw Position where + draw _style _mode _pos = return () -- bare points are invisible ??? ****** + translate dx dy (Position x y) = Position (x + dx) (y + dy) + +instance Draw Iolet where + draw style mode (Iolet circle) = draw style mode circle + translate dx dy (Iolet circle) = Iolet (translate dx dy circle) + +drawIolet :: Iolet -> VColor -> VColor -> Render () +drawIolet (Iolet circle) = drawCircle circle + +drawInlets :: Style -> DrawMode -> [Iolet] -> Render () +drawInlets style mode inlets = + let selected i = mode == DrawSelectedInlet i + in drawIolets selected style inlets + +drawOutlets :: Style -> DrawMode -> [Iolet] -> Render () +drawOutlets style mode outlets = + let selected o = mode == DrawSelectedOutlet o + in drawIolets selected style outlets + +drawIolets :: (Int -> Bool) -> Style -> [Iolet] -> Render () +drawIolets selected style iolets = + -- (selected n) should be true iff n is the selected iolet + let loop _ [] = return () + loop n (p:ps) = + uncurry (drawIolet p) + (if selected n + then (styleSelectedFillColor style, + styleSelectedEdgeColor style) + else (styleNormalFillColor style, + styleNormalEdgeColor style)) >> + loop (n + 1) ps + in loop 0 iolets + +instance Draw Circle where + draw style mode circle = + drawCircle circle (modeFillCol mode style) (modeEdgeCol mode style) + + translate dx dy (Circle center radius) = + Circle (translate dx dy center) radius + +drawCircle :: Circle -> VColor -> VColor -> Render () +drawCircle (Circle (Position x y) r) bgColor fgColor = do + newPath -- otherwise we get a line to the arc + arc x y r 0 (2 * pi) + setColor bgColor + fillPreserve + setColor fgColor + stroke + +-- Helper functions to find the background and foreground colors for a mode + +modeFillCol :: DrawMode -> (Style -> VColor) +modeFillCol DrawNormal = styleNormalFillColor +modeFillCol DrawActive = styleActiveFillColor +modeFillCol _ = styleSelectedFillColor + +modeTextCol :: DrawMode -> (Style -> VColor) +modeTextCol DrawNormal = styleNormalTextColor +modeTextCol DrawActive = styleActiveTextColor +modeTextCol _ = styleSelectedTextColor + +modeEdgeCol :: DrawMode -> (Style -> VColor) +modeEdgeCol DrawNormal = styleNormalEdgeColor +modeEdgeCol DrawActive = styleActiveEdgeColor +modeEdgeCol _ = styleSelectedEdgeColor + + + diff --git a/UITypes.hs b/UITypes.hs new file mode 100644 --- /dev/null +++ b/UITypes.hs @@ -0,0 +1,288 @@ +module UITypes (VPUI(..) + , WinId, VPUIWindow(..) + , vpuiUserEnvAList + -- operations on a VPUI involving its window + , vpuiInsertWindow + , vpuiTryGetWindow + , vpuiGetWindow + , vpuiUpdateWindow + , vpuiReplaceWindow + , vpuiUpdateWindowIO + , vpuiRemoveVPUIWindow + + -- operations on a window involving its canvas + , vpuiWindowLookupCanvas, vpuiWindowGetCanvas + , vpuiWindowSetCanvas, vpuiWindowModCanvas + , vpuiWindowModCanvasIO + + -- operation on a VPUI involving the canvas of its window + , vpuiModCanvas, vpuiModCanvasIO + + -- other operations on a window + , vpuiWindowWindow + + , VPToolkit(..), Toolbox(..), Tool(..), ToolContext(..) + , CanvasToolOp + , ToolOp + , toToolOpVW + , Workspace(..) + , FunctionEditor(..), fedFunctionName + , VCanvas(..), Selection(..), Dragging(..) + ) + +where + +import Data.Map as Map +import Data.Graph.Inductive as G + +import Graphics.UI.Gtk + hiding (Function, Layout, Style, Size) +import qualified Graphics.UI.Gtk as Gtk (Frame, Layout) +import Graphics.UI.Gtk.Gdk.EventM (Modifier(..)) + +import RPanel +import TreeLayout +import Workspace.Frame +import Workspace.WGraph +import Expr +import Geometry + +-- | VPUI: Sifflet (formerly VisiProg) User Interface +-- The initialEnv is apt to contain "builtin" functions; +-- it's preserved here so that when writing to a file, +-- we can skip the functions that were in the initial env. +data VPUI = VPUI { + vpuiWindows :: Map WinId VPUIWindow, + vpuiToolkits :: Map String VPToolkit, -- collections of tools + -- A phantom button (never shown) to represent the group of all tools: + vpuiButtonGroup :: RadioToolButton, + vpuiFilePath :: Maybe FilePath, -- the file opened or to save + vpuiFileChanged :: Bool, -- has file changed since open/save? + vpuiStyle :: Style, -- for windows, canvases, editors + vpuiInitialEnv :: Env, -- initial value of global environment + vpuiGlobalEnv :: Env -- the global environment + } + +-- | Extract from the environment the part defined by the user +vpuiUserEnvAList :: VPUI -> [(String, Value)] +vpuiUserEnvAList vpui = + let env' = vpuiGlobalEnv vpui -- I hope + env = vpuiInitialEnv vpui + in if length env == 1 && length env' == 1 + then assocs (Map.difference (head env') (head env)) + else error ("vpuiUserEnv: env lengths are not one" ++ + "|env'|: " ++ show (length env') ++ + "|env|: " ++ show (length env)) + +-- | Insert a window in the window map +vpuiInsertWindow :: VPUI -> WinId -> VPUIWindow -> VPUI +vpuiInsertWindow vpui winId vw = + vpui {vpuiWindows = Map.insert winId vw (vpuiWindows vpui)} + +-- | Try to get the VPUIWindow with the given window ID, +-- return Just result or Nothing +vpuiTryGetWindow :: VPUI -> WinId -> Maybe VPUIWindow +vpuiTryGetWindow vpui winId = Map.lookup winId (vpuiWindows vpui) + +-- | Get the VPUIWindow with the given window ID; +-- it is an error if this fails. +vpuiGetWindow :: VPUI -> WinId -> VPUIWindow +vpuiGetWindow vpui winId = vpuiWindows vpui ! winId + +-- | Replace a VPUIWindow with given window ID; +-- it is an error if this fails. +vpuiReplaceWindow :: VPUI -> WinId -> VPUIWindow -> VPUI +vpuiReplaceWindow vpui winId vpuiWin = + let winMap = vpuiWindows vpui + winMap' = insert winId vpuiWin winMap + in vpui {vpuiWindows = winMap'} + +-- | Apply an update function to a VPUIWindow with given window ID; +-- it is an error if this fails. +vpuiUpdateWindow :: VPUI -> WinId -> (VPUIWindow -> VPUIWindow) -> VPUI +vpuiUpdateWindow vpui winId updater = + let winMap = vpuiWindows vpui + winMap' = adjust updater winId winMap + in vpui {vpuiWindows = winMap'} + +-- | Apply an update IO action to a VPUIWindow with given window ID; +-- it is an error if this fails. +vpuiUpdateWindowIO :: WinId -> (VPUIWindow -> IO VPUIWindow) -> VPUI -> IO VPUI +vpuiUpdateWindowIO winId updater vpui = do + { + let winMap = vpuiWindows vpui + vw = winMap ! winId + ; vw' <- updater vw + ; let winMap' = insert winId vw' winMap + ; return $ vpui {vpuiWindows = winMap'} + } + +-- | Remove a window from the windows map; it has already been destroyed +-- in the GUI +vpuiRemoveVPUIWindow :: WinId -> VPUI -> VPUI +vpuiRemoveVPUIWindow winId vpui = + let winMap = vpuiWindows vpui + winMap' = delete winId winMap + in vpui {vpuiWindows = winMap'} + +data VPUIWindow = -- VPUIJustWindow Window + VPUIWorkWin Workspace Window + | FunctionPadWindow Window [(String, RPanel)] + + +vpuiWindowWindow :: VPUIWindow -> Window +vpuiWindowWindow vw = + case vw of + VPUIWorkWin _ w -> w + FunctionPadWindow w _ -> w + +-- | Try to find canvas; fail gracefully +vpuiWindowLookupCanvas :: VPUIWindow -> Maybe VCanvas +vpuiWindowLookupCanvas vw = + case vw of + VPUIWorkWin ws _ -> Just (wsCanvas ws) + _ -> Nothing + +-- | Find canvas or fail dramatically +vpuiWindowGetCanvas :: VPUIWindow -> VCanvas +vpuiWindowGetCanvas vw = + case vpuiWindowLookupCanvas vw of + Nothing -> error "vpuiWindowGetCanvas: no canvas found" + Just canvas -> canvas + +vpuiWindowSetCanvas :: VPUIWindow -> VCanvas -> VPUIWindow +vpuiWindowSetCanvas vw canvas = + case vw of + VPUIWorkWin ws w -> VPUIWorkWin (ws {wsCanvas = canvas}) w + _ -> error "vpuiWindowSetCanvas: not a workspace window" + +vpuiWindowModCanvas :: VPUIWindow -> (VCanvas -> VCanvas) -> VPUIWindow +vpuiWindowModCanvas vw f = + case vpuiWindowLookupCanvas vw of + Nothing -> error "vpuiWindowModCanvas: plain VPUIWindow" + Just canvas -> vpuiWindowSetCanvas vw (f canvas) + +vpuiWindowModCanvasIO :: VPUIWindow -> (VCanvas -> IO VCanvas) -> IO VPUIWindow +vpuiWindowModCanvasIO vw f = + case vpuiWindowLookupCanvas vw of + Nothing -> error "vpuiWindowModCanvas: plain VPUIWindow" + Just canvas -> + do + { + canvas' <- f canvas + ; return $ vpuiWindowSetCanvas vw canvas' + } + +-- | Update the canvas of the specified window, without IO +vpuiModCanvas :: VPUI -> WinId -> (VCanvas -> VCanvas) -> VPUI +vpuiModCanvas vpui winId modCanvas = + let modWindow vw = vpuiWindowModCanvas vw modCanvas + in vpuiUpdateWindow vpui winId modWindow + +-- | Update the canvas of the specified window, with IO +vpuiModCanvasIO :: VPUI -> WinId -> (VCanvas -> IO VCanvas) -> IO VPUI +vpuiModCanvasIO vpui winId modCanvas = + let modWindow vw = vpuiWindowModCanvasIO vw modCanvas + in vpuiUpdateWindowIO winId modWindow vpui + +type WinId = String + +data Workspace = Workspace {wsBox :: VBox, -- ^ container of the rest + wsCanvas :: VCanvas, -- ^ the canvas + wsButtonBar :: HBox, + wsStatusbar :: Statusbar} + +data FunctionEditor = FunctionEditor {fedWindow :: Window, + fedWinTitle :: String, + fedFunction :: Function, + fedCanvas :: VCanvas + -- , fedUIRef :: IORef VPUI + } + +fedFunctionName :: FunctionEditor -> String +fedFunctionName = functionName . fedFunction + +-- | Toolkit functions are organized in groups (rows) for presentation +-- in a toolbox +data VPToolkit = VPToolkit {toolkitName :: String, + toolkitWidth :: Int, -- (-1) = don't care + toolkitRows :: [[Tool]]} + +-- | A Toolbox is a framed VBox with a set of Toolbars attached +data Toolbox = Toolbox {toolboxFrame :: Gtk.Frame + , toolboxVBox :: VBox} + +-- | ToolOp a is intended for a = VPUIWindow or VCanvas +-- type ToolOp a +-- = VPUI -> a -> ToolContext -> [Modifier] -> Double -> Double -> IO a + +type ToolOp + = VPUI -> WinId -> ToolContext -> [Modifier] -> Double -> Double -> IO VPUI + +type CanvasToolOp + = VCanvas -> ToolContext -> [Modifier] -> Double -> Double -> IO VCanvas + +data Tool = Tool {toolName :: String, -- the tool's name + + -- what to do when the tool is selected from the toolbox + toolActivated :: VCanvas -> IO VCanvas, + + -- what to do to apply the tool to a point on the canvas + toolOp :: ToolOp + } + +-- | A helper for making toolOps from actions on VCanvas + +toToolOpVW :: CanvasToolOp -> ToolOp +toToolOpVW vcOp vpui winId toolContext mods x y = do + { + let vw = vpuiGetWindow vpui winId + canv = vpuiWindowGetCanvas vw + ; canv' <- vcOp canv toolContext mods x y + ; let vw' = vpuiWindowSetCanvas vw canv' + ; return $ vpuiReplaceWindow vpui winId vw' + } + +-- | ToolContext: The way a tool should be applied depends on +-- where it is being used + +data ToolContext = TCWorkspace + | TCCallFrame CanvFrame + | TCEditFrame CanvFrame + | TCExprNode -- ??? + + + +-- | A canvas that can display multiple boxes representing +-- expressions or function definitions or calls + +data VCanvas = VCanvas { + vcLayout :: Gtk.Layout, + vcStyle :: Style, + vcGraph :: WGraph, + vcFrames :: [CanvFrame], + vcSize :: Size, + -- vcLocalEnv :: Env, -- only good for function editor, I think? + vcMousePos :: (Double, Double), + vcTool :: Maybe Tool, -- current tool on this canvas + vcActive :: Maybe Node, -- active node, if any + vcSelected :: Maybe Selection, -- selected node(s), if any + vcDragging :: Maybe Dragging -- what we're dragging, if anything + } + + +data Selection = SelectionNode {selNode :: G.Node} + | SelectionInlet {selNode :: G.Node, + selInEdge :: WEdge} -- numbered from 0 + | SelectionOutlet {selNode :: G.Node, + selOutEdge :: WEdge} -- normally just 0 + deriving (Eq, Read, Show) + +-- | A Dragging keeps track of the object (node) being dragged +-- and the current mouse position. + +data Dragging = Dragging { draggingNode :: G.Node, + draggingPosition :: Position + } + deriving (Eq, Read, Show) + diff --git a/Util.hs b/Util.hs new file mode 100644 --- /dev/null +++ b/Util.hs @@ -0,0 +1,112 @@ +module Util ( + -- PARSER UTILITIES + SuccFail(Succ, Fail) + , parsef, parseInt, parseDouble, parseVerbatim + -- STRING UTILITIES + , par + -- OUTPUT UTILITIES + , info + , fake + , stub + + -- LIST UTILITIES + , map2, mapM2 + , adjustAList, adjustAListM + , insertLastLast, insertLast + ) + +where + +import Control.Monad +import Data.List + +-- SuccFail: the result of an attempt, succeeds or fails +data SuccFail a = Succ a -- value + | Fail String -- error message + deriving (Eq, Read, Show) + +instance Monad SuccFail where + Succ val >>= f = f val + Fail err >>= _f = Fail err + return = Succ + fail = Fail + +-- PARSER UTILITIES + +parsef :: (Read a) => String -> String -> String -> SuccFail a +parsef typeName inputLabel input = + case reads input of + [(value, "")] -> Succ value + [(_, more)] -> + Fail $ inputLabel ++ ": extra characters after " ++ + typeName ++ ": " ++ more + _ -> Fail $ inputLabel ++ ": cannot parse as " ++ + typeName ++ ": " ++ input + +parseInt :: String -> String -> SuccFail Int +parseInt = parsef "integer" + +parseDouble :: String -> String -> SuccFail Double +parseDouble = parsef "real number" + +parseVerbatim :: String -> String -> SuccFail String +parseVerbatim _label = Succ + +-- | Enclose in parentheses, like a Lisp function call. +-- Example: par "foo" ["x", "y"] = "(foo x y)" + +par :: String -> [String] -> String +par f xs = "(" ++ unwords (f:xs) ++ ")" + + +info :: (Show t) => t -> IO () +info = print + +fake :: String -> IO () +fake what = putStrLn $ "Faking " ++ what ++ "..." + +stub :: String -> IO () +stub name = putStrLn $ "Stub for " ++ name + +-- LIST UTILITIES + +-- | Generalization of map to lists of lists +map2 :: (a -> b) -> [[a]] -> [[b]] +map2 f rows = -- map (\ row -> map f row) rows + map (map f) rows + +-- | Generalization of mapM to lists of lists +mapM2 :: (Monad m) => (a -> m b) -> [[a]] -> m [[b]] +mapM2 f rows = -- mapM (\ row -> mapM f row) rows + mapM (mapM f) rows + +-- | Insert an item into a list of lists of items, +-- making it the last element in the last sublist +insertLastLast :: [[a]] -> a -> [[a]] +insertLastLast xss x = init xss ++ [insertLast (last xss) x] + +-- | Insert an item in a list of items, making it the last element +insertLast :: [a] -> a -> [a] +insertLast xs x = xs ++ [x] + +-- | Update a value at a given key by applying a function. +-- Similar to Data.Map.adjust. + +-- This implementation, using map, could be inefficient +-- if the key to be updated is near the front of a long list. +adjustAList :: (Eq k) => k -> (v -> v) -> [(k, v)] -> [(k, v)] +adjustAList key f alist = + map (\ (k, v) -> if k == key then (k, f v) else (k, v)) + alist + +-- | Monadic generalization of adjustAList + +-- Same caution re. inefficiency +adjustAListM :: (Eq k, Monad m) => + k -> (v -> m v) -> [(k, v)] -> m [(k, v)] +adjustAListM key f alist = + mapM (\ (k, v) -> + if k == key + then do { v' <- f v; return (k, v') } + else return (k, v)) + alist diff --git a/WindowManagement.hs b/WindowManagement.hs new file mode 100644 --- /dev/null +++ b/WindowManagement.hs @@ -0,0 +1,1020 @@ +module WindowManagement + ( + -- Window utilities + showWindow + , newWindowTitled + + , showWorkWin + , showWorkspaceWindow + + , showFedWin + , fedWindowTitle + + , showFunctionPadWindow + , newFunctionDialog + + , setWSCanvasCallbacks + , keyBindingsHelpText + ) + +where + +import Control.Monad +import Control.Monad.Trans (liftIO) -- for use in EventM +import Data.IORef +import Data.List +import Data.Map as Map (fromList, lookup) +import Data.Map (Map) +import Data.Maybe + +import Data.Graph.Inductive as G + +import Graphics.UI.Gtk hiding (Frame, Function, Style, + add, buttonPressed, disconnect, + fill, function, lineWidth) + +import Graphics.UI.Gtk.Gdk.EventM + +import CBMgr +import Expr +import Geometry +import GtkForeign as XCursor +import GtkUtil +import RPanel +import SiffML +import UITypes +import Util +import Workspace + +-- --------------------------------------------------------------------- +-- | Finding, creating, and initializing windows (VPUIWindow) + +-- | Find and show a window, if it exists. +-- If not, create the window, put it in the vpui's window map, +-- and initialize it and any auxiliary objects using the initWin function. +-- The 3rd argument of initWin will be the window's title. +-- Always presents the window (shows and raises). +-- Returns a 3-tuple: the VPUIWindow contains the Window, +-- and the Bool value is True if the Window is new +-- (and therefore might need some further initialization). +-- The third tuple element is an IORef to the VPUIWindow; +-- it may be useful for setting up signal and event handling. + +showWindow :: WinId -> CBMgr + -> (VPUI -> Window -> IO VPUIWindow) -- initializes Gtk Window + -> (VPUI -> WinId -> CBMgr -> IO ()) -- initializes callbacks + -> VPUI -> IO (VPUI, VPUIWindow, Bool) +showWindow winId uimgr initWin initCB vpui = do + { + (vpui', vw, isNew) <- + case vpuiTryGetWindow vpui winId of + Nothing -> + do + { + window <- newWindowTitled winId + ; widgetSetName window ("Sifflet-" ++ winId) + ; vwin <- initWin vpui window + ; let vpui' = vpuiInsertWindow vpui winId vwin + -- when window is destroyed, remove it from the map + ; uimgr (OnWindowDestroy window + (\ uiref -> + modifyIORef uiref (vpuiRemoveVPUIWindow winId))) + ; return (vpui', vwin, True) + } + Just vw -> + return (vpui, vw, False) + ; when isNew (initCB vpui' winId uimgr) -- add callbacks on new window + ; windowPresent (vpuiWindowWindow vw) + ; return (vpui', vw, isNew) + } + +-- | Default "do-nothing" add-callbacks function +initCBDefault :: VPUI -> WinId -> CBMgr -> IO () +initCBDefault _vpui _winId _uimgr = return () + +newWindowTitled :: String -> IO Window +newWindowTitled winId = do + window <- windowNew + set window [windowTitle := winId] + widgetSetName window ("Sifflet-" ++ winId) + return window + +-- | Show a workspace window, with a given title, _not_ editing a function + +showWorkWin :: VPUI -> WinId -> CBMgr -> IO VPUI +showWorkWin vpui winId uimgr = do + { + (vpui', _, _) <- showWorkspaceWindow winId uimgr Nothing vpui + ; return vpui' + } + +-- | Show a workspace window with a given title and maybe function to edit + +showWorkspaceWindow :: WinId -> CBMgr -> Maybe Function -> VPUI + -> IO (VPUI, VPUIWindow, Bool) +showWorkspaceWindow winId cbmgr mfunc = + showWindow winId cbmgr (workspaceWindowInit cbmgr winId mfunc) + setWSCanvasCallbacks + + +-- | Initialize a Workspace window. +-- Called in sifflet.hs:Main from showWindow called from showWorkspaceWindow. + +workspaceWindowInit :: CBMgr -> WinId -> Maybe Function -> VPUI -> Window + -> IO VPUIWindow +workspaceWindowInit cbmgr winId mfunc vpui window = do + { + let style = vpuiStyle vpui + env = vpuiGlobalEnv vpui + ; ws <- case mfunc of + Nothing -> workspaceNewDefault style (buildMainMenu cbmgr) + Just func -> workspaceNewEditing style env func + ; set window [windowTitle := winId, containerChild := wsBox ws] + + ; widgetShowAll window + ; windowPresent window + + ; return $ VPUIWorkWin ws window + } + +-- Menu specs here need to coordinate accelerators (shortcuts) +-- with keyBindingsList in WindowManagement.hs + +buildMainMenu :: CBMgr -> VBox -> IO () +buildMainMenu cbmgr vbox = do + { + -- menu bar + let mspecs = + [MenuSpec "File" + [ -- "new" isn't implemented yet + -- MenuItem "New ..." menuFileNew + -- , + -- Temporarily disabling file I/O operations + MenuItem "Open ... (C-o)" (menuFileOpen cbmgr) + , MenuItem "Save (C-s)" menuFileSave + , MenuItem "Save as ..." menuFileSaveAs + , MenuItem "Quit (C-q)" vpuiQuit] + , MenuSpec "Functions" + [MenuItem "New ... (n)" + (newFunctionDialog "ignore" cbmgr) + , MenuItem "Function Pad" + (showFunctionPadWindow cbmgr)] + , MenuSpec "Help" + [MenuItem "Help ..." showHelpDialog + , MenuItem "Complaints and praise ..." showBugs + , MenuItem "About ..." showAboutDialog] + ] + ; menubar <- createMenuBar mspecs cbmgr + ; boxPackStart vbox menubar PackNatural 0 +} + +-- | Show a function editor window = a workspace window +-- editing a given function. +-- Use argNames for a new function; ignore them if funcName is bound. + +showFedWin :: CBMgr -> String -> [String] -> VPUI -> IO VPUI +showFedWin cbmgr funcName argNames vpui = do + { + ; let initEnv = vpuiGlobalEnv vpui + function = case envLookupFunction initEnv funcName of + Nothing -> newUndefinedFunction funcName argNames + Just func -> func + winId = fedWindowTitle funcName + + ; (vpui', vw, isNew) <- showWorkspaceWindow winId cbmgr (Just function) vpui + + ; if isNew + then do + { + let canvas = vpuiWindowGetCanvas vw + -- ** Can this use vpuiAddFrame? + ; canvas' <- vcAddFrame canvas (FunctoidFunc function) [] + EditFrame + initEnv 0 0 0 Nothing + ; canvas'' <- + case vcFrames canvas' of + [] -> info "showFedWin: ERROR: no frame on canvas" >> + return canvas' + _:_:_ -> + info "showFedWin: ERROR: too many frames on canvas" >> + return canvas' + [frame] -> editFunction canvas' frame + ; addArgToolButtons cbmgr winId (functionArgNames function) vpui' + ; addApplyCloseButtons cbmgr winId vpui' + ; return (vpuiReplaceWindow vpui' winId + (vpuiWindowSetCanvas vw canvas'')) + } + else return vpui' + } + +fedWindowTitle :: String -> WinId +fedWindowTitle funcName = "Edit " ++ funcName + +updateFunctionPadIO :: String -> (RPanel -> IO RPanel) -> VPUI -> IO VPUI +updateFunctionPadIO padName update = + let updateWindow vw = + case vw of + FunctionPadWindow window rpAList -> + do + { + rpAList' <- adjustAListM padName update rpAList + ; return (FunctionPadWindow window rpAList') + } + _ -> return vw + in vpuiUpdateWindowIO "Function Pad" updateWindow + +showFunctionPadWindow :: CBMgr -> VPUI -> IO VPUI +showFunctionPadWindow cbmgr vpui = + let initWindow _vpui window = do + { + -- widgetSetName window "SiffletFunctionPadWindow" + ; vbox <- vBoxNew False 0 -- non-homogenous, 0 padding + ; set window [containerChild := vbox] + + ; let rpnames = ["Base", "Examples", "My Functions"] + ; rps <- mapM (makeFunctionPadPanel cbmgr) rpnames + ; mapM_ (\ rp -> boxPackStart vbox (rpanelRoot rp) PackNatural 0) + rps + + ; windowMove window 5 5 + ; widgetShowAll window -- redundant? + ; windowPresent window -- redundant? + + ; return $ FunctionPadWindow window (zip rpnames rps) + -- ^^ maybe need reference only the "My Functions" panel though + } + in do + { + (vpui', _, windowIsNew) <- + showWindow functionPadWinId cbmgr initWindow initCBDefault vpui + -- "My Functions" default is empty; add any user-defined + -- functions in the environment to it + ; if windowIsNew + then addUserFunctions cbmgr vpui' + else return vpui' + } + +functionPadWinId :: String +functionPadWinId = "Function Pad" + +addUserFunctions :: CBMgr -> VPUI -> IO VPUI +addUserFunctions cbmgr vpui = + let names = map fst (vpuiUserEnvAList vpui) + update rp = do + { + buttons <- mapM (makeToolButton cbmgr . functionTool) names + ; rp' <- rpanelAddWidgets rp (zip names buttons) + ; widgetShowAll (rpanelRoot rp') + ; return rp' + } + in updateFunctionPadIO "My Functions" update vpui + +makeFunctionPadPanel :: CBMgr -> String -> IO RPanel +makeFunctionPadPanel cbmgr name = + let VPToolkit _ width toolrows = + case Map.lookup name defaultVPUIToolkits of + Nothing -> + error ("makeFunctionPadPanel: " ++ + "can't find toolkit definition: " ++ name) + Just atoolkit -> atoolkit + in do + { + buttonRows <- makeToolButtonRows cbmgr toolrows + :: IO [[(String, Button)]] + ; rp <- newRPanel name 3 3 width + ; rpanelAddRows rp buttonRows + } + +makeToolButtonRows :: CBMgr -> [[Tool]] -> IO [[(String, Button)]] +makeToolButtonRows cbmgr toolRows = + mapM2 (makeNamedToolButton cbmgr) toolRows + +makeNamedToolButton :: CBMgr -> Tool -> IO (String, Button) +makeNamedToolButton cbmgr tool = do + { + button <- makeToolButton cbmgr tool + ; return (toolName tool, button) + } + +makeToolButton :: CBMgr -> Tool -> IO Button +makeToolButton cbmgr tool = do + { + button <- buttonNewWithLabel (toolName tool) + ; cbmgr (AfterButtonClicked button + ((flip modifyIORefIO) + (forallWindowsIO (vpuiWindowSetTool tool)))) + ; return button + } + +-- | Add a tool button to the function pad window in a specified panel +addFunctionPadToolButton :: CBMgr -> String -> Tool -> VPUIWindow + -> IO VPUIWindow +addFunctionPadToolButton cbmgr panelId tool vw = + case vw of + FunctionPadWindow window panelAList -> + let adjustPanel :: RPanel -> IO RPanel + adjustPanel rp = do + { + -- make the tool button from the tool + button <- makeToolButton cbmgr tool + -- add it to the panel + ; rp' <- rpanelAddWidget rp (toolName tool) button + ; widgetShowAll (rpanelRoot rp') + ; return rp' + } + in do + { + panelAList' <- adjustAListM panelId adjustPanel panelAList + ; return $ FunctionPadWindow window panelAList' + } + _ -> return vw + + +-- | Ask user for new function name and arguments, +-- then begin editing the function. + +newFunctionDialog :: WinId -> CBMgr -> VPUI -> IO VPUI +newFunctionDialog _winId cbmgr vpui = + -- _winId is ignored, but needed for use in KeyBindingsList + let reader :: Reader [String] (String, [String]) + reader inputLines = + case inputLines of + [fname, fargs] -> + return (fname, words fargs) + _ -> fail "wrong number of lines" + in do + { + inputDialog <- + createEntryDialog "New Function" + ["Function name", "Argument names (space between)"] + ["", ""] + reader + (-1) + ; values <- runEntryDialog inputDialog + ; case values of + Nothing -> return vpui + Just (name, args) -> editNewFunction cbmgr name args vpui + } + +-- ------------------------------------------------------------ +-- Implementation of menu commands + +-- | Create a new file, but what does this mean? + +menuFileNew :: VPUI -> IO VPUI +menuFileNew vpui = putStrLn "Not implemented: \"New\"" >> return vpui + +-- | Open a file (load its function definitions) + +menuFileOpen :: CBMgr -> VPUI -> IO VPUI +menuFileOpen cbmgr vpui = do + mpath <- showDialogFileOpen vpui + case mpath of + Nothing -> return vpui + Just filePath -> + do + { + loadResult <- loadFile vpui filePath + ; case loadResult of + Fail msg -> + showErrorMessage msg >> return vpui + Succ (vpui', functions) -> + let title = "My Functions" + updatePad rp = + -- Figure out which functions are new, + -- i.e., not already on the pad + let oldNames = concat (rpanelContent rp) + loadedNames = map functionName functions + -- use set difference to avoid duplicates + newNames = loadedNames \\ oldNames + newTools = map functionTool newNames + in do + { + ; newPairs <- + mapM (makeNamedToolButton cbmgr) newTools + ; rp' <- rpanelAddWidgets rp newPairs + ; widgetShowAll (rpanelRoot rp) + ; return rp' + } + in do + { + vpui'' <- + showFunctionPadWindow cbmgr vpui' >>= + updateFunctionPadIO title updatePad + ; return $ vpui'' {vpuiFilePath = mpath, + vpuiFileChanged = False} + } + } + +showDialogFileOpen :: VPUI -> IO (Maybe FilePath) +showDialogFileOpen _vpui = do + chooser <- fileChooserDialogNew + Nothing -- default title + Nothing -- transient parent of the dialog + FileChooserActionOpen + [("Open", ResponseOk), ("Cancel", ResponseCancel)] -- buttons + result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename + return result + +loadFile :: VPUI -> FilePath -> IO (SuccFail (VPUI, [Function])) +loadFile vpui filePath = do + { + functions <- consumeFile xmlToFunctions filePath + ; case functions of + [Functions fs] -> + let vpui' = foldl bindFunction vpui fs + in return (Succ (vpui', fs)) + _ -> + return (Fail "file format error") + + } + +bindFunction :: VPUI -> Function -> VPUI +bindFunction vpui function = + let env = vpuiGlobalEnv vpui + Function (Just name) _argTypes _resType _impl = function + env' = envIns env name (VFun function) + in vpui {vpuiGlobalEnv = env'} + +menuFileSave :: VPUI -> IO VPUI +menuFileSave vpui = + case vpuiFilePath vpui of + Nothing -> menuFileSaveAs vpui + Just filePath -> saveFile vpui filePath + +menuFileSaveAs :: VPUI -> IO VPUI +menuFileSaveAs vpui = do + mpath <- showDialogFileSaveAs vpui + case mpath of + Nothing -> return vpui -- canceled + Just filePath -> saveFile vpui filePath + +showDialogFileSaveAs :: VPUI -> IO (Maybe FilePath) +showDialogFileSaveAs _vpui = do + chooser <- fileChooserDialogNew + Nothing -- default title + Nothing -- transient parent of the dialog + FileChooserActionSave + [("Save", ResponseOk), ("Cancel", ResponseCancel)] -- buttons + result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename + print ("dialog result", result) + return result + +-- | Returns the updated VPUI with updated fields +-- vpuiFilePath and vpuiFileChanged + +-- What about IO errors? ****** + +saveFile :: VPUI -> FilePath -> IO VPUI +saveFile vpui filePath = + let functions = Functions (map (valueFunction . snd) + (vpuiUserEnvAList vpui)) + in produceFile functions filePath >> + return vpui {vpuiFilePath = Just filePath, vpuiFileChanged = False} + +-- | Text shown by the help dialog +helpText :: String +helpText = + unlines ["Functions menu:", + " \"New\" enters a dialog to create a new function.", + " \"Function pad\" raises the function pad window.", + "Keystroke shortcuts for the menu commands are shown " ++ + "using \"C-\" for Control. For example, Quit " ++ + "is C-q, meaning Control+Q.", + "", + "In a function editor, right-click for the context menu.", + "", + "For more help, please visit the Sifflet web site,", + "http://mypage.iu.edu/~gdweber/software/sifflet/", + "especially the Sifflet Tutorial:", + "http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html" + ] + +-- | Show the help dialog +showHelpDialog :: MenuItemAction +showHelpDialog vpui = showInfoMessage "Sifflet Help" helpText >> return vpui + +-- | How to report bugs +bugsText :: String +bugsText = + unlines ["To report bugs, please send mail to " ++ bugReportAddress, + "and mention \"Sifflet\" in the Subject header.", + "To send praise, follow the same procedure.", + "Seriously, whether you like Sifflet or dislike it,", + "I'd like to hear from you." + ] + +bugReportAddress :: String +bugReportAddress = concat ["gdweber", at, "iue", punctum, "edu"] + where at = "@" + punctum = "." + +showBugs :: MenuItemAction +showBugs vpui = showInfoMessage "Reporting bugs" bugsText >> return vpui + +-- | Text for the About dialog +aboutText :: String +aboutText = + unlines ["Sifflet version " ++ siffletVersionString, + "Copyright (C) 2010 Gregory D. Weber", + "", + "BSD3 License", + "", + "Sifflet home page:", + "http://mypage.iu.edu/~gdweber/software/sifflet/" + ] + +-- | The software version number. +-- How can this be synchronized with darcs and Cabal? +siffletVersionString :: String +siffletVersionString = "0.1.5" + +showAboutDialog :: MenuItemAction +showAboutDialog vpui = showInfoMessage "About Sifflet" aboutText >> return vpui + +-- ---------------------------------------------------------------------- + +-- Moved here from Callbacks.hs: + +setWSCanvasCallbacks :: VPUI -> WinId -> CBMgr -> IO () +setWSCanvasCallbacks vpui winId cbmgr = do + { + let vw = vpuiGetWindow vpui winId + window = vpuiWindowWindow vw + ; case vpuiWindowLookupCanvas vw of + Nothing -> + error ("setWSCanvasCallbacks: VPUIWindow is not a VPUIWorkWin" ++ + " and has no canvas") + Just canvas -> + do + { + -- Notice when the window size is changed + ; cbmgr (OnWindowConfigure window (configuredCallback winId)) + + -- Keypress events -- send to canvas window because the Gtk.Layout + -- cannot receive them (why ever not?) + ; cbmgr (OnWindowKeyPress window (keyPressCallback winId cbmgr)) + + -- Send remaining events to the Gtk.Layout (why?) + ; let layout = vcLayout canvas + ; widgetSetCanFocus layout True + ; cbmgr (OnLayoutExpose layout (exposedCallback winId)) + + -- Mouse events + ; widgetAddEvents layout [PointerMotionMask] + ; cbmgr (OnLayoutMouseMove layout (mouseMoveCallback winId)) + ; cbmgr (OnLayoutButtonPress layout + (buttonPressCallback winId cbmgr)) + ; cbmgr (OnLayoutButtonRelease layout (buttonReleaseCallback winId)) + } + } + +-- | Context menu command to edit the function displayed in +-- a CallFrame + +editFrameFunction :: CBMgr -> CanvFrame -> VPUI -> IO VPUI +editFrameFunction cbmgr frame vpui = + let func = cfFunctoid frame + in showFedWin cbmgr (functoidName func) (functoidArgNames func) vpui + +-- | Create a new function, add it to the global environment +-- with body undefined, and start editing it in a new window. +-- Also update and show "My Functions" toolbox and +-- update its toolkit. + +editNewFunction :: CBMgr -> String -> [String] -> VPUI -> IO VPUI +editNewFunction cbmgr name args vpui = + let updateEnv :: VPUI -> IO VPUI + updateEnv vpui' = + let env = vpuiGlobalEnv vpui' + env' = envIns env name (VFun (newUndefinedFunction name args)) + in return $ vpui' {vpuiGlobalEnv = env'} + in + -- Show window first, with the *old* functions + showFunctionPadWindow cbmgr vpui >>= + updateEnv >>= + vpuiUpdateWindowIO functionPadWinId + (addFunctionPadToolButton cbmgr "My Functions" + (functionTool name)) >>= + showFedWin cbmgr name args + +configuredCallback :: WinId -> IORef VPUI -> EventM EConfigure Bool +configuredCallback winId uiref = + tryEvent $ do + { + (w, h) <- eventSize + ; liftIO $ modifyIORef uiref (handleConfigured winId w h) + -- We *must* "stop the event", forcing the event handler + -- to return False, or else the canvas remains "squeezed in" + -- -- Weird!! + ; stopEvent + } + +-- | Handle the Configured event. +handleConfigured :: WinId -> Int -> Int -> VPUI -> VPUI +handleConfigured winId width height vpui = + let vw = vpuiGetWindow vpui winId + vw' = vpuiWindowModCanvas vw + (atLeastSize (Size (fromIntegral width) (fromIntegral height))) + in vpuiReplaceWindow vpui winId vw' + +exposedCallback :: WinId -> IORef VPUI -> EventM EExpose Bool +exposedCallback winId uiref = + tryEvent $ do + { + clipbox <- eventArea + ; liftIO (readIORef uiref >>= handleExposed winId clipbox) + } + +-- | Handle the Exposed event, should be called only for a window +-- with a canvas +handleExposed :: WinId -> Rectangle -> VPUI -> IO () +handleExposed winId clipbox vpui = + let vw = vpuiGetWindow vpui winId -- error if not found + in case vpuiWindowLookupCanvas vw of + Nothing -> info "handleExposed: no canvas found!" + Just canvas -> drawCanvas canvas clipbox + +data KeyBinding = KeyBinding {kbGtkKeyName :: String, + kbAltKeyName :: Maybe String, -- for humans + kbRequiredModifiers :: [Modifier], + kbDescription :: String, + kbAction :: KeyAction} + +data KeyAction + = KeyActionST (WinId -> VPUI -> IO VPUI) -- ^ set a tool + | KeyActionDG (WinId -> CBMgr -> VPUI -> IO VPUI) -- ^ start a dialog + | KeyActionModIO (CBMgr -> VPUI -> IO VPUI) -- ^ modify VPUI with IO + | KeyActionHQ (VPUI -> IO ()) -- ^ help or quit + +-- | Key bindings map. This is derived from keyBindingsList. +keyBindingsMap :: Map String KeyBinding +keyBindingsMap = Map.fromList [(kbGtkKeyName kb, kb) | kb <- keyBindingsList] + +-- | KeyBinding list for workspace and function editor windows. + +keyBindingsList :: [KeyBinding] +keyBindingsList = + [ + -- Bindings to set tools + KeyBinding "c" Nothing [] "connect" + (KeyActionST (vpuiSetTool ToolConnect)) + , KeyBinding "d" Nothing [] "disconnect" + (KeyActionST (vpuiSetTool ToolDisconnect)) + , KeyBinding "i" Nothing [] "if" (KeyActionST (vpuiSetTool ToolIf)) + , KeyBinding "m" Nothing [] "move" (KeyActionST (vpuiSetTool ToolMove)) + , KeyBinding "KP_Delete" (Just "Keypad-Del") [] "delete" + (KeyActionST (vpuiSetTool ToolDelete)) + + -- Bindings to start dialogs + , KeyBinding "n" Nothing [] "new function" (KeyActionDG newFunctionDialog) + , KeyBinding "f" Nothing [] "function" (KeyActionDG showFunctionEntry) + , KeyBinding "l" Nothing [] "literal" (KeyActionDG showLiteralEntry) + + -- Help and quit + + , KeyBinding "question" (Just "?") [] "help" (KeyActionHQ vpuiKeyHelp) + + -- Shortcuts for menu commands (GTK "accelerators", but not done + -- in the standard GTK way). + -- These need to be coordinated with buildMainMenu, + -- in WindowManagement.hs + +-- Oops! Binding Ctrl+F here interferes with binding just plain f above. +-- , KeyBinding "f" (Just "Control-f") [Control] "function-pad" +-- (KeyActionModIO showFunctionPadWindow) + + , KeyBinding "o" (Just "Control-o") [Control] "open" + (KeyActionModIO menuFileOpen) + , KeyBinding "s" (Just "Control-s") [Control] "save" + (KeyActionModIO (\ _cbmgr -> menuFileSave)) + , KeyBinding "q" (Just "Control-q") [Control] "quit" + (KeyActionHQ (\ vpui -> vpuiQuit vpui >> return ())) + ] + +-- | Unused argument needed for key bindings +vpuiKeyHelp :: VPUI -> IO () +vpuiKeyHelp _vpui = putStrLn keyBindingsHelpText + +-- | Help text built from key bindings +keyBindingsHelpText :: String +keyBindingsHelpText = + let add :: String -> KeyBinding -> String + add result (kb@KeyBinding {kbAltKeyName = mkey}) = + concat [result, " ", + case mkey of + Nothing -> kbGtkKeyName kb + Just akey -> akey, + " = ", kbDescription kb, "\n"] + in foldl add "" keyBindingsList + +-- | What to do when a key is pressed +keyPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EKey Bool +keyPressCallback winId cbmgr uiref = + tryEvent $ do + { + kname <- eventKeyName + ; mods <- eventModifier + -- ; liftIO $ print mods + + ; let giveUp = + -- liftIO (info ("Unrecognized key: " ++ kname)) >> + stopEvent + + ; case Map.lookup kname keyBindingsMap of + Nothing -> + giveUp + Just keyBinding -> + if checkMods (kbRequiredModifiers keyBinding) mods + then liftIO $ + case kbAction keyBinding of + KeyActionModIO f0 -> + -- update with IO + modifyIORefIO uiref (f0 cbmgr) + KeyActionST f1 -> + -- update with IO and window ID + modifyIORefIO uiref (f1 winId) + KeyActionDG f2 -> + -- update with IO and cbmgr to set further callbacks + modifyIORefIO uiref (f2 winId cbmgr) + KeyActionHQ f3 -> + -- no update, no cbmgr, no further callbacks + readIORef uiref >>= f3 + else giveUp + } + +buttonPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EButton Bool +buttonPressCallback winId cbmgr uiref = + tryEvent $ do + { + ; (x, y) <- eventCoordinates + ; mouseButton <- eventButton + ; mods <- eventModifier + ; timestamp <- eventTime + ; liftIO + (modifyIORefIO uiref + (handleButtonPress winId cbmgr mouseButton x y mods timestamp)) + } + +mouseMoveCallback :: WinId -> IORef VPUI -> EventM EMotion Bool +mouseMoveCallback winId uiref = + tryEvent $ do + { + (x, y) <- eventCoordinates + ; mods <- eventModifier + ; liftIO (modifyIORefIO uiref (handleMouseMove winId x y mods)) + } + +buttonReleaseCallback :: WinId -> IORef VPUI -> EventM EButton Bool +buttonReleaseCallback winId uiref = + tryEvent $ do + { + mouseButton <- eventButton + ; liftIO (modifyIORefIO uiref (handleButtonRelease winId mouseButton)) + } + +-- | Handle the ButtonPress event. Should be called only for a window +-- with a canvas. +handleButtonPress :: WinId -> CBMgr -> MouseButton + -> Double -> Double -- x, y + -> [Modifier] -> TimeStamp -- timestamp not needed? + -> VPUI ->IO VPUI +handleButtonPress winId cbmgr mouseButton x y mods timestamp vpui = + let vw = vpuiGetWindow vpui winId + in case vpuiWindowLookupCanvas vw of + Nothing -> info "handleButtonPress: no canvas found!" >> + return vpui + Just canvas -> + case whichFrame canvas x y of + Nothing -> + case vcTool canvas of + Nothing -> return vpui + Just tool -> toolOp tool vpui winId TCWorkspace mods x y + Just frame -> + frameButtonPressed winId cbmgr vw + frame mods (x, y) + mouseButton timestamp vpui + +-- | Handles button pressed in a frame +frameButtonPressed :: WinId -> CBMgr -> VPUIWindow -> CanvFrame + -> [Modifier] -> (Double, Double) -> MouseButton + -> TimeStamp + -> VPUI + -> IO VPUI +frameButtonPressed winId cbmgr vw frame mods (x, y) mouseButton timestamp vpui = + let retWrap :: VPUIWindow -> IO VPUI + retWrap = return . vpuiReplaceWindow vpui winId + in case mouseButton of + LeftButton -> + if cfPointInHeader frame x y + then beginFrameDrag vw frame x y >>= retWrap + else if cfPointInFooter frame x y + then leftButtonPressedInFrameFooter vw frame >>= retWrap + else frameBodyButtonPressed vpui winId frame + mouseButton mods x y + MiddleButton -> return vpui + RightButton -> + offerContextMenu winId cbmgr frame RightButton timestamp >> + return vpui + OtherButton _ -> return vpui + +-- | Handles button pressed in the body of a frame +-- frameBodyButtonPressed needs VPUIWindow because it calls a toolOp. +-- mb (mouse button) is unused, but might be used later. +frameBodyButtonPressed :: VPUI -> WinId -> CanvFrame + -> MouseButton -> [Modifier] -> Double -> Double + -> IO VPUI +frameBodyButtonPressed vpui winId frame _mb mods x y = do + { + let vw = vpuiGetWindow vpui winId + canvas = vpuiWindowGetCanvas vw + mnode = vcanvasNodeAt canvas (Position x y) + ; case mnode of + Nothing -> + case vcTool canvas of + Nothing -> return vpui + Just tool -> toolOp tool vpui winId (cfContext frame) mods x y + Just node -> + do + { + vw' <- openNode vw node + ; return $ vpuiReplaceWindow vpui winId vw' + } + } + +-- | Handles left button pressed in the footer of a frame +leftButtonPressedInFrameFooter :: + VPUIWindow -> CanvFrame -> IO VPUIWindow +leftButtonPressedInFrameFooter vw frame = + let canvas = vpuiWindowGetCanvas vw + in case frameType frame of + CallFrame -> + -- request argument values and evaluate call + if cfEvalReady frame + then do + canvas' <- vcEvalDialog canvas frame + return $ vpuiWindowSetCanvas vw canvas' + else return vw + EditFrame -> + -- ignore + return vw + +-- | Handles beginning of mouse-drag +beginFrameDrag :: VPUIWindow -> CanvFrame -> Double -> Double + -> IO VPUIWindow +beginFrameDrag vw frame x y = + let canvas = vpuiWindowGetCanvas vw + window = vpuiWindowWindow vw + dragging = Dragging {draggingNode = cfFrameNode frame, + draggingPosition = Position x y} + canvas' = canvas {vcDragging = Just dragging} + in setCursor window XCursor.Fleur >> + (return $ vpuiWindowSetCanvas vw canvas') + +-- | Handle mouse move event +handleMouseMove :: WinId -> Double -> Double -> [Modifier] -> VPUI -> IO VPUI +handleMouseMove winId x y mods vpui = +-- Needs to be in IO because of drawWindowInvalidateRect + let vw = vpuiGetWindow vpui winId + in case vpuiWindowLookupCanvas vw of + Nothing -> + info "SQUAWK! No canvas! Shouldn't happen!" >> + return vpui -- shouldn't happen + Just canvas -> + do + { + -- Highlight the active node, if any + let active = vcActive canvas + active' = vcanvasNodeAt canvas (Position x y) + + invalidate :: DrawWindow -> Maybe G.Node -> IO () + invalidate win mnode = + case mnode of + Nothing -> return () + Just node -> + drawWindowInvalidateRect win + (vcanvasNodeRect canvas node) False + + ; when (active /= active') $ + do + { + win <- layoutGetDrawWindow (vcLayout canvas) + ; invalidate win active + ; invalidate win active' + } + -- if dragging, continue drag + ; canvas' <- continueDrag (canvas {vcActive = active', + vcMousePos = (x, y)}) + mods x y + ; let vw' = vpuiWindowSetCanvas vw canvas' + ; return $ vpuiReplaceWindow vpui winId vw' + } + +continueDrag :: VCanvas -> [Modifier] -> Double -> Double -> IO VCanvas +continueDrag canvas mods x y = + case vcDragging canvas of + Nothing -> return canvas + Just dragging -> + let graph = vcGraph canvas + dnode = draggingNode dragging + wnode = wlab graph dnode + Position oldX oldY = draggingPosition dragging + (dx, dy) = (x - oldX, y - oldY) + in + case wnode of + WSimple _ -> + continueDragSimple canvas dragging dnode mods x y dx dy + WFrame frameNode -> + continueDragFrame canvas dragging frameNode x y dx dy + +continueDragSimple :: VCanvas -> Dragging -> G.Node -> [Modifier] + -> Double -> Double -> Double -> Double -> IO VCanvas +continueDragSimple canvas dragging simpleNode mods x y dx dy = + let graph = vcGraph canvas + frame = nodeContainerFrame canvas graph simpleNode + dragging' = dragging {draggingPosition = Position x y} + translateSelection = if checkMods [Shift] mods + then translateTree + else translateNode + graph' = translateSelection dx dy graph simpleNode + canvas' = canvas {vcGraph = graph'} + in vcInvalidateFrameWithParent canvas graph frame >> + return (canvas' {vcDragging = Just dragging'}) + +continueDragFrame :: + VCanvas -> Dragging -> G.Node -> + Double -> Double -> Double -> Double -> IO VCanvas +continueDragFrame canvas dragging frameNode x y dx dy = + let graph = vcGraph canvas + frame = vcGetFrame canvas graph frameNode + frame' = translateFrame frame dx dy + graph' = grTranslateFrameNodes graph frame dx dy + canvas' = vcUpdateFrameAndGraph canvas frame' graph' + dragging' = Just dragging {draggingPosition = Position x y} + in + -- Tell the GUI about the changes so they will be redrawn + -- Mark the frame changed so it will be redrawn + frameChanged canvas graph frame graph' frame' >> + -- Also, any frames opened from nodes of this frame + mapM_ (\f -> frameChanged canvas graph f graph' f) + (vcFrameSubframes canvas frame) >> + -- Return the modified canvas + return (canvas' {vcDragging = dragging'}) + +handleButtonRelease :: WinId -> MouseButton -> VPUI -> IO VPUI +handleButtonRelease winId mouseButton vpui = + case mouseButton of + LeftButton -> + -- End drag + let vw = vpuiGetWindow vpui winId + canvas = vpuiWindowGetCanvas vw + window = vpuiWindowWindow vw + vw' = vpuiWindowSetCanvas vw (canvas {vcDragging = Nothing}) + vpui' = vpuiReplaceWindow vpui winId vw' + in setCursor window XCursor.LeftPtr >> + return vpui' + _ -> return vpui + +-- | Show a context menu for mouse click in a frame. +offerContextMenu :: WinId -> CBMgr -> CanvFrame + -> MouseButton -> TimeStamp -> IO () +offerContextMenu winId cbmgr frame button timestamp = do + -- Needs CBMgr to specify menu actions. + { + let menuSpec = + MenuSpec "Context Menu" (contextMenuOptions winId cbmgr frame) + ; menu <- createMenu menuSpec cbmgr + ; widgetShowAll menu + ; menuPopup menu (Just (button, timestamp)) + } + +-- | Options for context menu that depend on the frame type. + +contextMenuOptions :: WinId -> CBMgr -> CanvFrame -> [MenuItemSpec] +contextMenuOptions winId cbmgr frame = + let typeDependentOptions :: [MenuItemSpec] + typeDependentOptions = + case frameType frame of + CallFrame -> + [MenuItem "Edit" (editFrameFunction cbmgr frame) + , MenuItem "Close" (\ vpui -> closeFrame vpui winId frame)] + EditFrame -> + [ + -- The next items duplicate parts of keyBindingsList + MenuItem "CONNECT (c)" (vpuiSetTool ToolConnect winId) + , MenuItem "DISCONNECT (d)" (vpuiSetTool ToolDisconnect winId) + , MenuItem "IF (i)" (vpuiSetTool ToolIf winId) + , MenuItem "FUNCTION (f)" (showFunctionEntry winId cbmgr) + , MenuItem "LITERAL (l)" (showLiteralEntry winId cbmgr) + -- , ("CLEAR (not implemented)", clearFrame winId frame) + , MenuItem "MOVE (m)" (vpuiSetTool ToolMove winId) + , MenuItem "DELETE (KP-Del)" (vpuiSetTool ToolDelete winId) + ] + in typeDependentOptions ++ + [ +-- ("Dump frame (debug)", +-- \ vpui -> dumpFrame vpui winId frame >> return vpui) +-- , ("Dump graph (debug)", \ vpui -> +-- dumpGraph vpui winId >> return vpui) +-- , ("--QUIT--", \ vpui -> vpuiQuit vpui >> return vpui) + ] diff --git a/Workspace.hs b/Workspace.hs new file mode 100644 --- /dev/null +++ b/Workspace.hs @@ -0,0 +1,20 @@ +{- Workspace.hs implements the graphical workspace of Sifflet -} + +module Workspace + ( + module Workspace.Canvas + , module Workspace.Frame + , module Workspace.Functoid + , module Workspace.Tools + , module Workspace.WGraph + , module Workspace.Workspace + ) + +where + +import Workspace.Canvas +import Workspace.Frame +import Workspace.Tools +import Workspace.Functoid +import Workspace.WGraph +import Workspace.Workspace diff --git a/Workspace/Canvas.hs b/Workspace/Canvas.hs new file mode 100644 --- /dev/null +++ b/Workspace/Canvas.hs @@ -0,0 +1,979 @@ +-- File: Canvas.hs +-- Canvas and CanvFrame data and operations + +module Workspace.Canvas + ( + VCanvas(..), Selection(..), Dragging(..) + , atLeastSize + , cfContext + , connect + , disconnect + , drawCanvas + , editFunction + , frameChanged + , nodeContainerFrame + , pointSelection + , vcAddFrame + , vcClearSelection + , vcClearFrame + , vcCloseFrame + , vcEvalDialog + , vcFrameAddFunctoidNode + , vcFrameAddNode + , vcFrameDeleteNode + , vcFrameDeleteTree + , vcFrameSubframes + , vcGetFrame + , vcInvalidateFrameWithParent + , vcInvalidateBox + , vcUpdateFrameAndGraph + , vcanvasNew + , vcanvasNodeAt + , vcanvasNodeRect + , whichFrame + , callFrames + ) + +where + +import Control.Monad +import Data.List as List + +import Data.Graph.Inductive as G +import Graphics.UI.Gtk hiding (Frame, Function, Style, Size, + buttonPressed, fill, function, + lineWidth, disconnect) +import Graphics.Rendering.Cairo hiding (translate) + +import Expr +import Geometry +import GtkUtil +import Tree as T +import TreeGraph +import TreeLayout +import UITypes +import Workspace.Frame +import Workspace.Functoid +import Workspace.WGraph + + +-- 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 = error (concat ["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) = + error ("loopWithInlets: insufficient inlets, with these " ++ + "outs remaining: " ++ show (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) + + +graphRenderNode :: + Style -> Maybe Node -> Maybe Selection -> WGraph -> + G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)]) +-- 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 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 + defaultInlet = Iolet (Geometry.Circle + (Position xcenter (bbBottom nodeBB)) 0) + inlets = + case gnodeInlets (nodeGNode lnode) of + [] -> replicate (length outs) defaultInlet + is -> is + + -- 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] + + in if length inlets < length outs' + then error ("graphRenderTree: insufficient inlets: " ++ + show (length inlets, length outs') ++ " " ++ + show (inlets, outs')) + else 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 values = [] if you do not want the frame to be evaluated +-- as a function call. +-- +-- 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 -> [Value] -> FrameType + -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VCanvas +vcAddFrame canvas functoid values 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 values + 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 +-- --------------------------------------------------------------------- + +drawCanvas :: VCanvas -> Rectangle -> IO () +drawCanvas canvas clipbox = do + { + -- 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 (Rectangle ix iy iwidth iheight) = do + { + rectangle (fromIntegral ix) (fromIntegral iy) + (fromIntegral iwidth) (fromIntegral iheight) + ; 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 + } + + 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 + } + + 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 + } + + ; drawWin <- layoutGetDrawWindow (vcLayout canvas) + ; renderWithDrawable drawWin $ do + { + setClip clipbox + ; drawBackground + -- sorting is a possible bottleneck? + ; (mapM_ renderFrame (sortBy levelOrder frames)) + } + + } + +-- | 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 = do + let FunctoidFunc function = cfFunctoid frame -- FunctoidParts should not happen + varnames = cfVarNames frame + labels = varnames + argDefault env arg = + case envLookup env arg of + Nothing -> "" + Just value -> repr value + defaults = map (argDefault (cfEnv frame)) varnames + reader :: Reader [String] [Value] + reader inputs = + mapM stringToValue inputs >>= + typeCheck varnames (functionArgTypes function) + dialog <- + createEntryDialog "Input Values" labels defaults reader (-1) + result <- runEntryDialog dialog + case result of + Nothing -> return canvas + Just values -> evalFrame canvas frame values + +evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas +-- evaluate the frame, having gotten a list of values from the dialog +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) 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 -- was vpui' = ... + + -- remove it from the frames list + let canvas'' = vcDeleteFrame canvas' frame -- was vpui'' = ... + + -- remove it and its edges from the graph + let -- was vcanvas = vpuiCanvas vpui'' + graph = vcGraph canvas'' + (_mcontext, graph') = match (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) diff --git a/Workspace/Frame.hs b/Workspace/Frame.hs new file mode 100644 --- /dev/null +++ b/Workspace/Frame.hs @@ -0,0 +1,304 @@ +module Workspace.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 Expr +import Geometry +import Tree +import TreeLayout +import Workspace.Functoid +import Workspace.WGraph + +-- --------------------------------------------------------------------- +-- 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 -> + error ("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 -> [Value] -> FrameType -- added arg + -> Node -> Env -> Maybe G.Node + -> (CanvFrame, FunctoidLayout) -- reversed tuple +frameNewWithLayout style (Position x y) z + functoid values 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 values + env = if null values + -- dummy extension to be popped off + then extendEnv [] [] prevEnv + else extendEnv vars values prevEnv + -- body tlo + layout0 = flayout style functoid env values + -- 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] -> [Value] -> String +buildFooterText vars values = + concat (intersperse ", " + (case values of + [] -> vars + _ -> + if length vars /= length values + then error ("buildFooterText: " ++ + "mismatched lists") + else [var ++ " = " ++ repr value | + (var, value) <- zip vars values] + )) + diff --git a/Workspace/Functoid.hs b/Workspace/Functoid.hs new file mode 100644 --- /dev/null +++ b/Workspace/Functoid.hs @@ -0,0 +1,95 @@ +module Workspace.Functoid + (Functoid(..) + , functoidName, functoidArgNames, functoidHeader + , FunctoidLayout(..), flayout + , flayoutBBox, flayoutSize, flayoutWidth, flayoutBottom + , flayoutWiden) + +where + +import Data.Graph.Inductive as G + +import Geometry +import Expr +import TreeLayout + +-- | 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 + +flayout :: Style -> Functoid -> Env -> [Value] -> FunctoidLayout +flayout style functoid env values = + 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 + exprTree = if null values + then exprToTree expr + else evalTree (exprToTree expr) env + tlo = treeLayout style (exprNodeIoletCounter env) 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 Draw FunctoidLayout where + + draw style mode (FLayoutTree t) = draw style mode t + draw style mode (FLayoutForest f _) = draw style mode f + + translate dx dy (FLayoutTree t) = FLayoutTree (translate dx dy t) + translate dx dy (FLayoutForest f b) = + FLayoutForest (translate dx dy f) (translate dx dy b) diff --git a/Workspace/Tools.hs b/Workspace/Tools.hs new file mode 100644 --- /dev/null +++ b/Workspace/Tools.hs @@ -0,0 +1,553 @@ +module Workspace.Tools + ( + ToolId(..) + , Tool(..), ToolContext(..) + , checkMods + , functionTool + , functionToolsFromLists + , makeConnectTool + , makeCopyTool + , makeDeleteTool + , makeDisconnectTool + , makeFixedArgTool + , 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 + hiding (Frame, Function, Style, Size, buttonPressed, fill, lineWidth, + disconnect) +import Graphics.UI.Gtk.Gdk.EventM + +import CBMgr +import Expr +import Geometry +import Tree (putTree, repr) +import TreeGraph (graphToOrderedTreeFrom) + +import UITypes +import Util +import Workspace.Canvas +import Workspace.Frame +import Workspace.Functoid +import Workspace.WGraph + + +data ToolId + = ToolConnect + | ToolDisconnect + | ToolIf + | ToolMove + | ToolDelete + | ToolFunction String -- ^ function name + | ToolLiteral Expr + | ToolArg String -- ^ argument name + deriving (Eq, Show) + +-- 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 expr -> makeFixedLiteralTool expr + ToolArg argname -> makeFixedArgTool argname + + +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 + +makeFixedLiteralTool :: Expr -> Tool +makeFixedLiteralTool expr = + case expr of + ELit literal -> + let node = ENode (NLit literal) EvalUntried + addLitNode vw toolContext _mods x y = + case toolContext of + TCEditFrame frame -> + vcFrameAddNode vw frame node [] x y + _ -> + return vw -- Nothing + in Tool ("Literal: " ++ repr literal) return (toToolOpVW addLitNode) + _ -> + error $ "makeFixedLiteralTool: non-literal expression " ++ show expr + +makeFixedArgTool :: String -> Tool +makeFixedArgTool label = + let node = ENode (NSymbol (Symbol label)) EvalUntried + addArgNode vw toolContext _mods x y = + case toolContext of + TCEditFrame frame -> + vcFrameAddNode vw frame node [] x y + _ -> + return vw -- no effect + in Tool ("Argument: " ++ label) 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) [] + 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 -> [Value] -> FrameType + -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VPUI +vpuiAddFrame vpui winId functoid values mode prevEnv x y z mparent = + let update vw = + vwAddFrame vw functoid values 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 -> [Value] -> FrameType + -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VPUIWindow +vwAddFrame vw functoid values mode prevEnv x y z mparent = + let modify canvas = vcAddFrame canvas functoid values 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 + stringToLiteral -- 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 + +-- 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 + { + ; vbox <- vBoxNew False 5 + ; evtBox <- eventBoxNew -- needed for Label visibility + ; label <- labelNew (Just prompt) + ; entry <- entryNew + ; case mcompletions of + Nothing -> return () + Just comps -> addEntryCompletions entry comps + + -- Organize as (vbox (eventbox (label), entry)) + ; containerAdd evtBox label + ; boxPackStartDefaults vbox evtBox + ; boxPackStartDefaults vbox entry + ; layoutPut layout vbox (round xx) (round yy) + ; widgetShowAll vbox + + -- 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 vbox entry) + ; uimgr (OnEntryActivate entry + (entryActivated vbox 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 value -> + grabRemove entry >> + widgetDestroy container >> + readIORef uiref >>= + vpuiSetTool (toolType value) 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 = print . 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 diff --git a/Workspace/WGraph.hs b/Workspace/WGraph.hs new file mode 100644 --- /dev/null +++ b/Workspace/WGraph.hs @@ -0,0 +1,415 @@ +module Workspace.WGraph + (WNode(..), WEdge(..), WGraph, wgraphNew, grInsertNode, grRemoveNode + , connectToFrame + , grConnect, grDisconnect + , grAddGraph + , grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree + + , unmaybe -- move to Util? + , wlab, llab, nodeExprNode, nodeText, nodeValue + , nodeBBox, nodePosition, nodeInputValues + , nodeAllChildren, nodeSimpleChildren, nodeFrameChildren + , nodeAllSimpleDescendants, nodeProperSimpleDescendants + , nodeIsSimple, nodeIsOpen, nodeContainerFrameNode + , nodeParent + + , grUpdateFLayout, grUpdateTreeLayout + , translateNodes + , translateNode, grRelabelNode + , translateTree + , functoidParts, functionToParts + ) + +where + +import Data.List (sort) + +import Data.Graph.Inductive as G + +import Geometry +import TreeLayout +import Expr +import Tree as T -- exports Data.Tree.Tree(Node), etc. +import Workspace.Functoid + +-- | 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 + +data 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 _) = "" + +wgraphNew :: WGraph +wgraphNew = empty + +-- | 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 -> error $ "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 + +-- | unmaybe is the inverse of Maybe, sort of +unmaybe :: Maybe a -> a +unmaybe (Just x) = x +unmaybe Nothing = error "unmaybe: Nothing" + +-- | wlab is like lab with no Maybe: the node *must* have a label +wlab :: WGraph -> Node -> WNode +wlab g n = unmaybe (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 -> + error (concat ["llab: node is not simple\n", + "node ", (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 + +-- | 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) + +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 = + error (concat ["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, _) -> + error ("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 + _ -> error ("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, _) -> + error $ "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 _, _) -> + error $ "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, _) -> error ("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} diff --git a/Workspace/Workspace.hs b/Workspace/Workspace.hs new file mode 100644 --- /dev/null +++ b/Workspace/Workspace.hs @@ -0,0 +1,412 @@ +{- Currently, this module contains functions for VPUI, VPUIWindow, +Workspace, VCanvas, and more. A reorganization seems called for, +but for now I will just keep adding functions here. -} + +module Workspace.Workspace + ( + -- VPUI and Workspace + vpuiNew + , defaultVPUIToolkits + , Workspace(..), workspaceNewDefault, workspaceNewEditing + , addArgToolButtons + , addApplyCloseButtons + , defineFunction + , openNode + + -- Quitting: + , removeWindow + , vpuiQuit + + -- Windows: + , forallWindowsIO + ) + +where + +import Control.Monad + +import Data.Map (Map, (!), fromList, keys) +import qualified Data.Map as Map (empty) + +import Data.Graph.Inductive as G +import Graphics.UI.Gtk as Gtk + hiding (Frame, Function, Style, Size, buttonPressed, fill, lineWidth, + disconnect, function, remove) + +import CBMgr +import Examples +import Expr +import Geometry +import GtkUtil +import TreeGraph +import TreeLayout +import UITypes +import Util +import Workspace.Canvas +import Workspace.Frame +import Workspace.Functoid +import Workspace.Tools +import Workspace.WGraph + +-- | Create a new VPUI. +-- This used to set up the basic "q to quit" and "on exposed" callbacks, +-- but now does not even do that. +-- The 'init' function argument +-- may perform additional initialization; +-- if there is none, simply use 'return'. + +-- The following comment is out of date, +-- but may explain some bizarre features historically: + +-- Note that if you want to set up callbacks, +-- there is some trickiness: the vpui contains the workspace, +-- and the layout (which is on the workspace) needs to have callbacks +-- which know the uiref. So, create the workspace, vpui, and uiref, +-- in that order, and then set up the callbacks. + + +vpuiNew :: Style -> Env -> IO VPUI +vpuiNew style env = do + group <- radioToolButtonNew + return VPUI {vpuiWindows = Map.empty, + vpuiToolkits = Map.empty, + vpuiButtonGroup = group, + vpuiFilePath = Nothing, + vpuiFileChanged = False, + vpuiStyle = style, + vpuiInitialEnv = env, + vpuiGlobalEnv = env + } + +baseFunctionsRows :: [[String]] +baseFunctionsRows = [["+", "-", "*", "div", "mod", "add1", "sub1", "/"], + ["==", "/=", "<", ">", "<=", ">="], + ["zero?", "positive?", "negative?"], + ["null", "head", "tail", ":"]] + +defaultVPUIToolkits :: Map String VPToolkit +defaultVPUIToolkits = + let toolkits = + -- each item has name, width, list of rows tools + [VPToolkit "Base" 500 (functionToolsFromLists baseFunctionsRows), + VPToolkit "Examples" 500 + (functionToolsFromLists [exampleFunctionNames]), + VPToolkit "My Functions" 500 (functionToolsFromLists [[]])] + in fromList (zip (map toolkitName toolkits) toolkits) + + +-- | Create a new "main" workspace window, with a given style. +-- The second argument should set up a menu bar and place it on the vbox, +-- or do nothing if no menu is wanted. +workspaceNewDefault :: Style -> (VBox -> IO ()) -> IO Workspace +workspaceNewDefault style = + workspaceNew style (Size 3600.0 2400.0) (Just (Size 900.0 600.0)) + +workspaceNewEditing :: Style -> Env -> Function -> IO Workspace +workspaceNewEditing style initEnv func = do + { + ; let argValues = [] + funcFrame = fedFuncFrame style func argValues initEnv -- throw-away + Size fwidth fheight = bbSize (cfBox funcFrame) + canvSize = Size (max fwidth 300) (max fheight 300) + mViewSize = Nothing + addNoMenu _ = return () + ; workspaceNew style canvSize mViewSize addNoMenu + } + +addArgToolButtons :: CBMgr -> WinId -> [String] -> VPUI -> IO () +addArgToolButtons cbmgr winId labels vpui = + case vpuiGetWindow vpui winId of + VPUIWorkWin ws _ -> + let bbar = wsButtonBar ws + in mapM_ (addArgToolButton cbmgr winId bbar) labels + _ -> return () + +addArgToolButton :: CBMgr -> WinId -> HBox -> String -> IO () +addArgToolButton cbmgr winId buttonBox label = do + { + button <- buttonNewWithLabel label + ; boxPackStart buttonBox button PackNatural 3 -- spacing between buttons + ; widgetShow button + ; cbmgr (AfterButtonClicked button + (\ uiref -> + modifyIORefIO uiref (vpuiSetTool (ToolArg label) winId))) + ; return () + } + +-- | Add "Apply" and "Close" buttons to a function-editor window +addApplyCloseButtons :: CBMgr -> WinId -> VPUI -> IO () +addApplyCloseButtons cbmgr winId vpui = + case vpuiGetWindow vpui winId of + VPUIWorkWin ws window -> + addApplyCloseButtons2 cbmgr winId ws window + _ -> return () + +addApplyCloseButtons2 :: CBMgr -> WinId -> Workspace -> Window -> IO () +addApplyCloseButtons2 cbmgr winId ws window = + let bbar = wsButtonBar ws + applyFrame :: VPUI -> IO VPUI + applyFrame vpui = + case vcFrames (vpuiWindowGetCanvas (vpuiGetWindow vpui winId)) of + [frame] -> defineFunction winId frame vpui + _ -> info "ApplyFrame: no unique frame found" >> return vpui + -- addButton :: String -> (IORef VPUI -> IO ()) + addButton label action = do + { + button <- buttonNewWithLabel label + ; boxPackEnd bbar button PackNatural 3 + ; widgetShow button + ; cbmgr (AfterButtonClicked button action) + } + in addButton "Close" (\ _uiref -> widgetDestroy window) >> + addButton "Apply" (\ uiref -> modifyIORefIO uiref applyFrame) + +-- | fedFuncFrame generates a throw-away frame for the sole purplse +-- of obtaining its measurements before initializing the canvas + +fedFuncFrame :: Style -> Function -> [Value] -> Env -> CanvFrame +fedFuncFrame style func values prevEnv = + let (frame, _) = + frameNewWithLayout style (Position 0 0) 0 + (FunctoidFunc func) values + CallFrame -- mode may change below + 0 prevEnv Nothing + in frame + + +-- | If mViewSize is Nothing, no scrollbars are put on the canvas, +-- and its display size request is its natural size. +-- If mViewSize = Just viewSize, then scrollbars are wrapped around +-- the canvas, and its displayed size request is viewSize. +-- addMenuBar is an action which, if desired, adds a menu bar; +-- if you don't want one, just pass (\ _ -> return ()). + +workspaceNew :: Style -> Size -> Maybe Size -> (VBox -> IO ()) -> IO Workspace +workspaceNew style canvSize mViewSize addMenuBar = do + { + ; let Size dcWidth dcHeight = canvSize -- Double, Double + (icWidth, icHeight) = (round dcWidth, round dcHeight) + + scrolled :: Gtk.Layout -> Size -> IO ScrolledWindow + scrolled layout viewSize = do + { + let Size dvWidth dvHeight = viewSize -- Double, Double + (iViewWidth, iViewHeight) = (round dvWidth, round dvHeight) + -- Wrap layout directly in a ScrolledWindow . + -- Adjustments: value lower upper stepIncr pageIncr pageSize + ; xAdj <- adjustmentNew 0.0 0.0 dcWidth 10.0 dvWidth dvWidth + ; yAdj <- adjustmentNew 0.0 0.0 dcHeight 10.0 dvHeight dvHeight + ; scrollWin <- scrolledWindowNew (Just xAdj) (Just yAdj) + -- show scrollbars? (never, always, or if needed) + ; scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyAutomatic + -- request view size for _layout_ + ; widgetSetSizeRequest layout iViewWidth iViewHeight + ; set scrollWin [containerChild := layout] + ; return scrollWin + } + + bare :: Gtk.Layout -> IO Gtk.Layout + bare layout = do + { + -- request canvas size for _layout_ + ; widgetSetSizeRequest layout icWidth icHeight -- new + ; return layout + } + + -- The canvas itself + ; vcanvas <- vcanvasNew style dcWidth dcHeight + ; let layout = vcLayout vcanvas + -- Set the actual size of the canvas layout, which may be more + -- than is displayed if scrollbars are used + ; layoutSetSize layout icWidth icHeight + + -- An empty HBox for buttons (or it may remain empty) + ; buttonBar <- hBoxNew False 3 + + -- The Statusbar + ; statusBar <- statusbarNew + + -- All together in a VBox + ; vbox <- vBoxNew False 0 -- not equal space allotments, 0 spacing + + ; addMenuBar vbox + + ; let packGrow :: WidgetClass w => w -> IO () + packGrow w = boxPackStart vbox w PackGrow 0 + ; case mViewSize of + Nothing -> bare layout >>= packGrow + Just viewSize -> scrolled layout viewSize >>= packGrow + + ; boxPackStart vbox buttonBar PackNatural 0 + ; boxPackStart vbox statusBar PackNatural 0 + ; return $ Workspace vbox vcanvas buttonBar statusBar +} + + +vpuiQuit :: VPUI -> IO VPUI +vpuiQuit vpui = do + { + -- *** This should also check for unsaved changes? *** + vpui' <- foldM (\ vp winId -> removeWindow vp True winId) + vpui + (vpuiAllWindowKeys vpui) + ; mainQuit + ; return vpui' + } + +-- | List of all window ids of the vpui, + +vpuiAllWindowKeys :: VPUI -> [WinId] +vpuiAllWindowKeys = keys . vpuiWindows + +-- | Perform action on all windows +-- (actually (WinId, VPUIWindow) pairs. +-- Returns updated VPUI (in case any windows are changed). + +forallWindowsIO :: (VPUIWindow -> IO VPUIWindow) -> VPUI -> IO VPUI +forallWindowsIO action vpui = + let loop ks vpui' = + case ks of + [] -> return vpui' + k : ks' -> + let w = vpuiGetWindow vpui' k + in do + { + w' <- action w + ; loop ks' (vpuiReplaceWindow vpui' k w') + } + in loop (vpuiAllWindowKeys vpui) vpui + + +-- | This function is called either when a window *has been* destroyed, +-- with destroy = False, +-- or when you *want to* destroy a window, with destroy = True. + +-- WOULD BE BETTER to have two functions, windowRemoved and removeWindow??? + +-- | removeWindow actually *closes* the window if destroy = True, +-- as well as removing it from the vpui's windows map. +removeWindow :: VPUI -> Bool -> WinId -> IO VPUI +removeWindow vpui destroy winId = do + { + -- Remove the window from vpui; + -- if destroy is true, also destroy it. + -- It is an error if the window id does not exist. + let vwMap = vpuiWindows vpui + ; when destroy $ widgetDestroy (vpuiWindowWindow (vwMap ! winId)) + ; return $ vpuiRemoveVPUIWindow winId vpui + } + +-- | Context menu command to apply the function definition +-- of an EditFrame. + +-- | "Execute" the definition currently represented in the frame, +-- i.e., bind the function name in the global environment +-- to the function definition found in the frame. + +defineFunction :: WinId -> CanvFrame -> VPUI -> IO VPUI +defineFunction winId frame vpui = + case frameType frame of + CallFrame -> + showErrorMessage "Software error\nNot in an edit frame!" + >> return vpui + EditFrame -> + case cfFunctoid frame of + FunctoidFunc _function -> + return vpui + fparts@FunctoidParts {} -> + let env = vpuiGlobalEnv vpui + vw = vpuiGetWindow vpui winId + canv = vpuiWindowGetCanvas vw + graph = vcGraph canv + frameNode = cfFrameNode frame + in case functoidToFunction fparts graph frameNode env of + Fail errmsg -> + showErrorMessage errmsg >> + return vpui + Succ function -> + let BBox x y _ _ = cfBox frame + z = cfLevel frame + fname = functionName function + env' = envSet env fname (VFun function) + vpui' = vpui {vpuiGlobalEnv = env'} + in do + { + ; canv' <- vcCloseFrame canv frame + -- ** can this use vpuiAddFrame? + ; canv'' <- + vcAddFrame canv' (FunctoidFunc function) [] + EditFrame + env' x y z Nothing + ; let vw' = vpuiWindowSetCanvas vw canv'' + vpui'' = vpuiReplaceWindow vpui' winId vw' + ; vpuiUpdateCallFrames vpui'' fname + } + +-- | In the workspace window, update each frame calling the named function +-- to reflect the current function definition +vpuiUpdateCallFrames :: VPUI -> String -> IO VPUI +vpuiUpdateCallFrames vpui fname = + let winId = "Sifflet Workspace" + in case vpuiTryGetWindow vpui winId of + Nothing -> return vpui + Just w -> do + { + ; let canvas = vpuiWindowGetCanvas w + env = vpuiGlobalEnv vpui + frames = callFrames canvas fname + update canv frame = canvasUpdateCallFrame canv frame fname env + ; canvas' <- foldM update canvas frames + ; let w' = vpuiWindowSetCanvas w canvas' + ; return $ vpuiReplaceWindow vpui winId w' + } + +-- | In the canvas, update a call frame with the current function +-- definition from the environment, returning a new canvas. +-- Root call frames are torn down and rebuilt with the new function definition. +-- Call frames that are called by other call frames are simply torn down. +canvasUpdateCallFrame :: VCanvas -> CanvFrame -> String -> Env -> IO VCanvas +canvasUpdateCallFrame canvas frame fname env = do + { + -- Tear down old frame + canvas' <- vcCloseFrame canvas frame + ; case cfParent frame of + Nothing -> + -- root frame; build up new frame + let Position x y = bbPosition (cfBox frame) + z = cfLevel frame + functoid = FunctoidFunc {fpFunc = envGetFunction env fname} + in vcAddFrame canvas' functoid [] CallFrame env x y z Nothing + Just _ -> + -- frame with a parent; finished + return canvas' + } + +openNode :: VPUIWindow -> G.Node -> IO VPUIWindow +openNode vw node = do + let canvas = vpuiWindowGetCanvas vw + graph = vcGraph canvas + if not (nodeIsSimple graph node) + then return vw -- WFrame node -- is this possible? + else if nodeIsOpen graph node + then info "Already open" >> return vw + else let frame = nodeContainerFrame canvas graph node + in case nodeCompoundFunction graph frame node of + Nothing -> + info "Cannot be opened" >> return vw + Just function -> + case nodeInputValues graph node of + EvalOk (VList values) -> + let env = extendEnv (functionArgNames function) + values (cfEnv frame) + Position x y = + frameOffset (vcStyle canvas) frame + z = succ (cfLevel frame) + in vwAddFrame vw + (FunctoidFunc function) values CallFrame + env x y z (Just node) + EvalOk x -> + error $ "openNode: non-VList result: " ++ show x + _ -> + info "Cannot be opened: lacking input values" >> + return vw diff --git a/sifflet.cabal b/sifflet.cabal new file mode 100644 --- /dev/null +++ b/sifflet.cabal @@ -0,0 +1,56 @@ +name: sifflet +version: 0.1.5 +cabal-version: >= 1.6 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: (C) 2009-2010 Gregory D. Weber +author: Gregory D. Weber +maintainer: "gdweber" ++ drop 3 "abc@" ++ "iue.edu" +bug-reports: mailto:"gdweber" ++ drop 3 "abc@" ++ "iue.edu" +homepage: http://mypage.iu.edu/~gdweber/software/sifflet/ +stability: experimental +synopsis: A simple, visual, functional programming language. +description: Sifflet is a visual, functional programming language. + Sifflet users can make programs by drawing diagrams + to connect functions and other units. + Sifflet show the intermediate steps of the computation + on the diagram, and can expand function calls to show further details. + It is intended as an aid for learning about recursion. +category: + Language + , Visual Programming +tested-with: GHC == 6.10, GHC == 6.12 +-- data-files: filename list +-- data-dir: directory +-- extra-tmp-files: filename list + +extra-source-files: CBMgr.hs Examples.hs Expr.hs Geometry.hs GtkForeign.hs + GtkUtil.hs RPanel.hs SiffML.hs Tree.hs TreeGraph.hs TreeLayout.hs + UITypes.hs Util.hs WindowManagement.hs Workspace.hs + Workspace/Canvas.hs Workspace/Frame.hs + Workspace/Functoid.hs Workspace/Tools.hs Workspace/WGraph.hs + Workspace/Workspace.hs + README + +executable sifflet + main-is: sifflet.hs + build-depends: + base >= 4.0.0.0 && < 5, + cairo >= 0.10, + containers >= 0.2, + fgl >= 5.4, + glib >= 0.10, + gtk >= 0.10, + haskell98, + haskell-src >= 1.0, + hxt >= 8.3 && < 9, + mtl >= 1.1, + process >= 1.0 + if !os(windows) + build-depends: unix >= 2.3 + buildable: True + extensions: ForeignFunctionInterface CPP + ghc-options: -Wall + includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h + extra-libraries: gdk-x11-2.0 gtk-x11-2.0 diff --git a/sifflet.hs b/sifflet.hs new file mode 100644 --- /dev/null +++ b/sifflet.hs @@ -0,0 +1,50 @@ +module Main (main) where + +import Data.IORef + +-- external libraries +import Graphics.UI.Gtk + hiding (Frame, Function, Style, buttonPressed, fill, lineWidth, + disconnect, function) + +-- sifflet modules +import CBMgr +import Examples +import Expr +import GtkUtil +import TreeLayout +import WindowManagement +import Workspace +import UITypes + + +-- --------------------------------------------------------------------- +-- Environment + +initialEnv :: Env +initialEnv = exampleEnv + +main :: IO () +main = do + { + -- scim-bridge causes many errors, so don't use it + suppressScimBridge + + -- Initialize GTK + ; initGUI + + -- create the user interface + ; vpui <- vpuiNew wstyle initialEnv + ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkits} + workId = "Sifflet Workspace" + ; uiref <- newIORef vpui' + -- Create wome windows + ; let cbmgr = mkCBMgr uiref + ; vpui'' <- showWorkWin vpui' workId cbmgr + ; writeIORef uiref vpui'' + + ; showFunctionPadWindow cbmgr vpui'' >>= writeIORef uiref + -- run GTK + ; mainGUI + ; return () +}