Mon Nov 26 16:11:20 WET 2007 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Split big file
Split NetworkUI in NetworkUI and CommonUI.
{
hunk ./Makefile 40
+ src/CommonUI.hs \
hunk ./Makefile 363
+src/CommonUI.o : src/CommonUI.hs
+src/CommonUI.o : src/LambdaC.hi
+src/CommonUI.o : src/SpecialSymbols.hi
+src/CommonUI.o : src/INChecks.hi
+src/CommonUI.o : src/Constants.hi
+src/CommonUI.o : src/InfoKind.hi
+src/CommonUI.o : src/Math.hi
+src/CommonUI.o : src/Ports.hi
+src/CommonUI.o : src/Shape.hi
+src/CommonUI.o : src/Palette.hi
+src/CommonUI.o : src/PDDefaults.hi
+src/CommonUI.o : src/PersistentDocument.hi
+src/CommonUI.o : src/CommonIO.hi
+src/CommonUI.o : src/Common.hi
+src/CommonUI.o : src/INRules.hi
+src/CommonUI.o : src/INRule.hi
+src/CommonUI.o : src/Document.hi
+src/CommonUI.o : src/DocumentFile.hi
+src/CommonUI.o : src/NetworkView.hi
+src/CommonUI.o : src/Network.hi
+src/CommonUI.o : src/StateUtil.hi
+src/CommonUI.o : src/State.hi
+src/CommonUI.o : src/SafetyNet.hi
+src/CommonUI.o : src/GUIEvents.hi
hunk ./Makefile 388
+src/INChecksUI.o : src/CommonUI.hi
hunk ./Makefile 400
-src/NetworkUI.o : src/LambdaC.hi
-src/NetworkUI.o : src/SpecialSymbols.hi
+src/NetworkUI.o : src/CommonUI.hi
hunk ./Makefile 403
-src/NetworkUI.o : src/NetworkControl.hi
hunk ./Makefile 407
-src/NetworkUI.o : src/Math.hi
-src/NetworkUI.o : src/Ports.hi
-src/NetworkUI.o : src/Shape.hi
-src/NetworkUI.o : src/Palette.hi
hunk ./Makefile 411
-src/NetworkUI.o : src/INRules.hi
hunk ./Makefile 413
-src/NetworkUI.o : src/DocumentFile.hi
-src/NetworkUI.o : src/NetworkView.hi
hunk ./Makefile 417
-src/NetworkUI.o : src/GUIEvents.hi
addfile ./src/CommonUI.hs
hunk ./src/CommonUI.hs 1
+{-# OPTIONS -cpp #-}
+module CommonUI where
+
+import GUIEvents
+import SafetyNet
+import State
+import StateUtil
+import Network
+import NetworkView
+import DocumentFile
+import Document
+import INRule
+import INRules
+import Common
+import CommonIO
+import qualified PersistentDocument as PD
+import qualified PDDefaults as PD
+import Palette
+import Shape
+import Ports
+import Math
+import InfoKind
+import Constants
+import Text.XML.HaXml.XmlContent (XmlContent)
+import Text.ParserCombinators.TextParser as Parse
+import INChecks
+import SpecialSymbols
+import LambdaC
+
+import Graphics.UI.WX hiding (Child, upKey, downKey, swap)
+import Graphics.UI.WXCore
+
+import Data.Maybe
+import Data.List
+import qualified Data.Map as Map
+
+
+noImage = -1 :: Int
+
+-- | Prints a document in a none XMl format
+printy :: (InfoKind n g, InfoKind e g, Show g) => Document.Document g n e -> IO ()
+printy doc = [_$_]
+ do let network = getNetwork doc
+ rules = getRules doc
+ mostraNodos network
+ putStrLn "+++++++++++++++++++++++++++++++"
+ mapM_ f rules
+ where mostraNodos network = print $ map Network.getName $ getNodes network
+ f rule = do putStrLn $ INRule.getName rule
+ putStrLn "lhs"
+ mostraNodos $ getLHS rule
+ putStrLn "rhs"
+ mostraNodos $ getRHS rule
+ print $ INRule.getMapping rule
+ putStrLn "-----------------------------------"
+
+paintHandler :: (InfoKind n g, InfoKind e g) => [_$_]
+ State g n e -> DC () -> ActiveCanvas -> IO ()
+paintHandler state dc canvas =
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; dp <- getDisplayOptions state
+ ; let network = selectNetwork doc canvas
+ selection = getSelection doc
+ palette = getPalette doc
+ selection' = selection `filterSelectionTo` canvas
+ ; mapp <- case canvas of
+ Net -> return []
+ LHS rule -> maybe (fail $ rule ++ " not found.") [_$_]
+ (return . map fst . getMapping) [_$_]
+ . findRule rule $ getRules doc [_$_]
+ RHS rule -> maybe (fail $ rule ++ " not found.") [_$_]
+ (return . map snd . getMapping) [_$_]
+ . findRule rule $ getRules doc [_$_]
+
+ ; drawCanvas network palette selection' mapp dc dp
+ }
+ where filterSelectionTo :: Document.Selection -> ActiveCanvas [_$_]
+ -> Document.Selection
+ filterSelectionTo selection canvas =
+ case selection of
+ NodeSelection canv _ _ | canv == canvas -> selection
+ EdgeSelection canv _ | canv == canvas -> selection
+ ViaSelection canv _ _ | canv == canvas -> selection
+ MultipleSelection canv _ _ _ | canv == canvas -> selection
+ _ -> NoSelection [_$_]
+
+
+chooseNetwork :: State g n e -> IO (Network g n e)
+chooseNetwork state = [_$_]
+ do canvas <- getActiveCanvas state
+ pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ case canvas of
+ Net -> return $ getNetwork doc
+ LHS rule -> maybe (fail $ "Invalid rule name: " ++ rule) return [_$_]
+ $ getLHS `fromRule` rule $ getRules doc
+ RHS rule -> maybe (fail $ "Invalid rule name: " ++ rule) return [_$_]
+ $ getRHS `fromRule` rule $ getRules doc
+
+mouseEvent :: (InfoKind n g, InfoKind e g, Show g, Parse g) =>
+ EventMouse -> ScrolledWindow () -> Frame () -> State g n e -> IO ()
+mouseEvent eventMouse canvas theFrame state = case eventMouse of
+ MouseLeftDown mousePoint mods
+ | shiftDown mods -> leftMouseDownWithShift mousePoint state
+ | metaDown mods || controlDown mods -> leftMouseDownWithMeta mousePoint state
+ | otherwise -> mouseDown True mousePoint theFrame state
+ MouseRightDown mousePoint _ ->
+ mouseDown False mousePoint theFrame state
+ MouseLeftDrag mousePoint _ ->
+ leftMouseDrag mousePoint canvas state
+ MouseLeftUp mousePoint _ ->
+ leftMouseUp mousePoint state
+ _ ->
+ return ()
+
+keyboardEvent :: (InfoKind n g, InfoKind e g) =>
+ Frame () -> State g n e -> EventKey -> IO ()
+keyboardEvent theFrame state (EventKey theKey _ _) =
+ case theKey of
+ KeyDelete -> deleteKey state
+ KeyBack -> backspaceKey state
+ KeyF2 -> f2Key theFrame state
+ KeyChar 'r' -> pressRKey theFrame state
+ KeyChar 'i' -> pressIKey theFrame state
+ KeyUp -> upKey state
+ KeyDown -> downKey state
+ _ -> propagateEvent
+
+closeDocAndThen :: State g n e -> IO () -> IO ()
+closeDocAndThen state action =
+ do{ pDoc <- getDocument state
+ ; continue <- PD.isClosingOkay pDoc
+ ; when continue $ action
+ }
+
+setInterfacePalette :: (InfoKind n g) => n -> State g n e -> IO ()
+setInterfacePalette n state =
+ do pDoc <- getDocument state
+
+ let interfacePal = Palette [interfaceSymbol]
+ -- set the initial palette only with interface symbol [_$_]
+ PD.superficialUpdateDocument (setPalette interfacePal) pDoc
+ setCurrentShape (fst interfaceSymbol) state
+
+ buildVisiblePalette state
+
+
+newItem :: (InfoKind n g, InfoKind e g) => State g n e -> g -> n -> e -> IO ()
+newItem state g n e =
+ closeDocAndThen state $
+ do{ pDoc <- getDocument state
+ ; PD.resetDocument Nothing (Document.empty g n e) pDoc
+ ; initializeRules state g n e [_$_]
+ ; reAddRules2Tree state
+ ; setInterfacePalette n state
+ ; repaintAll state
+ }
+
+openItem :: (InfoKind n g, InfoKind e g, XmlContent g) =>
+ Frame () -> State g n e -> IO ()
+openItem theFrame state =
+ do{ mbfname <- fileOpenDialog
+ theFrame
+ False -- change current directory
+ True -- allowReadOnly
+ "Open File"
+ extensions
+ "" "" -- no default directory or filename
+ ; ifJust mbfname $ \fname -> openNetworkFile fname state (Just theFrame)
+ }
+
+-- Third argument: Nothing means exceptions are ignored (used in Configuration)
+-- Just f means exceptions are shown in a dialog on top of frame f
+openNetworkFile :: (InfoKind n g, InfoKind e g, XmlContent g) =>
+ String -> State g n e -> Maybe (Frame ()) -> IO ()
+openNetworkFile fname state exceptionsFrame =
+ closeDocAndThen state $
+ flip catch
+ (\exc -> case exceptionsFrame of
+ Nothing -> return ()
+ Just f -> errorDialog f "Open network"
+ ( "Error while opening '" ++ fname ++ "'. \n\n"
+ ++ "Reason: " ++ show exc)
+ ) $
+ do{ contents <- strictReadFile fname
+ ; let errorOrDocument = DocumentFile.fromString contents
+ ; case errorOrDocument of {
+ Left err -> ioError (userError err);
+ Right (doc, warnings, oldFormat) ->
+ do{ [_$_]
+ ; pDoc <- getDocument state
+ ; PD.resetDocument (if null warnings then Just fname else Nothing)
+ doc pDoc
+ ; applyCanvasSize state
+ ; when (not (null warnings)) $
+ case exceptionsFrame of
+ Nothing -> return ()
+ Just f ->
+ do{ errorDialog f "File read warnings"
+ ( "Warnings while reading file " ++ show fname ++ ":\n\n"
+ ++ unlines ( map ("* " ++) (take 10 warnings)
+ ++ if length warnings > 10 then ["..."] else []
+ )
+ ++ unlines
+ [ ""
+ , "Most likely you are reading a file that is created by a newer version of " ++ toolName ++ ". If you save this file with"
+ , "this version of " ++ toolName ++ " information may be lost. For safety the file name is set to \"untitled\" so that you do"
+ , "not accidentally overwrite the file"
+ ]
+ )
+ ; PD.setFileName pDoc Nothing
+ }
+ ; when oldFormat $
+ do{ case exceptionsFrame of
+ Nothing -> return ()
+ Just f ->
+ errorDialog f "File read warning" $
+ unlines
+ [ "The file you opened has the old " ++ toolName ++ " file format which will become obsolete in newer versions of " ++ toolName ++ "."
+ , "When you save this network, the new file format will be used. To encourage you to do so the network has"
+ , "been marked as \"modified\"."
+ ]
+ ; PD.setDirty pDoc True
+ }
+ ; -- Redraw
+ ; buildVisiblePalette state
+ ; reAddRules2Tree state [_$_]
+ ; repaintAll state
+ }}}
+
+openPalette :: (InfoKind n g, Parse n) => Frame () -> State g n e -> IO ()
+openPalette theFrame state =
+ do{ mbfname <- fileOpenDialog
+ theFrame
+ False -- change current directory
+ True -- allowReadOnly
+ "Open File"
+ paletteExtensions [_$_]
+ "" "" -- no default directory or filename
+ ; ifJust mbfname $ \fname -> openPaletteFile fname state (Just theFrame)
+ }
+
+-- Third argument: Nothing means exceptions are ignored (used in Configuration)
+-- Just f means exceptions are shown in a dialog on top of frame f
+openPaletteFile :: (InfoKind n g, Parse n) =>
+ String -> State g n e -> Maybe (Frame ()) -> IO ()
+openPaletteFile fname state exceptionsFrame =
+ flip catch
+ (\exc -> case exceptionsFrame of
+ Nothing -> return ()
+ Just f -> errorDialog f "Open shape palette"
+ ( "Error while opening '" ++ fname ++ "'. \n\n"
+ ++ "Reason: " ++ show exc)
+ ) $
+ do{ contents <- readFile fname
+ ; case fst (runParser parse contents) of {
+ Left msg -> ioError (userError ("Cannot parse shape palette file: "
+ ++fname++"\n\t"++msg));
+ Right p -> do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let newPalette = removeQuotesFromNames p
+ oldPalette = getPalette doc [_$_]
+ newNames = shapesNames newPalette
+ oldNames = shapesNames oldPalette [_$_]
+ [_$_]
+ ; let cont = newNames `union` oldNames == newNames
+ ; yes <- if cont [_$_]
+ then return True
+ else [_$_]
+ case exceptionsFrame of [_$_]
+ Nothing -> return False
+ Just f -> confirmDialog f [_$_]
+ "Conflict with palettes" [_$_]
+ ("The old palette has names that are not defined in the one that you intend to load.\nThis can make the system inconsistent.\n\nDo you want to load the new palette anyway ?") False
+ ; when (cont || yes) $ [_$_]
+ do PD.updateDocument "change palette"
+ (setPalette newPalette)
+ pDoc
+ -- the shape name of the first palette's element is chosen
+ -- as the default one
+ setCurrentShape (fst . head . shapes $ newPalette) state
+
+ buildVisiblePalette state
+ }
+ }}
+ where remQuot = init . tail
+ removeQuotesFromNames = Palette . map (\(a,b) -> (remQuot a, rem1 b) ) . shapes [_$_]
+ rem1 (shape, mPorts, info) = (shape, rem2 mPorts , info)
+ rem2 = maybe Nothing (Just . map rem3)
+ rem3 (str, dpoint) = (remQuot str, dpoint)
+
+savePalette :: Show n => Frame () -> State g n e -> IO ()
+savePalette theFrame state =
+ do pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ mfname <- PD.defaultSaveAsDialog theFrame paletteExtensions Nothing
+ case mfname of
+ Just fname -> do safeWriteFile theFrame fname . show $ getPalette doc
+ return ()
+ Nothing -> return ()
+
+-- | Get the canvas size from the network and change the size of
+-- the widget accordingly
+applyCanvasSize :: State g n e -> IO ()
+applyCanvasSize state =
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let network = getNetwork doc
+ (width, height) = getCanvasSize network
+ ; canvas <- getCanvas state
+ ; ppi <- getScreenPPI
+ ; set canvas [ virtualSize := sz (logicalToScreenX ppi width)
+ (logicalToScreenY ppi height) ]
+ }
+
+
+saveToDisk :: (InfoKind n g, InfoKind e g, XmlContent g) =>
+ Frame () -> String -> Document.Document g n e -> IO Bool
+saveToDisk theFrame fileName doc =
+ safeWriteFile theFrame fileName (DocumentFile.toString doc)
+
+exit :: State g n e -> IO ()
+exit state =
+ closeDocAndThen state $ propagateEvent
+
+-- Code for build the Visible Palette
+
+buildVisiblePalette :: InfoKind n g => State g n e -> IO ()
+buildVisiblePalette state =
+ do{ pDoc2 <- getDocument state
+ ; pp <- getPalettePanel state
+ ; doc <- PD.getDocument pDoc2
+ ; let palette = getPalette doc
+
+ -- its necessary to delete the old elements in the panel
+ ; windowChildren pp >>= mapM objectDelete
+ [_$_]
+ ; reallyBuildVisiblePalette palette pp state setCurrentShape
+ }
+
+reallyBuildVisiblePalette :: InfoKind n g => [_$_]
+ Palette.Palette n -> Panel () -> State g n e
+ -> (String -> State g n e -> IO ()) -> IO ()
+reallyBuildVisiblePalette palette panel state action =
+ do list <- mapM (drawNodeButton panel state action) . shapes $ palette
+ let table = list2Table 2 list [_$_]
+
+ set panel [layout := [_$_]
+#if !defined(__APPLE__)
+ boxed "Symbol palette" [_$_]
+#endif
+ (grid 4 4 table) ]
+
+
+drawNodeButton :: InfoKind n g => Window w -> State g n e -> (String -> State g n e -> IO ()) [_$_]
+ -> (String, (Shape, Maybe Ports, Maybe n)) -> IO Layout
+drawNodeButton w state action (name, (shape, ports, _info)) = [_$_]
+ do{ frame <- getNetworkFrame state
+ ; node <- button w [ text := name
+ -- , clientSize := sz 50 50 -- due to a wxHaskell problem forcing the size don't works
+ , on command := action name state
+ , bgcolor := white [_$_]
+ , on paint := \dc r -> safetyNet frame $ [_$_]
+ do { logicalDraw ppi dc (center r) shape []
+ ; drawPorts ppi dc (center r) ports []
+ }
+ -- , checked := True
+ ]
+ ; return (widget node)
+ }
+ where factor f (DoublePoint x y) = DoublePoint (x/f) (y/f)
+ ppi = (sz 40 40) -- (rectSize r) this is the correct code if
+ center r = factor 14.0 $ intPointToDoublePoint $ rectCentralPoint r
+
+
+-- | Transforms a list in a table of n columns
+list2Table :: Int -> [a] -> [[a]]
+list2Table n l | null l = []
+ | otherwise = a : list2Table n b [_$_]
+ where (a,b) = splitAt n l
+
+createNewAgentItem :: InfoKind n g => State g n e -> IO ()
+createNewAgentItem state = [_$_]
+ do mRes <- createAgentByNameDialog state
+ case mRes of
+ Just (agentName, agentShape, ports) -> [_$_]
+ do{ pDoc <- getDocument state
+ ; let newElem = (agentName, (agentShape, Just ports, Nothing))
+ ; PD.updateDocument "change palette"
+ (\doc -> setPalette (Palette . (++ [newElem]) . shapes . getPalette $ doc) [_$_]
+ doc)
+ pDoc
+ [_$_]
+ ; setCurrentShape (agentName) state
+
+ ; buildVisiblePalette state
+ }
+ _ -> return ()
+
+-- | List the rules on a one level tree. [_$_]
+addRules2Tree :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
+ TreeCtrl a -> TreeItem -> State g n e -> IO ()
+addRules2Tree tree item state = [_$_]
+ do pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ [_$_]
+ treeCtrlDeleteChildren tree item
+ let rNames = rulesNames $ getRules doc [_$_]
+ mapM_ addItemRule rNames [_$_]
+
+ -- choose the last rule as the active (displayed) one
+ rule <- treeCtrlGetLastChild tree item
+ ruleName <- treeCtrlGetItemText tree rule
+ setActiveRule ruleName state
+ treeCtrlSelectItem tree rule
+ where addItemRule ruleName = [_$_]
+ treeCtrlAppendItem tree item ruleName noImage noImage objectNull [_$_]
+
+-- | Eliminates old rules and add the newer ones.
+reAddRules2Tree :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
+ State g n e -> IO ()
+reAddRules2Tree state =
+ do tree <- getTree state
+ root <- treeCtrlGetRootItem tree
+ addRules2Tree tree root state
+
+onTreeEvent :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
+ TreeCtrl a -> State g n e -> g -> n -> e -> EventTree -> IO ()
+onTreeEvent tree state g n e event = [_$_]
+ case event of [_$_]
+ TreeSelChanged item olditem | treeItemIsOk item
+ -> do wxcBeginBusyCursor
+ ruleName <- treeCtrlGetItemText tree item
+ when (ruleName /= "Rules") $
+ do setActiveRule ruleName state
+ repaintAll state
+ wxcEndBusyCursor
+ propagateEvent
+ TreeBeginLabelEdit item str action [_$_]
+ | str == "Rules" -> action -- prevents the root from be editable
+ TreeEndLabelEdit item new wasCanceled veto | not wasCanceled -> [_$_]
+ do -- change rule name
+ old <- treeCtrlGetItemText tree item
+ [_$_]
+ when (new /= old) $
+ do pDoc <- getDocument state
+ frame <- getNetworkFrame state
+ doc <- PD.getDocument pDoc
+ let rNames = rulesNames $ getRules doc
+ if new `elem` rNames
+ then do veto
+ warningDialog frame "Warning" [_$_]
+ $ "Already exists one rule with name \"" ++ new [_$_]
+ ++ "\".\n Please choose a different identifier."
+ else do PD.updateDocument "change rule name" [_$_]
+ (updateRules [_$_]
+ $ updateRule old [_$_]
+ $ INRule.setName new) pDoc
+ setActiveRule new state
+ propagateEvent
+ TreeItemRightClick item -> [_$_]
+ do ruleName <- treeCtrlGetItemText tree item
+ contextMenu <- menuPane []
+ theFrame <- getNetworkFrame state [_$_]
+
+ if (ruleName == "Rules") -- means right click on root item
+ then [_$_]
+ do menuItem contextMenu [_$_]
+ [ text := "Add new rule"
+ , on command := safetyNet theFrame $ addNewRuleItem True state $ initial g n e
+ ] [_$_]
+ menuItem contextMenu [_$_]
+ [ text := "Create new Interaction Net rule"
+ , on command := safetyNet theFrame $ createRuleItem theFrame state g n e
+ ]
+ else [_$_]
+ do menuItem contextMenu [_$_]
+ [ text := "Rename rule" [_$_]
+ , on command := treeCtrlEditLabel tree item
+ ]
+ menuItem contextMenu [_$_]
+ [ text := "Remove rule"
+ , on command := do safetyNet theFrame [_$_]
+ $ removeRuleItem state ruleName item
+ propagateEvent
+ ]
+
+ propagateEvent
+ pointWithinWindow <- windowGetMousePosition theFrame
+ menuPopup contextMenu pointWithinWindow theFrame
+ objectDelete contextMenu
+ _
+ -> propagateEvent
+
+-- | Adds a new rule setting it with a new name.
+addNewRuleItem :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
+ Bool -> State g n e -> INRule g n e -> IO ()
+addNewRuleItem genNewName state newRule = [_$_]
+ do pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ [_$_]
+ let newName = if genNewName then (addNew 1 . rulesNames $ getRules doc) else (INRule.getName newRule)
+
+ PD.superficialUpdateDocument [_$_]
+ (updateRules $ addNewRule $ (if genNewName then INRule.setName newName else id) $ newRule ) pDoc
+
+ tree <- getTree state
+ root <- treeCtrlGetRootItem tree
+ item <- treeCtrlAppendItem tree root newName noImage noImage objectNull
+ treeCtrlSelectItem tree item
+ where addNew :: Int -> [String] -> String
+ addNew i rules | newName `elem` rules = addNew (i+1) rules
+ | otherwise = newName
+ where newName = "Rule " ++ show i [_$_]
+updateTreeSelection :: State g n e -> IO ()
+updateTreeSelection state =
+ do tree <- getTree state
+ root <- treeCtrlGetRootItem tree
+ selItem <- treeCtrlGetLastChild tree root
+ treeCtrlSelectItem tree selItem
+
+removeRuleItem :: (InfoKind n g, InfoKind e g) => [_$_]
+ State g n e -> String -> TreeItem -> IO ()
+removeRuleItem state ruleName item = [_$_]
+ do frame <- getNetworkFrame state
+ pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+
+ if (1 == ) . length . rulesNames $ getRules doc [_$_]
+ then warningDialog frame "Removal forbidden" [_$_]
+ "You cannot remove the rule because it is the last one."
+ else do tree <- getTree state
+ delete <- confirmDialog frame "Rule deletion" msg yesDefault
+ [_$_]
+ when (delete) $ [_$_]
+ do treeCtrlDelete tree item [_$_]
+ updateTreeSelection state [_$_]
+
+ PD.updateDocument ("remove rule " ++ ruleName) [_$_]
+ (updateRules $ removeRule ruleName) pDoc
+ [_$_]
+ where yesDefault = False
+ msg = "Are you sure you want to delete rule \"" ++ ruleName ++ "\" ?"
+
+-- | If there are none rules it creates a empty one.
+initializeRules :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
+ State g n e -> g -> n -> e -> IO ()
+initializeRules state g n e = [_$_]
+ do pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ let rNames = rulesNames $ getRules doc
+
+ if (null rNames) [_$_]
+ then
+ do -- adds an initial rule
+ PD.superficialUpdateDocument [_$_]
+ (updateRules $ addNewEmptyRule "Rule 1" g n e) pDoc
+ setActiveRule "Rule 1" state
+ else setActiveRule (head rNames) state [_$_]
+
+lhs2rhsItem :: Bool -> State g n e -> IO ()
+lhs2rhsItem everything state = [_$_]
+ do pDoc <- getDocument state
+ rule <- getActiveRule state
+ theFrame <- getNetworkFrame state
+ doc <- PD.getDocument pDoc
+ let rhs = selectNetwork doc $ RHS rule
+ [_$_]
+ copy <- if isEmpty rhs
+ then return True
+ else proceedDialog theFrame "Non empty RHS" $ [_$_]
+ "The RHS side of the rule is not empty.\n" ++ [_$_]
+ "Copying the LHS will make you loosing it.\n" ++
+ "Do you want to proceed ?"
+ when copy $ [_$_]
+ do if everything [_$_]
+ then PD.updateDocument ("copy of LHS to RHS on rule " ++ rule) [_$_]
+ (updateRules $ updateRule rule $ copyLHS2RHS) pDoc
+ else PD.updateDocument ("copy of LHS interface to RHS on rule " ++ rule) [_$_]
+ (updateRules $ updateRule rule $ copyLHSInterface2RHS) pDoc
+ repaintAll state
+ setActiveCanvas (RHS rule) state
+
+data CopyLHS2RHS = Everything | JustInterface | DontCopy | DefaultRule deriving (Show)
+
+-- | Create a dialog where the user have to choose two symbols. [_$_]
+-- An interaction net rule, whose left hand side is the active pair [_$_]
+-- of those two agents, will then be created. [_$_]
+-- A new name is created for this rule.
+createRuleItem :: (InfoKind n g, InfoKind e g) => [_$_]
+ Frame () -> State g n e -> g -> n -> e -> IO ()
+createRuleItem frame state g n e = [_$_]
+ do [_$_]
+ maybeRes <- chooseAgentsDialog state
+ when (isJust maybeRes) $
+ do{ [_$_]
+ ; pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ;let ;(agent1, agent2, copyOption) = fromJust maybeRes
+ ;copy = case copyOption of [_$_]
+ Everything -> copyLHS2RHS [_$_]
+ JustInterface -> copyLHSInterface2RHS [_$_]
+ DontCopy -> id
+ DefaultRule -> defaultRuleSelector (agent1,agent2) state g n e (getPalette doc) [_$_]
+ ; let palette = getPalette doc
+ (nNr1, lhs1) = addNode agent1 palette [_$_]
+ $ Network.empty g n e
+ (nNr2, lhs2) = addNode agent2 palette lhs1
+ [_$_]
+ ; (pP1:ports1) <- getPorts' agent1 palette
+ ; (pP2:ports2) <- getPorts' agent2 palette
+ ;logMessage $ agent1 ++ agent2 ++ (show copyOption)
+
+ -- edge connecting principal ports
+ ; let lhs3 = addEdge nNr1 (Just pP1) nNr2 (Just pP2) lhs2
+ [_$_]
+ (pos1, pos2) = givePositions pP1 pP2 -- (DoublePoint 2.0 2.0, DoublePoint 6.0 3.0) -- ??
+ lhs4 = setNodePosition nNr1 pos1 [_$_]
+ . setNodePosition nNr2 pos2 $ lhs3
+
+ -- adding as many interface nodes as needed
+ (nrs1, lhs5) = addNodes (fst interfaceSymbol) palette (length ports1) lhs4
+ (nrs2, lhs6) = addNodes (fst interfaceSymbol) palette (length ports2) lhs5
+
+ ; interPort <- getInterfacePort palette
+ [_$_]
+ -- choose interface agents better positions; up or down
+ ; let (ups1, downs1) = (map snd >< map snd ) . partition sep $ zip ports1 nrs1
+ (ups2, downs2) = (map snd >< map snd ) . partition sep $ zip ports2 nrs2
+ orderConcat = chooseOrder pos1 pos2
+ [_$_]
+ -- add edges between not principal ports in agents to interface nodes and set their positions [_$_]
+ lhs7 = specialFoldl (DoublePoint 0.5 5.5) (orderConcat downs1 downs2)
+ . specialFoldl (DoublePoint 0.5 0.5) (orderConcat ups1 ups2)
+ . addEdgesWithJustPort -- edges agent2 to interface
+ [((nNr2, p'), (n', interPort)) | p' <- ports2 | n' <- nrs2] [_$_]
+ . addEdgesWithJustPort -- edges agent1 to interface
+ [((nNr1, p'), (n', interPort)) | p' <- ports1 | n' <- nrs1] $ lhs6
+
+ ; let rhs = Network.empty g n e
+ mapping = [] [_$_]
+ ; addNewRuleItem False state . copy $ construct (agent1 ++ "_" ++ agent2) lhs7 rhs mapping
+ }
+ where getPorts' :: String -> Palette.Palette n -> IO Ports
+ getPorts' shape (Palette palette) = [_$_]
+ case Data.List.lookup shape palette of [_$_]
+ Nothing -> fail $ shape ++ " agent is missing." [_$_]
+ Just e -> case snd3 e of [_$_]
+ Nothing -> fail $ shape ++ " agent without port."
+ Just [] -> fail $ shape ++ " agent without port."
+ Just ps -> return ps
+
+ getInterfacePort :: Palette.Palette n -> IO Port
+ getInterfacePort palette = [_$_]
+ do ps <- getPorts' "interface" palette
+ case ps of [_$_]
+ [port] -> return port
+ _ -> fail "Interface agent with more than one port."
+ givePositions :: Port -> Port -> (DoublePoint, DoublePoint)
+ givePositions port1 port2 = g (portZone port1) (portZone port2)
+ where g Ztop Ztop = lineH
+ g Zbottom Zbottom = lineH
+ g Zleft Zleft = lineV
+ g Zright Zright = lineV
+ g Ztop Zbottom = invert lineV
+ g Zbottom Ztop = lineV
+ g Zleft Zright = invert lineH
+ g Zright Zleft = lineH
+ g Ztop Zleft = invert lineI
+ g Ztop Zright = invert lineD
+ g Zbottom Zleft = lineD
+ g Zbottom Zright = lineI
+ g Zleft Ztop = lineI
+ g Zleft Zbottom = invert lineD
+ g Zright Ztop = lineD
+ g Zright Zbottom = invert lineI
+ [_$_]
+ c1 = 2.0
+ c2 = 4.0 [_$_]
+ p1 = DoublePoint c1 c1
+ p2 = DoublePoint c2 c1
+ p3 = DoublePoint c1 c2
+ p4 = DoublePoint c2 c2
+ lineH = (p1, p2)
+ lineV = (p1, p3)
+ lineD = (p1, p4)
+ lineI = (p2, p3)
+ invert = swap
+
+ sep :: (Port, NodeNr) -> Bool
+ sep (port, _) = isUp port
+ chooseOrder pos1 pos2 = if doublePointX pos1 <= doublePointX pos2
+ then (++)
+ else flip (++)
+
+specialFoldl :: DoublePoint -> [NodeNr] -> Network g n e -> Network g n e
+specialFoldl startingPoint nodes net = snd $ foldl gene (startingPoint, net) nodes
+gene :: (DoublePoint, Network g n e) -> NodeNr -> (DoublePoint, Network g n e)
+gene (actual, oldNet) nNr = (translate actual diff, setNodePosition nNr actual oldNet)
+diff = DoublePoint 1.0 0.0
+
+
+
+
+defaultRuleSelector :: (InfoKind n g, InfoKind e g) => (String,String) -> State g n e-> g ->n -> e -> [_$_]
+ Palette.Palette n -> INRule g n e -> INRule g n e
+defaultRuleSelector (a1,a2) state g n e pal rule = case a2 of
+ "copy" -> copyORduplicatorDefaultRule (a1,a2) rule state g n e pal
+ "duplicator" -> copyORduplicatorDefaultRule (a1,a2) rule state g n e pal
+ "Erase" -> eraseDefaultRule a1 rule state g n e pal
+ _ -> rule
+
+------------------------------------------------------------------------------------------------------------------------
+
+eraseDefaultRule :: (InfoKind n g, InfoKind e g) => String ->INRule g n e -> State g n e -> g -> n -> e -> Palette.Palette n -> (INRule g n e)
+eraseDefaultRule a1 rule state g n e palette = [_$_]
+ let ;newRule = copyLHSInterface2RHS $ construct "" lhs (Network.empty g n e) []
+ ;rhs = getRHS newRule [_$_]
+ ;inter = getNodeAssocs rhs
+ ;(erasers, rhs1) = addNodes "Erase" palette (length inter) rhs
+ ;rhs2 = specialFoldl (DoublePoint 1.0 1.0) erasers rhs1
+ ;rhs3 = addEdgesWithPort (mix (map fst inter) erasers) rhs2
+ in (construct ("Erase_"++a1) lhs rhs3 (getMapping newRule))
+[_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_] [_$_]
+ where
+ mix [] [] = []
+ mix (x:y ) (a:b) = [((x,(Just ("interface",DoublePoint 0.0 0.25))),(a,(Just ("down",DoublePoint 0.0 0.5)))) ]++ mix y b
+ mix _ _ = []
+ ;lhs = getLHS rule
+
+
+
+
+
+copyORduplicatorDefaultRule :: (InfoKind n g, InfoKind e g) => (String,String) -> INRule g n e ->
+ State g n e -> g -> n -> e -> Palette.Palette n -> (INRule g n e)
+copyORduplicatorDefaultRule (a1,a2) rule state [_$_]
+ g n e palette = let [_$_]
+ newRule = copyLHSInterface2RHS $ construct "" lhs (Network.empty g n e) []
+ rhs = getRHS newRule
+ inter = getNodeAssocs rhs
+ (alphas, rhs1) = addNodes a1 palette 2 rhs
+ alphasNodes = map (\x -> (x,(getNode x rhs1))) alphas
+ (spas,rhs2) = addNodes a2 palette ((length $ fromMaybe [] $ getPorts (snd $ head alphasNodes))-1) rhs1
+ rhs3 = specialFoldl (DoublePoint 1.0 4.0) spas $ (specialFoldl (DoublePoint 1.0 2.0) alphas rhs2)
+ (copyI,alphaI) = splitAt ((length inter)-2) inter
+ rhs4 = makeInterfaceConection (map fst alphaI) alphas $ makeInterfaceConection (map fst (reverse copyI)) spas rhs3
+ newC = newConections $ makeConnection alphas spas rhs4
+ rhs5 = addEdgesWithJustPort newC rhs4
+ in (construct (a1++"_"++a2) lhs rhs5 (getMapping newRule))
+ where ;lhs = getLHS rule
+-- ;makeInterfaceConection :: [NodeNr] -> [NodeNr] -> Network g n e -> Network g n e
+ ;makeInterfaceConection inter node ne = let pp_i = getInterfaceList inter ne
+ pp_n = getInterfaceList node ne
+ in addEdgesWithJustPort (zip (zip inter pp_i) (zip node pp_n)) ne
+ ;getInterfaceList nodes ne = map head $ filter (/=[]) $ map (fromMaybe []) $ map getPorts $ map (\x -> getNode x ne) nodes
+-- ;makeConnection :: [NodeNr] -> [NodeNr] -> Network g n e ->([((NodeNr,Port),(Int,Int))] , [((NodeNr,Port),(Int,Int))])
+ ;makeConnection alphs sps ne = let
+ ;alp_p = map reverse $ map (drop 1) $ map (\y -> (fromJust $ getPorts $ ( getNode y ne))) alphs
+ ;alp_p_i = map (zip [1..] ) alp_p
+ ;alp_Nr_p = zip [1..] alp_p_i
+ ;alp_fin = zip alphs alp_Nr_p
+ ;sps_p = map (drop 1) $ map (\y -> (fromJust $ getPorts $ ( getNode y ne))) sps
+ ;sps_p_i = map (zip [1..] ) sps_p
+ ;sps_Nr_p = zip [1..] sps_p_i
+ ;sps_fin = zip sps sps_Nr_p
+ in (foldr (++) [] $ map f alp_fin , foldr (++) [] $ map f sps_fin)
+ ;f :: (Int,(Int,([(Int,Port)]))) -> [((NodeNr,Port),(Int,Int))]
+ ;f (_,(_ ,([]))) = [] [_$_]
+ ;f(nodeNr,(node_i,((port_i,port) : l ))) = [((nodeNr,port),(node_i,port_i))] ++ f (nodeNr,(node_i,( l )))
+getOther :: [((NodeNr,Port),(Int,Int))] -> (Int,Int) -> (NodeNr,Port)
+getOther (((nr,p),(ni,pi)) :l) (a,b) | (b == ni) && (a==pi) = (nr,p)
+ | otherwise = getOther l (a,b)
+newConections :: ([((NodeNr,Port),(Int,Int))],[((NodeNr,Port),(Int,Int))]) ->[((NodeNr,Port),(NodeNr,Port))]
+newConections ([],_) = []
+newConections ((((nr,p),(ni,pi)) :l), ll) = [((nr,p), getOther ll (ni,pi) ) ] ++ (newConections (l,ll))
+
+
+chooseAgentsDialog :: InfoKind n g => State g n e [_$_]
+ -> IO ( Maybe (String, String, CopyLHS2RHS))
+chooseAgentsDialog state = [_$_]
+ do theFrame <- getNetworkFrame state
+ pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ [_$_]
+ -- palette without interface symbol
+ let pal = filter ( (/= fst interfaceSymbol).fst )
+ . shapes $ getPalette doc
+
+ if null pal [_$_]
+ then [_$_]
+ do warningDialog theFrame "No symbols" "There are no symbols other than interface ones.\nAdd symbol first."
+ return Nothing
+ else [_$_]
+ do let palette = Palette pal
+ -- no button was pressed
+ setShape1 Nothing state
+ setShape2 Nothing state
+
+ -- create Dialog [_$_]
+ dia <- dialog theFrame [ text := "Rule creation wizard"]
+ p <- panel dia []
+ p1 <- panel p []
+ p2 <- panel p []
+ ;p3 <- panel p2 []
+[_^I_][_^I_][_^I_] [_$_]
+ ok <- button p [ text := "Ok"
+ , enabled := False [_$_]
+ ]
+ setOkButton ok state[_^I_][_^I_][_^I_] [_$_]
+
+ let rinfo = [ ("all nodes", Everything)
+ , ( "just interface nodes", JustInterface)
+ , ("nothing", DontCopy) [_$_]
+ , ("Rule template",DefaultRule)
+ ]
+ (rlabels, rdata) = unzip rinfo
+ r1 <- radioBox p Vertical rlabels [_$_]
+ [ text := "What to copy automatically from LHS to RHS ?"
+ , selection := 1 [_$_]
+
+ ]
+
+ ca <- button p [ text := "Cancel" ]
+
+ ;set r1 [ on select ::= logSelect pal p2 state (onClick r1 setJustShape2)][_^I_][_^I_][_^I_] [_$_]
+
+
+ reallyBuildVisiblePalette palette p1 state $ onClick r1 setJustShape1 [_$_]
+ reallyBuildVisiblePalette palette p2 state $ onClick r1 setJustShape2
+[_^I_][_^I_][_^I_][_$_]
+
+ set dia [ layout := container p $ [_$_]
+ margin 10 $ [_$_]
+ column 5 [ label "Choose one symbol in each palette."
+ , widget p1
+ , hrule 350
+ , widget p2
+ , widget r1
+ , row 5 [widget ok, widget ca]
+ ]
+ ]
+ [_$_]
+
+ showModal dia $ \stop -> [_$_]
+ do set ok [on command := [_$_]
+ do mAgent1 <- getShape1 state
+ mAgent2 <- getShape2 state
+ i <- get r1 selection
+ let res = (fromJust mAgent1, fromJust mAgent2, rdata !! i)
+
+ stop (Just res) ]
+ set ca [on command := stop Nothing ]
+ [_$_]
+ where setJustShape1 = setShape1 . Just [_$_]
+ setJustShape2 = setShape2 . Just
+ onClick r1 func name state = [_$_]
+ do func name state
+ mAgent1 <- getShape1 state
+ mAgent2 <- getShape2 state
+ i <- get r1 selection
+ okButton <- getOkButton state
+ set okButton [ enabled := if (i==3) then (((fromMaybe "" mAgent2) `elem` ["Erase","duplicator","copy"] ) && isJust mAgent1)
+ else (isJust mAgent1 && isJust mAgent2)
+ ]
+ logSelect pal p2 state f w
+ = do ;i <- get w selection
+ ;mAgent2 <- getShape2 state
+ ;mAgent1 <- getShape1 state
+ ;okButton <- getOkButton state
+ ;if (i == 3) [_$_]
+ then do ;set okButton [enabled := (fromMaybe "" mAgent2) `elem` ["Erase","duplicator","copy"] ] [_$_]
+ ;let specialPalette = filter (\x -> (fst x) == "Erase" || (fst x) == "duplicator" || (fst x) == "copy" ) pal
+ ;if (null specialPalette) [_$_]
+ then do ;theFrame <- getNetworkFrame state
+ ;errorDialog theFrame "Not Defined" "No rules defined for any of the symbols in the pallete"
+ ;set w [selection := 1]
+ else do{ ; windowChildren p2 >>= mapM objectDelete [_$_]
+ ; n <- panel p2 []
+ ;reallyBuildVisiblePalette (Palette specialPalette) n state f
+ }[_^I_][_^I_][_^I_][_^I_][_^I_][_$_]
+ else do {;set okButton [enabled := (isJust mAgent1 && isJust mAgent2) ] [_$_]
+ ; windowChildren p2 >>= mapM objectDelete [_$_]
+ ; n <- panel p2 []
+ ;reallyBuildVisiblePalette (Palette pal) n state f
+ }
+
+
+
+
+
+createAgentByNameDialog :: State g n e -> IO (Maybe (String, Shape, [Port]))
+createAgentByNameDialog state =
+ do theFrame <- getNetworkFrame state
+ pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ [_$_]
+ -- palette shape names
+ let paletteNames = map fst . shapes $ getPalette doc
+
+ -- create Dialog [_$_]
+ diaW <- dialog theFrame [ text := "Create new symbol"
+-- , visible := True
+ , resizeable := True
+ , clientSize := sz 200 300
+ ]
+ p <- panel diaW []
+
+ agent <- entry p [text := "Symbol name"]
+ -- set agent [ on keyboard := \k -> do propagateEvent
+ -- agentD <- get agent text
+ -- if agentD `elem` paletteNames [_$_]
+ -- then set agent [bgcolor := red]
+ -- else set agent [bgcolor := green] ]
+ symb <- entry p [text := "Displayed name" ]
+ -- set symb [ on keyboard := \k -> do propagateEvent
+ -- set symb [ bgcolor := green ]
+ -- repaint agentG
+ portsC <- textCtrl p [text := "[ (\"port_name\", DoublePoint 0.3 (-0.3))\n]" ]
+ -- set portsC [ on keyboard := \k -> do propagateEvent
+ -- portsT <- get portsC text
+ -- case (reads :: ReadS [Port] ) portsT of
+ -- [(ports,"")] -> do set portsC [ bgcolor := green]
+ -- repaint agentG [_$_]
+ -- _ -> set portsC [ bgcolor := red]
+
+ let (width, height) = (10,10)
+ ppi <- getScreenPPI
+ agentG <- window p
+ [ virtualSize := sz (logicalToScreenX ppi width)
+ (logicalToScreenY ppi height)
+ , clientSize := sz 300 50
+ , fullRepaintOnResize := False
+ , bgcolor := wxcolor paneBackgroundColor [_$_]
+ , on paint := \dc r -> safetyNet theFrame $ [_$_]
+ do { symbD <- get symb text
+ ; portsT <- get portsC text
+ [_$_]
+ ; case (reads :: ReadS [Port] ) portsT of
+ [(ports,"")] -> [_$_]
+ do let shape = [_$_]
+ TextInEllipse { shapeStyle = defaultShapeStyle
+ , shapeText = symbD}
+ [_$_]
+ drawFig dc r shape (Just ports) [] [_$_]
+ [_$_]
+ _ -> logMessage "bad parsing in ports" -- return ()
+ }
+ ]
+ set agentG [ on mouse := \p -> repaint agentG
+ , on keyboard := \k -> repaint agentG
+ ]
+
+ test <- button p [text := "Test", on command := repaint agentG]
+
+ ok <- button p [ text := "Ok"]
+ ca <- button p [ text := "Cancel" ]
+
+ set diaW [ layout := container p $ [_$_]
+ margin 10 $ fill $ [_$_]
+ column 5 [ [_$_]
+#if !defined(__APPLE__)
+ boxed "New symbol with" $
+#endif [_$_]
+ fill $ grid 5 5 [_$_]
+ [[label "Symbol name", hfill $ widget agent]
+ ,[label "Symbol displayed name", hfill $ widget symb]
+ ,[label "list of ports", hfill $ widget portsC]]
+ , hfill $ widget test
+ , fill $ widget agentG
+ , floatBottomRight $ row 5 [widget ok, widget ca]
+ ]
+ ]
+
+ showModal diaW $ \stop -> [_$_]
+ do set ok [on command := [_$_]
+ do{ agentD <- get agent text
+ ; symbD <- get symb text
+ ; portsT <- get portsC text
+
+ ; if agentD `elem` paletteNames [_$_]
+ then do { errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."
+ -- ; set agent [bgcolor := red]
+ }
+ else [_$_]
+ if agentD `elem` map fst specialSymbols
+ then errorDialog diaW "Reserved agent name" $ "\"" ++ agentD ++ "\" is a reserved agent name for a special agent.\nPlease import the agent or choose a different name."
+ else
+ do let shape = TextInEllipse { shapeStyle = defaultShapeStyle
+ , shapeText = symbD}
+ case (reads :: ReadS [Port] ) portsT of
+ [(ports,"")] -> stop $ Just (agentD, shape, ports)
+ _ -> do { errorDialog diaW "Parse error in list of Ports" "Parse error in list of Ports" [_$_]
+ -- ; set portsC [ bgcolor := red ]
+ } [_$_]
+ }
+ ]
+ set ca [on command := stop Nothing ]
+
+createHelpWindow :: IO () [_$_]
+createHelpWindow =
+ do f <- frame [ text := "Interaction Nets editor help"
+ , position := pt 200 20
+ , clientSize := sz 300 240 ]
+
+ hw <- htmlWindowCreate f 1 (Rect 50 150 500 150) 5 "theWindow"
+ htmlWindowLoadPage hw "html/HowToUse.html"
+ set f [layout := fill $ widget hw]
+
+createAboutWindow :: Frame () -> IO ()
+createAboutWindow f = [_$_]
+ do infoDialog f ("About " ++ toolName) $ [_$_]
+ toolName ++ " is an Interaction Nets Editor.\n"
+ ++ "The project is mainly developed by\n"
+ ++ "Miguel Vilaca < " ++ "jmvilaca@di.uminho.pt" ++" >\n" [_$_]
+ ++ "See the project webpage at\n"
+ ++ "http://haskell.di.uminho.pt/jmvilaca/INblobs"
+
+
+
+[_^I_][_$_]
+lambdaDialog :: (InfoKind n g, InfoKind e g,Show g) => g -> n -> e -> State g n e -> IO (Maybe Int)
+lambdaDialog g n e state = [_$_]
+ do ;theFrame <- getNetworkFrame state
+ ;pDoc <- getDocument state
+ ;doc <- PD.getDocument pDoc
+ ;let pal = getPalette doc
+ ;dial <- dialog theFrame [text := "Lambda term to Net", position := pt 200 20]
+ ;p <- panel dial []
+ ;termbox <- textCtrl p [text := "[x]x"]
+ ;help <- button p [text := "Help"]
+ ;goNet <- button p [text := "Create Net"]
+ ;ok <- button p [text := "Done"]
+ ;can <- button p [text := "Cancel" ]
+ ;sc1 <- checkBox p [text := "Add Token", checked := False]
+ ;set dial [ layout := container p $ [_$_]
+ margin 10 $ [_$_]
+ column 5 [ label "Lambda term input"
+ , row 2 [hfill $ widget termbox, column 10 [widget help ,widget goNet]]
+ , hrule 350
+ , row 5 [widget ok, widget can,widget sc1]
+ ]
+ ]
+ ;showModal dial $ \stop -> [_$_]
+ do set goNet [on command := do {;ex <- get termbox text
+ ;safetyNet theFrame $ do { ;sele <- get sc1 checked[_^I_][_$_]
+ ;s <- drawLambda g n e state pal ex sele
+ ;case s of [_$_]
+ Nothing -> do ;let rep = getlambdaReport ex
+ ;case rep of
+ Nothing -> return ()
+ Just i -> errorDialog dial "Lambda Terms" $ i [_$_]
+ ;return ()
+ Just nt -> do ;PD.updateDocument "Draw Lambda" ( updateNetwork (\a -> nt)) pDoc
+ ;repaintAll state
+ ;return ()
+ }
+ -- ;stop Nothing
+ }
+ ]
+ set help [on command := do infoDialog dial "Help" $ helpString
+ ]
+ set ok [on command := stop (Just 0)]
+ set can [on command := stop (Just 0) ]
+ [_$_]
+ where helpString = "Before starting to create Nets you must load the LambdaC palette in your Palettes folder.\n"
+ ++ "To change the agent palette go to Symbols -> Change shape palettes and choose the LambdaC Palette\n\n"
+ ++ "************* Lambda Term Grammar: ***************\n\n"
+ ++ "Term -> \'[\' ListOfVars \']\' Term \n"
+ ++ " | \'(\' Term \')\' \n"
+ ++ " | Term Term \n"
+ ++ " | Var\n\n"
+ ++ "ListOfVars -> Var\n"
+ ++ " | Var \',\' ListOfVars \n"
+ ++ " \n"
+ ++ "Var -> String \n\n\n************* Some Examples: *************** \n\n\n"
+ ++ "Lambda Notation INblobs Lambda Notation\n\n"
+ ++ " \\x.x [x]x\n"
+ ++ " \\x y.x y [x,y]x y or [x][y]x y \n"
+ ++ " (\\x.x x) (\\x. x x) ([x]x x) ([x]x x)\n"
+ ++ " x x \n"
+ [_$_]
+safeAndClear :: Window a -> TextCtrl b -> IO c -> IO ()
+safeAndClear theFrame textlog comp =
+ safetyNet theFrame $ textCtrlClear textlog >> comp
+
+-- | Add text to a 'TextCtrl' putting it in the given 'Color'.
+addTxtOfColor2TextCtrl :: Color -> TextCtrl () -> String -> IO ()
+addTxtOfColor2TextCtrl color txt str =
+ do
+ start <- textCtrlGetInsertionPoint txt
+ textCtrlAppendText txt str
+ end <- textCtrlGetInsertionPoint txt
+ style <- textAttrCreateDefault
+ textAttrSetTextColour style color
+ textCtrlSetStyle txt start end style
+ return ()
+
+addError2TextCtrl, addGood2TextCtrl :: TextCtrl () -> String -> IO ()
+addError2TextCtrl = addTxtOfColor2TextCtrl red
+addGood2TextCtrl = addTxtOfColor2TextCtrl green
+
+
hunk ./src/INChecksUI.hs 18
+import CommonUI
hunk ./src/INChecksUI.hs 240
--- | Add text to a 'TextCtrl' putting it in the given 'Color'.
-addTxtOfColor2TextCtrl :: Color -> TextCtrl () -> String -> IO ()
-addTxtOfColor2TextCtrl color txt str =
- do
- start <- textCtrlGetInsertionPoint txt
- textCtrlAppendText txt str
- end <- textCtrlGetInsertionPoint txt
- style <- textAttrCreateDefault
- textAttrSetTextColour style color
- textCtrlSetStyle txt start end style
- return ()
-
-addError2TextCtrl, addGood2TextCtrl :: TextCtrl () -> String -> IO ()
-addError2TextCtrl = addTxtOfColor2TextCtrl red
-addGood2TextCtrl = addTxtOfColor2TextCtrl green
-
hunk ./src/NetworkUI.hs 7
-import GUIEvents
hunk ./src/NetworkUI.hs 11
-import NetworkView
-import DocumentFile
hunk ./src/NetworkUI.hs 13
-import INRules
hunk ./src/NetworkUI.hs 17
-import Palette
-import Shape
-import Ports
-import Math
hunk ./src/NetworkUI.hs 23
-import NetworkControl (changeGlobalInfo)
hunk ./src/NetworkUI.hs 25
-import SpecialSymbols
+import CommonUI
hunk ./src/NetworkUI.hs 29
-import Maybe
-import Data.List
-import LambdaC
hunk ./src/NetworkUI.hs 53
-noImage = -1 :: Int
-
hunk ./src/NetworkUI.hs 556
--- | Prints a document in a none XMl format
-printy :: (InfoKind n g, InfoKind e g, Show g) => Document.Document g n e -> IO ()
-printy doc = [_$_]
- do let network = getNetwork doc
- rules = getRules doc
- mostraNodos network
- putStrLn "+++++++++++++++++++++++++++++++"
- mapM_ f rules
- where mostraNodos network = print $ map Network.getName $ getNodes network
- f rule = do putStrLn $ INRule.getName rule
- putStrLn "lhs"
- mostraNodos $ getLHS rule
- putStrLn "rhs"
- mostraNodos $ getRHS rule
- print $ INRule.getMapping rule
- putStrLn "-----------------------------------"
-
-paintHandler :: (InfoKind n g, InfoKind e g) => [_$_]
- State g n e -> DC () -> ActiveCanvas -> IO ()
-paintHandler state dc canvas =
- do{ pDoc <- getDocument state
- ; doc <- PD.getDocument pDoc
- ; dp <- getDisplayOptions state
- ; let network = selectNetwork doc canvas
- selection = getSelection doc
- palette = getPalette doc
- selection' = selection `filterSelectionTo` canvas
- ; mapp <- case canvas of
- Net -> return []
- LHS rule -> maybe (fail $ rule ++ " not found.") [_$_]
- (return . map fst . getMapping) [_$_]
- . findRule rule $ getRules doc [_$_]
- RHS rule -> maybe (fail $ rule ++ " not found.") [_$_]
- (return . map snd . getMapping) [_$_]
- . findRule rule $ getRules doc [_$_]
-
- ; drawCanvas network palette selection' mapp dc dp
- }
- where filterSelectionTo :: Document.Selection -> ActiveCanvas [_$_]
- -> Document.Selection
- filterSelectionTo selection canvas =
- case selection of
- NodeSelection canv _ _ | canv == canvas -> selection
- EdgeSelection canv _ | canv == canvas -> selection
- ViaSelection canv _ _ | canv == canvas -> selection
- MultipleSelection canv _ _ _ | canv == canvas -> selection
- _ -> NoSelection [_$_]
-
-
-chooseNetwork :: State g n e -> IO (Network g n e)
-chooseNetwork state = [_$_]
- do canvas <- getActiveCanvas state
- pDoc <- getDocument state
- doc <- PD.getDocument pDoc
- case canvas of
- Net -> return $ getNetwork doc
- LHS rule -> maybe (fail $ "Invalid rule name: " ++ rule) return [_$_]
- $ getLHS `fromRule` rule $ getRules doc
- RHS rule -> maybe (fail $ "Invalid rule name: " ++ rule) return [_$_]
- $ getRHS `fromRule` rule $ getRules doc
-
-mouseEvent :: (InfoKind n g, InfoKind e g, Show g, Parse g) =>
- EventMouse -> ScrolledWindow () -> Frame () -> State g n e -> IO ()
-mouseEvent eventMouse canvas theFrame state = case eventMouse of
- MouseLeftDown mousePoint mods
- | shiftDown mods -> leftMouseDownWithShift mousePoint state
- | metaDown mods || controlDown mods -> leftMouseDownWithMeta mousePoint state
- | otherwise -> mouseDown True mousePoint theFrame state
- MouseRightDown mousePoint _ ->
- mouseDown False mousePoint theFrame state
- MouseLeftDrag mousePoint _ ->
- leftMouseDrag mousePoint canvas state
- MouseLeftUp mousePoint _ ->
- leftMouseUp mousePoint state
- _ ->
- return ()
-
-keyboardEvent :: (InfoKind n g, InfoKind e g) =>
- Frame () -> State g n e -> EventKey -> IO ()
-keyboardEvent theFrame state (EventKey theKey _ _) =
- case theKey of
- KeyDelete -> deleteKey state
- KeyBack -> backspaceKey state
- KeyF2 -> f2Key theFrame state
- KeyChar 'r' -> pressRKey theFrame state
- KeyChar 'i' -> pressIKey theFrame state
- KeyUp -> upKey state
- KeyDown -> downKey state
- _ -> propagateEvent
-
-closeDocAndThen :: State g n e -> IO () -> IO ()
-closeDocAndThen state action =
- do{ pDoc <- getDocument state
- ; continue <- PD.isClosingOkay pDoc
- ; when continue $ action
- }
-
-setInterfacePalette :: (InfoKind n g) => n -> State g n e -> IO ()
-setInterfacePalette n state =
- do pDoc <- getDocument state
-
- let interfacePal = Palette [interfaceSymbol]
- -- set the initial palette only with interface symbol [_$_]
- PD.superficialUpdateDocument (setPalette interfacePal) pDoc
- setCurrentShape (fst interfaceSymbol) state
-
- buildVisiblePalette state
-
-
-newItem :: (InfoKind n g, InfoKind e g) => State g n e -> g -> n -> e -> IO ()
-newItem state g n e =
- closeDocAndThen state $
- do{ pDoc <- getDocument state
- ; PD.resetDocument Nothing (Document.empty g n e) pDoc
- ; initializeRules state g n e [_$_]
- ; reAddRules2Tree state
- ; setInterfacePalette n state
- ; repaintAll state
- }
-
-openItem :: (InfoKind n g, InfoKind e g, XmlContent g) =>
- Frame () -> State g n e -> IO ()
-openItem theFrame state =
- do{ mbfname <- fileOpenDialog
- theFrame
- False -- change current directory
- True -- allowReadOnly
- "Open File"
- extensions
- "" "" -- no default directory or filename
- ; ifJust mbfname $ \fname -> openNetworkFile fname state (Just theFrame)
- }
-
--- Third argument: Nothing means exceptions are ignored (used in Configuration)
--- Just f means exceptions are shown in a dialog on top of frame f
-openNetworkFile :: (InfoKind n g, InfoKind e g, XmlContent g) =>
- String -> State g n e -> Maybe (Frame ()) -> IO ()
-openNetworkFile fname state exceptionsFrame =
- closeDocAndThen state $
- flip catch
- (\exc -> case exceptionsFrame of
- Nothing -> return ()
- Just f -> errorDialog f "Open network"
- ( "Error while opening '" ++ fname ++ "'. \n\n"
- ++ "Reason: " ++ show exc)
- ) $
- do{ contents <- strictReadFile fname
- ; let errorOrDocument = DocumentFile.fromString contents
- ; case errorOrDocument of {
- Left err -> ioError (userError err);
- Right (doc, warnings, oldFormat) ->
- do{ [_$_]
- ; pDoc <- getDocument state
- ; PD.resetDocument (if null warnings then Just fname else Nothing)
- doc pDoc
- ; applyCanvasSize state
- ; when (not (null warnings)) $
- case exceptionsFrame of
- Nothing -> return ()
- Just f ->
- do{ errorDialog f "File read warnings"
- ( "Warnings while reading file " ++ show fname ++ ":\n\n"
- ++ unlines ( map ("* " ++) (take 10 warnings)
- ++ if length warnings > 10 then ["..."] else []
- )
- ++ unlines
- [ ""
- , "Most likely you are reading a file that is created by a newer version of " ++ toolName ++ ". If you save this file with"
- , "this version of " ++ toolName ++ " information may be lost. For safety the file name is set to \"untitled\" so that you do"
- , "not accidentally overwrite the file"
- ]
- )
- ; PD.setFileName pDoc Nothing
- }
- ; when oldFormat $
- do{ case exceptionsFrame of
- Nothing -> return ()
- Just f ->
- errorDialog f "File read warning" $
- unlines
- [ "The file you opened has the old " ++ toolName ++ " file format which will become obsolete in newer versions of " ++ toolName ++ "."
- , "When you save this network, the new file format will be used. To encourage you to do so the network has"
- , "been marked as \"modified\"."
- ]
- ; PD.setDirty pDoc True
- }
- ; -- Redraw
- ; buildVisiblePalette state
- ; reAddRules2Tree state [_$_]
- ; repaintAll state
- }}}
-
-openPalette :: (InfoKind n g, Parse n) => Frame () -> State g n e -> IO ()
-openPalette theFrame state =
- do{ mbfname <- fileOpenDialog
- theFrame
- False -- change current directory
- True -- allowReadOnly
- "Open File"
- paletteExtensions [_$_]
- "" "" -- no default directory or filename
- ; ifJust mbfname $ \fname -> openPaletteFile fname state (Just theFrame)
- }
-
--- Third argument: Nothing means exceptions are ignored (used in Configuration)
--- Just f means exceptions are shown in a dialog on top of frame f
-openPaletteFile :: (InfoKind n g, Parse n) =>
- String -> State g n e -> Maybe (Frame ()) -> IO ()
-openPaletteFile fname state exceptionsFrame =
- flip catch
- (\exc -> case exceptionsFrame of
- Nothing -> return ()
- Just f -> errorDialog f "Open shape palette"
- ( "Error while opening '" ++ fname ++ "'. \n\n"
- ++ "Reason: " ++ show exc)
- ) $
- do{ contents <- readFile fname
- ; case fst (runParser parse contents) of {
- Left msg -> ioError (userError ("Cannot parse shape palette file: "
- ++fname++"\n\t"++msg));
- Right p -> do{ pDoc <- getDocument state
- ; doc <- PD.getDocument pDoc
- ; let newPalette = removeQuotesFromNames p
- oldPalette = getPalette doc [_$_]
- newNames = shapesNames newPalette
- oldNames = shapesNames oldPalette [_$_]
- [_$_]
- ; let cont = newNames `union` oldNames == newNames
- ; yes <- if cont [_$_]
- then return True
- else [_$_]
- case exceptionsFrame of [_$_]
- Nothing -> return False
- Just f -> confirmDialog f [_$_]
- "Conflict with palettes" [_$_]
- ("The old palette has names that are not defined in the one that you intend to load.\nThis can make the system inconsistent.\n\nDo you want to load the new palette anyway ?") False
- ; when (cont || yes) $ [_$_]
- do PD.updateDocument "change palette"
- (setPalette newPalette)
- pDoc
- -- the shape name of the first palette's element is chosen
- -- as the default one
- setCurrentShape (fst . head . shapes $ newPalette) state
-
- buildVisiblePalette state
- }
- }}
- where remQuot = init . tail
- removeQuotesFromNames = Palette . map (\(a,b) -> (remQuot a, rem1 b) ) . shapes [_$_]
- rem1 (shape, mPorts, info) = (shape, rem2 mPorts , info)
- rem2 = maybe Nothing (Just . map rem3)
- rem3 (str, dpoint) = (remQuot str, dpoint)
-
-savePalette :: Show n => Frame () -> State g n e -> IO ()
-savePalette theFrame state =
- do pDoc <- getDocument state
- doc <- PD.getDocument pDoc
- mfname <- PD.defaultSaveAsDialog theFrame paletteExtensions Nothing
- case mfname of
- Just fname -> do safeWriteFile theFrame fname . show $ getPalette doc
- return ()
- Nothing -> return ()
-
--- | Get the canvas size from the network and change the size of
--- the widget accordingly
-applyCanvasSize :: State g n e -> IO ()
-applyCanvasSize state =
- do{ pDoc <- getDocument state
- ; doc <- PD.getDocument pDoc
- ; let network = getNetwork doc
- (width, height) = getCanvasSize network
- ; canvas <- getCanvas state
- ; ppi <- getScreenPPI
- ; set canvas [ virtualSize := sz (logicalToScreenX ppi width)
- (logicalToScreenY ppi height) ]
- }
-
-
-saveToDisk :: (InfoKind n g, InfoKind e g, XmlContent g) =>
- Frame () -> String -> Document.Document g n e -> IO Bool
-saveToDisk theFrame fileName doc =
- safeWriteFile theFrame fileName (DocumentFile.toString doc)
-
-exit :: State g n e -> IO ()
-exit state =
- closeDocAndThen state $ propagateEvent
-
--- Code for build the Visible Palette
-
-buildVisiblePalette :: InfoKind n g => State g n e -> IO ()
-buildVisiblePalette state =
- do{ pDoc2 <- getDocument state
- ; pp <- getPalettePanel state
- ; doc <- PD.getDocument pDoc2
- ; let palette = getPalette doc
-
- -- its necessary to delete the old elements in the panel
- ; windowChildren pp >>= mapM objectDelete
- [_$_]
- ; reallyBuildVisiblePalette palette pp state setCurrentShape
- }
-
-reallyBuildVisiblePalette :: InfoKind n g => [_$_]
- Palette.Palette n -> Panel () -> State g n e
- -> (String -> State g n e -> IO ()) -> IO ()
-reallyBuildVisiblePalette palette panel state action =
- do list <- mapM (drawNodeButton panel state action) . shapes $ palette
- let table = list2Table 2 list [_$_]
-
- set panel [layout := [_$_]
-#if !defined(__APPLE__)
- boxed "Symbol palette" [_$_]
-#endif
- (grid 4 4 table) ]
-
-
-drawNodeButton :: InfoKind n g => Window w -> State g n e -> (String -> State g n e -> IO ()) [_$_]
- -> (String, (Shape, Maybe Ports, Maybe n)) -> IO Layout
-drawNodeButton w state action (name, (shape, ports, _info)) = [_$_]
- do{ frame <- getNetworkFrame state
- ; node <- button w [ text := name
- -- , clientSize := sz 50 50 -- due to a wxHaskell problem forcing the size don't works
- , on command := action name state
- , bgcolor := white [_$_]
- , on paint := \dc r -> safetyNet frame $ [_$_]
- do { logicalDraw ppi dc (center r) shape []
- ; drawPorts ppi dc (center r) ports []
- }
- -- , checked := True
- ]
- ; return (widget node)
- }
- where factor f (DoublePoint x y) = DoublePoint (x/f) (y/f)
- ppi = (sz 40 40) -- (rectSize r) this is the correct code if
- center r = factor 14.0 $ intPointToDoublePoint $ rectCentralPoint r
-
-
--- | Transforms a list in a table of n columns
-list2Table :: Int -> [a] -> [[a]]
-list2Table n l | null l = []
- | otherwise = a : list2Table n b [_$_]
- where (a,b) = splitAt n l
-
-createNewAgentItem :: InfoKind n g => State g n e -> IO ()
-createNewAgentItem state = [_$_]
- do mRes <- createAgentByNameDialog state
- case mRes of
- Just (agentName, agentShape, ports) -> [_$_]
- do{ pDoc <- getDocument state
- ; let newElem = (agentName, (agentShape, Just ports, Nothing))
- ; PD.updateDocument "change palette"
- (\doc -> setPalette (Palette . (++ [newElem]) . shapes . getPalette $ doc) [_$_]
- doc)
- pDoc
- [_$_]
- ; setCurrentShape (agentName) state
-
- ; buildVisiblePalette state
- }
- _ -> return ()
-
--- | List the rules on a one level tree. [_$_]
-addRules2Tree :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
- TreeCtrl a -> TreeItem -> State g n e -> IO ()
-addRules2Tree tree item state = [_$_]
- do pDoc <- getDocument state
- doc <- PD.getDocument pDoc
- [_$_]
- treeCtrlDeleteChildren tree item
- let rNames = rulesNames $ getRules doc [_$_]
- mapM_ addItemRule rNames [_$_]
-
- -- choose the last rule as the active (displayed) one
- rule <- treeCtrlGetLastChild tree item
- ruleName <- treeCtrlGetItemText tree rule
- setActiveRule ruleName state
- treeCtrlSelectItem tree rule
- where addItemRule ruleName = [_$_]
- treeCtrlAppendItem tree item ruleName noImage noImage objectNull [_$_]
-
--- | Eliminates old rules and add the newer ones.
-reAddRules2Tree :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
- State g n e -> IO ()
-reAddRules2Tree state =
- do tree <- getTree state
- root <- treeCtrlGetRootItem tree
- addRules2Tree tree root state
-
-onTreeEvent :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
- TreeCtrl a -> State g n e -> g -> n -> e -> EventTree -> IO ()
-onTreeEvent tree state g n e event = [_$_]
- case event of [_$_]
- TreeSelChanged item olditem | treeItemIsOk item
- -> do wxcBeginBusyCursor
- ruleName <- treeCtrlGetItemText tree item
- when (ruleName /= "Rules") $
- do setActiveRule ruleName state
- repaintAll state
- wxcEndBusyCursor
- propagateEvent
- TreeBeginLabelEdit item str action [_$_]
- | str == "Rules" -> action -- prevents the root from be editable
- TreeEndLabelEdit item new wasCanceled veto | not wasCanceled -> [_$_]
- do -- change rule name
- old <- treeCtrlGetItemText tree item
- [_$_]
- when (new /= old) $
- do pDoc <- getDocument state
- frame <- getNetworkFrame state
- doc <- PD.getDocument pDoc
- let rNames = rulesNames $ getRules doc
- if new `elem` rNames
- then do veto
- warningDialog frame "Warning" [_$_]
- $ "Already exists one rule with name \"" ++ new [_$_]
- ++ "\".\n Please choose a different identifier."
- else do PD.updateDocument "change rule name" [_$_]
- (updateRules [_$_]
- $ updateRule old [_$_]
- $ INRule.setName new) pDoc
- setActiveRule new state
- propagateEvent
- TreeItemRightClick item -> [_$_]
- do ruleName <- treeCtrlGetItemText tree item
- contextMenu <- menuPane []
- theFrame <- getNetworkFrame state [_$_]
-
- if (ruleName == "Rules") -- means right click on root item
- then [_$_]
- do menuItem contextMenu [_$_]
- [ text := "Add new rule"
- , on command := safetyNet theFrame $ addNewRuleItem True state $ initial g n e
- ] [_$_]
- menuItem contextMenu [_$_]
- [ text := "Create new Interaction Net rule"
- , on command := safetyNet theFrame $ createRuleItem theFrame state g n e
- ]
- else [_$_]
- do menuItem contextMenu [_$_]
- [ text := "Rename rule" [_$_]
- , on command := treeCtrlEditLabel tree item
- ]
- menuItem contextMenu [_$_]
- [ text := "Remove rule"
- , on command := do safetyNet theFrame [_$_]
- $ removeRuleItem state ruleName item
- propagateEvent
- ]
-
- propagateEvent
- pointWithinWindow <- windowGetMousePosition theFrame
- menuPopup contextMenu pointWithinWindow theFrame
- objectDelete contextMenu
- _
- -> propagateEvent
-
--- | Adds a new rule setting it with a new name.
-addNewRuleItem :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
- Bool -> State g n e -> INRule g n e -> IO ()
-addNewRuleItem genNewName state newRule = [_$_]
- do pDoc <- getDocument state
- doc <- PD.getDocument pDoc
- [_$_]
- let newName = if genNewName then (addNew 1 . rulesNames $ getRules doc) else (INRule.getName newRule)
-
- PD.superficialUpdateDocument [_$_]
- (updateRules $ addNewRule $ (if genNewName then INRule.setName newName else id) $ newRule ) pDoc
-
- tree <- getTree state
- root <- treeCtrlGetRootItem tree
- item <- treeCtrlAppendItem tree root newName noImage noImage objectNull
- treeCtrlSelectItem tree item
- where addNew :: Int -> [String] -> String
- addNew i rules | newName `elem` rules = addNew (i+1) rules
- | otherwise = newName
- where newName = "Rule " ++ show i [_$_]
-updateTreeSelection :: State g n e -> IO ()
-updateTreeSelection state =
- do tree <- getTree state
- root <- treeCtrlGetRootItem tree
- selItem <- treeCtrlGetLastChild tree root
- treeCtrlSelectItem tree selItem
-
-removeRuleItem :: (InfoKind n g, InfoKind e g) => [_$_]
- State g n e -> String -> TreeItem -> IO ()
-removeRuleItem state ruleName item = [_$_]
- do frame <- getNetworkFrame state
- pDoc <- getDocument state
- doc <- PD.getDocument pDoc
-
- if (1 == ) . length . rulesNames $ getRules doc [_$_]
- then warningDialog frame "Removal forbidden" [_$_]
- "You cannot remove the rule because it is the last one."
- else do tree <- getTree state
- delete <- confirmDialog frame "Rule deletion" msg yesDefault
- [_$_]
- when (delete) $ [_$_]
- do treeCtrlDelete tree item [_$_]
- updateTreeSelection state [_$_]
-
- PD.updateDocument ("remove rule " ++ ruleName) [_$_]
- (updateRules $ removeRule ruleName) pDoc
- [_$_]
- where yesDefault = False
- msg = "Are you sure you want to delete rule \"" ++ ruleName ++ "\" ?"
-
--- | If there are none rules it creates a empty one.
-initializeRules :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => [_$_]
- State g n e -> g -> n -> e -> IO ()
-initializeRules state g n e = [_$_]
- do pDoc <- getDocument state
- doc <- PD.getDocument pDoc
- let rNames = rulesNames $ getRules doc
-
- if (null rNames) [_$_]
- then
- do -- adds an initial rule
- PD.superficialUpdateDocument [_$_]
- (updateRules $ addNewEmptyRule "Rule 1" g n e) pDoc
- setActiveRule "Rule 1" state
- else setActiveRule (head rNames) state [_$_]
-
-lhs2rhsItem :: Bool -> State g n e -> IO ()
-lhs2rhsItem everything state = [_$_]
- do pDoc <- getDocument state
- rule <- getActiveRule state
- theFrame <- getNetworkFrame state
- doc <- PD.getDocument pDoc
- let rhs = selectNetwork doc $ RHS rule
- [_$_]
- copy <- if isEmpty rhs
- then return True
- else proceedDialog theFrame "Non empty RHS" $ [_$_]
- "The RHS side of the rule is not empty.\n" ++ [_$_]
- "Copying the LHS will make you loosing it.\n" ++
- "Do you want to proceed ?"
- when copy $ [_$_]
- do if everything [_$_]
- then PD.updateDocument ("copy of LHS to RHS on rule " ++ rule) [_$_]
- (updateRules $ updateRule rule $ copyLHS2RHS) pDoc
- else PD.updateDocument ("copy of LHS interface to RHS on rule " ++ rule) [_$_]
- (updateRules $ updateRule rule $ copyLHSInterface2RHS) pDoc
- repaintAll state
- setActiveCanvas (RHS rule) state
-
-data CopyLHS2RHS = Everything | JustInterface | DontCopy | DefaultRule deriving (Show)
-
--- | Create a dialog where the user have to choose two symbols. [_$_]
--- An interaction net rule, whose left hand side is the active pair [_$_]
--- of those two agents, will then be created. [_$_]
--- A new name is created for this rule.
-createRuleItem :: (InfoKind n g, InfoKind e g) => [_$_]
- Frame () -> State g n e -> g -> n -> e -> IO ()
-createRuleItem frame state g n e = [_$_]
- do [_$_]
- maybeRes <- chooseAgentsDialog state
- when (isJust maybeRes) $
- do{ [_$_]
- ; pDoc <- getDocument state
- ; doc <- PD.getDocument pDoc
- ;let ;(agent1, agent2, copyOption) = fromJust maybeRes
- ;copy = case copyOption of [_$_]
- Everything -> copyLHS2RHS [_$_]
- JustInterface -> copyLHSInterface2RHS [_$_]
- DontCopy -> id
- DefaultRule -> defaultRuleSelector (agent1,agent2) state g n e (getPalette doc) [_$_]
- ; let palette = getPalette doc
- (nNr1, lhs1) = addNode agent1 palette [_$_]
- $ Network.empty g n e
- (nNr2, lhs2) = addNode agent2 palette lhs1
- [_$_]
- ; (pP1:ports1) <- getPorts' agent1 palette
- ; (pP2:ports2) <- getPorts' agent2 palette
- ;logMessage $ agent1 ++ agent2 ++ (show copyOption)
-
- -- edge connecting principal ports
- ; let lhs3 = addEdge nNr1 (Just pP1) nNr2 (Just pP2) lhs2
- [_$_]
- (pos1, pos2) = givePositions pP1 pP2 -- (DoublePoint 2.0 2.0, DoublePoint 6.0 3.0) -- ??
- lhs4 = setNodePosition nNr1 pos1 [_$_]
- . setNodePosition nNr2 pos2 $ lhs3
-
- -- adding as many interface nodes as needed
- (nrs1, lhs5) = addNodes (fst interfaceSymbol) palette (length ports1) lhs4
- (nrs2, lhs6) = addNodes (fst interfaceSymbol) palette (length ports2) lhs5
-
- ; interPort <- getInterfacePort palette
- [_$_]
- -- choose interface agents better positions; up or down
- ; let (ups1, downs1) = (map snd >< map snd ) . partition sep $ zip ports1 nrs1
- (ups2, downs2) = (map snd >< map snd ) . partition sep $ zip ports2 nrs2
- orderConcat = chooseOrder pos1 pos2
- [_$_]
- -- add edges between not principal ports in agents to interface nodes and set their positions [_$_]
- lhs7 = specialFoldl (DoublePoint 0.5 5.5) (orderConcat downs1 downs2)
- . specialFoldl (DoublePoint 0.5 0.5) (orderConcat ups1 ups2)
- . addEdgesWithJustPort -- edges agent2 to interface
- [((nNr2, p'), (n', interPort)) | p' <- ports2 | n' <- nrs2] [_$_]
- . addEdgesWithJustPort -- edges agent1 to interface
- [((nNr1, p'), (n', interPort)) | p' <- ports1 | n' <- nrs1] $ lhs6
-
- ; let rhs = Network.empty g n e
- mapping = [] [_$_]
- ; addNewRuleItem False state . copy $ construct (agent1 ++ "_" ++ agent2) lhs7 rhs mapping
- }
- where getPorts' :: String -> Palette.Palette n -> IO Ports
- getPorts' shape (Palette palette) = [_$_]
- case Data.List.lookup shape palette of [_$_]
- Nothing -> fail $ shape ++ " agent is missing." [_$_]
- Just e -> case snd3 e of [_$_]
- Nothing -> fail $ shape ++ " agent without port."
- Just [] -> fail $ shape ++ " agent without port."
- Just ps -> return ps
-
- getInterfacePort :: Palette.Palette n -> IO Port
- getInterfacePort palette = [_$_]
- do ps <- getPorts' "interface" palette
- case ps of [_$_]
- [port] -> return port
- _ -> fail "Interface agent with more than one port."
- givePositions :: Port -> Port -> (DoublePoint, DoublePoint)
- givePositions port1 port2 = g (portZone port1) (portZone port2)
- where g Ztop Ztop = lineH
- g Zbottom Zbottom = lineH
- g Zleft Zleft = lineV
- g Zright Zright = lineV
- g Ztop Zbottom = invert lineV
- g Zbottom Ztop = lineV
- g Zleft Zright = invert lineH
- g Zright Zleft = lineH
- g Ztop Zleft = invert lineI
- g Ztop Zright = invert lineD
- g Zbottom Zleft = lineD
- g Zbottom Zright = lineI
- g Zleft Ztop = lineI
- g Zleft Zbottom = invert lineD
- g Zright Ztop = lineD
- g Zright Zbottom = invert lineI
- [_$_]
- c1 = 2.0
- c2 = 4.0 [_$_]
- p1 = DoublePoint c1 c1
- p2 = DoublePoint c2 c1
- p3 = DoublePoint c1 c2
- p4 = DoublePoint c2 c2
- lineH = (p1, p2)
- lineV = (p1, p3)
- lineD = (p1, p4)
- lineI = (p2, p3)
- invert = swap
-
- sep :: (Port, NodeNr) -> Bool
- sep (port, _) = isUp port
- chooseOrder pos1 pos2 = if doublePointX pos1 <= doublePointX pos2
- then (++)
- else flip (++)
-
-specialFoldl :: DoublePoint -> [NodeNr] -> Network g n e -> Network g n e
-specialFoldl startingPoint nodes net = snd $ foldl gene (startingPoint, net) nodes
-gene :: (DoublePoint, Network g n e) -> NodeNr -> (DoublePoint, Network g n e)
-gene (actual, oldNet) nNr = (translate actual diff, setNodePosition nNr actual oldNet)
-diff = DoublePoint 1.0 0.0
-
-
-
-
-defaultRuleSelector :: (InfoKind n g, InfoKind e g) => (String,String) -> State g n e-> g ->n -> e -> [_$_]
- Palette.Palette n -> INRule g n e -> INRule g n e
-defaultRuleSelector (a1,a2) state g n e pal rule = case a2 of
- "copy" -> copyORduplicatorDefaultRule (a1,a2) rule state g n e pal
- "duplicator" -> copyORduplicatorDefaultRule (a1,a2) rule state g n e pal
- "Erase" -> eraseDefaultRule a1 rule state g n e pal
- _ -> rule
-
-------------------------------------------------------------------------------------------------------------------------
-
-eraseDefaultRule :: (InfoKind n g, InfoKind e g) => String ->INRule g n e -> State g n e -> g -> n -> e -> Palette.Palette n -> (INRule g n e)
-eraseDefaultRule a1 rule state g n e palette = [_$_]
- let ;newRule = copyLHSInterface2RHS $ construct "" lhs (Network.empty g n e) []
- ;rhs = getRHS newRule [_$_]
- ;inter = getNodeAssocs rhs
- ;(erasers, rhs1) = addNodes "Erase" palette (length inter) rhs
- ;rhs2 = specialFoldl (DoublePoint 1.0 1.0) erasers rhs1
- ;rhs3 = addEdgesWithPort (mix (map fst inter) erasers) rhs2
- in (construct ("Erase_"++a1) lhs rhs3 (getMapping newRule))
-[_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_] [_$_]
- where
- mix [] [] = []
- mix (x:y ) (a:b) = [((x,(Just ("interface",DoublePoint 0.0 0.25))),(a,(Just ("down",DoublePoint 0.0 0.5)))) ]++ mix y b
- mix _ _ = []
- ;lhs = getLHS rule
-
-
-
-
-
-copyORduplicatorDefaultRule :: (InfoKind n g, InfoKind e g) => (String,String) -> INRule g n e ->
- State g n e -> g -> n -> e -> Palette.Palette n -> (INRule g n e)
-copyORduplicatorDefaultRule (a1,a2) rule state [_$_]
- g n e palette = let [_$_]
- newRule = copyLHSInterface2RHS $ construct "" lhs (Network.empty g n e) []
- rhs = getRHS newRule
- inter = getNodeAssocs rhs
- (alphas, rhs1) = addNodes a1 palette 2 rhs
- alphasNodes = map (\x -> (x,(getNode x rhs1))) alphas
- (spas,rhs2) = addNodes a2 palette ((length $ fromMaybe [] $ getPorts (snd $ head alphasNodes))-1) rhs1
- rhs3 = specialFoldl (DoublePoint 1.0 4.0) spas $ (specialFoldl (DoublePoint 1.0 2.0) alphas rhs2)
- (copyI,alphaI) = splitAt ((length inter)-2) inter
- rhs4 = makeInterfaceConection (map fst alphaI) alphas $ makeInterfaceConection (map fst (reverse copyI)) spas rhs3
- newC = newConections $ makeConnection alphas spas rhs4
- rhs5 = addEdgesWithJustPort newC rhs4
- in (construct (a1++"_"++a2) lhs rhs5 (getMapping newRule))
- where ;lhs = getLHS rule
--- ;makeInterfaceConection :: [NodeNr] -> [NodeNr] -> Network g n e -> Network g n e
- ;makeInterfaceConection inter node ne = let pp_i = getInterfaceList inter ne
- pp_n = getInterfaceList node ne
- in addEdgesWithJustPort (zip (zip inter pp_i) (zip node pp_n)) ne
- ;getInterfaceList nodes ne = map head $ filter (/=[]) $ map (fromMaybe []) $ map getPorts $ map (\x -> getNode x ne) nodes
--- ;makeConnection :: [NodeNr] -> [NodeNr] -> Network g n e ->([((NodeNr,Port),(Int,Int))] , [((NodeNr,Port),(Int,Int))])
- ;makeConnection alphs sps ne = let
- ;alp_p = map reverse $ map (drop 1) $ map (\y -> (fromJust $ getPorts $ ( getNode y ne))) alphs
- ;alp_p_i = map (zip [1..] ) alp_p
- ;alp_Nr_p = zip [1..] alp_p_i
- ;alp_fin = zip alphs alp_Nr_p
- ;sps_p = map (drop 1) $ map (\y -> (fromJust $ getPorts $ ( getNode y ne))) sps
- ;sps_p_i = map (zip [1..] ) sps_p
- ;sps_Nr_p = zip [1..] sps_p_i
- ;sps_fin = zip sps sps_Nr_p
- in (foldr (++) [] $ map f alp_fin , foldr (++) [] $ map f sps_fin)
- ;f :: (Int,(Int,([(Int,Port)]))) -> [((NodeNr,Port),(Int,Int))]
- ;f (_,(_ ,([]))) = [] [_$_]
- ;f(nodeNr,(node_i,((port_i,port) : l ))) = [((nodeNr,port),(node_i,port_i))] ++ f (nodeNr,(node_i,( l )))
-getOther :: [((NodeNr,Port),(Int,Int))] -> (Int,Int) -> (NodeNr,Port)
-getOther (((nr,p),(ni,pi)) :l) (a,b) | (b == ni) && (a==pi) = (nr,p)
- | otherwise = getOther l (a,b)
-newConections :: ([((NodeNr,Port),(Int,Int))],[((NodeNr,Port),(Int,Int))]) ->[((NodeNr,Port),(NodeNr,Port))]
-newConections ([],_) = []
-newConections ((((nr,p),(ni,pi)) :l), ll) = [((nr,p), getOther ll (ni,pi) ) ] ++ (newConections (l,ll))
-
-
-chooseAgentsDialog :: InfoKind n g => State g n e [_$_]
- -> IO ( Maybe (String, String, CopyLHS2RHS))
-chooseAgentsDialog state = [_$_]
- do theFrame <- getNetworkFrame state
- pDoc <- getDocument state
- doc <- PD.getDocument pDoc
- [_$_]
- -- palette without interface symbol
- let pal = filter ( (/= fst interfaceSymbol).fst )
- . shapes $ getPalette doc
-
- if null pal [_$_]
- then [_$_]
- do warningDialog theFrame "No symbols" "There are no symbols other than interface ones.\nAdd symbol first."
- return Nothing
- else [_$_]
- do let palette = Palette pal
- -- no button was pressed
- setShape1 Nothing state
- setShape2 Nothing state
-
- -- create Dialog [_$_]
- dia <- dialog theFrame [ text := "Rule creation wizard"]
- p <- panel dia []
- p1 <- panel p []
- p2 <- panel p []
- ;p3 <- panel p2 []
-[_^I_][_^I_][_^I_] [_$_]
- ok <- button p [ text := "Ok"
- , enabled := False [_$_]
- ]
- setOkButton ok state[_^I_][_^I_][_^I_] [_$_]
-
- let rinfo = [ ("all nodes", Everything)
- , ( "just interface nodes", JustInterface)
- , ("nothing", DontCopy) [_$_]
- , ("Rule template",DefaultRule)
- ]
- (rlabels, rdata) = unzip rinfo
- r1 <- radioBox p Vertical rlabels [_$_]
- [ text := "What to copy automatically from LHS to RHS ?"
- , selection := 1 [_$_]
-
- ]
-
- ca <- button p [ text := "Cancel" ]
-
- ;set r1 [ on select ::= logSelect pal p2 state (onClick r1 setJustShape2)][_^I_][_^I_][_^I_] [_$_]
-
-
- reallyBuildVisiblePalette palette p1 state $ onClick r1 setJustShape1 [_$_]
- reallyBuildVisiblePalette palette p2 state $ onClick r1 setJustShape2
-[_^I_][_^I_][_^I_][_$_]
-
- set dia [ layout := container p $ [_$_]
- margin 10 $ [_$_]
- column 5 [ label "Choose one symbol in each palette."
- , widget p1
- , hrule 350
- , widget p2
- , widget r1
- , row 5 [widget ok, widget ca]
- ]
- ]
- [_$_]
-
- showModal dia $ \stop -> [_$_]
- do set ok [on command := [_$_]
- do mAgent1 <- getShape1 state
- mAgent2 <- getShape2 state
- i <- get r1 selection
- let res = (fromJust mAgent1, fromJust mAgent2, rdata !! i)
-
- stop (Just res) ]
- set ca [on command := stop Nothing ]
- [_$_]
- where setJustShape1 = setShape1 . Just [_$_]
- setJustShape2 = setShape2 . Just
- onClick r1 func name state = [_$_]
- do func name state
- mAgent1 <- getShape1 state
- mAgent2 <- getShape2 state
- i <- get r1 selection
- okButton <- getOkButton state
- set okButton [ enabled := if (i==3) then (((fromMaybe "" mAgent2) `elem` ["Erase","duplicator","copy"] ) && isJust mAgent1)
- else (isJust mAgent1 && isJust mAgent2)
- ]
- logSelect pal p2 state f w
- = do ;i <- get w selection
- ;mAgent2 <- getShape2 state
- ;mAgent1 <- getShape1 state
- ;okButton <- getOkButton state
- ;if (i == 3) [_$_]
- then do ;set okButton [enabled := (fromMaybe "" mAgent2) `elem` ["Erase","duplicator","copy"] ] [_$_]
- ;let specialPalette = filter (\x -> (fst x) == "Erase" || (fst x) == "duplicator" || (fst x) == "copy" ) pal
- ;if (null specialPalette) [_$_]
- then do ;theFrame <- getNetworkFrame state
- ;errorDialog theFrame "Not Defined" "No rules defined for any of the symbols in the pallete"
- ;set w [selection := 1]
- else do{ ; windowChildren p2 >>= mapM objectDelete [_$_]
- ; n <- panel p2 []
- ;reallyBuildVisiblePalette (Palette specialPalette) n state f
- }[_^I_][_^I_][_^I_][_^I_][_^I_][_$_]
- else do {;set okButton [enabled := (isJust mAgent1 && isJust mAgent2) ] [_$_]
- ; windowChildren p2 >>= mapM objectDelete [_$_]
- ; n <- panel p2 []
- ;reallyBuildVisiblePalette (Palette pal) n state f
- }
-
-
-
-
-
-createAgentByNameDialog :: State g n e -> IO (Maybe (String, Shape, [Port]))
-createAgentByNameDialog state =
- do theFrame <- getNetworkFrame state
- pDoc <- getDocument state
- doc <- PD.getDocument pDoc
- [_$_]
- -- palette shape names
- let paletteNames = map fst . shapes $ getPalette doc
-
- -- create Dialog [_$_]
- diaW <- dialog theFrame [ text := "Create new symbol"
--- , visible := True
- , resizeable := True
- , clientSize := sz 200 300
- ]
- p <- panel diaW []
-
- agent <- entry p [text := "Symbol name"]
- -- set agent [ on keyboard := \k -> do propagateEvent
- -- agentD <- get agent text
- -- if agentD `elem` paletteNames [_$_]
- -- then set agent [bgcolor := red]
- -- else set agent [bgcolor := green] ]
- symb <- entry p [text := "Displayed name" ]
- -- set symb [ on keyboard := \k -> do propagateEvent
- -- set symb [ bgcolor := green ]
- -- repaint agentG
- portsC <- textCtrl p [text := "[ (\"port_name\", DoublePoint 0.3 (-0.3))\n]" ]
- -- set portsC [ on keyboard := \k -> do propagateEvent
- -- portsT <- get portsC text
- -- case (reads :: ReadS [Port] ) portsT of
- -- [(ports,"")] -> do set portsC [ bgcolor := green]
- -- repaint agentG [_$_]
- -- _ -> set portsC [ bgcolor := red]
-
- let (width, height) = (10,10)
- ppi <- getScreenPPI
- agentG <- window p
- [ virtualSize := sz (logicalToScreenX ppi width)
- (logicalToScreenY ppi height)
- , clientSize := sz 300 50
- , fullRepaintOnResize := False
- , bgcolor := wxcolor paneBackgroundColor [_$_]
- , on paint := \dc r -> safetyNet theFrame $ [_$_]
- do { symbD <- get symb text
- ; portsT <- get portsC text
- [_$_]
- ; case (reads :: ReadS [Port] ) portsT of
- [(ports,"")] -> [_$_]
- do let shape = [_$_]
- TextInEllipse { shapeStyle = defaultShapeStyle
- , shapeText = symbD}
- [_$_]
- drawFig dc r shape (Just ports) [] [_$_]
- [_$_]
- _ -> logMessage "bad parsing in ports" -- return ()
- }
- ]
- set agentG [ on mouse := \p -> repaint agentG
- , on keyboard := \k -> repaint agentG
- ]
-
- test <- button p [text := "Test", on command := repaint agentG]
-
- ok <- button p [ text := "Ok"]
- ca <- button p [ text := "Cancel" ]
-
- set diaW [ layout := container p $ [_$_]
- margin 10 $ fill $ [_$_]
- column 5 [ [_$_]
-#if !defined(__APPLE__)
- boxed "New symbol with" $
-#endif [_$_]
- fill $ grid 5 5 [_$_]
- [[label "Symbol name", hfill $ widget agent]
- ,[label "Symbol displayed name", hfill $ widget symb]
- ,[label "list of ports", hfill $ widget portsC]]
- , hfill $ widget test
- , fill $ widget agentG
- , floatBottomRight $ row 5 [widget ok, widget ca]
- ]
- ]
-
- showModal diaW $ \stop -> [_$_]
- do set ok [on command := [_$_]
- do{ agentD <- get agent text
- ; symbD <- get symb text
- ; portsT <- get portsC text
-
- ; if agentD `elem` paletteNames [_$_]
- then do { errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."
- -- ; set agent [bgcolor := red]
- }
- else [_$_]
- if agentD `elem` map fst specialSymbols
- then errorDialog diaW "Reserved agent name" $ "\"" ++ agentD ++ "\" is a reserved agent name for a special agent.\nPlease import the agent or choose a different name."
- else
- do let shape = TextInEllipse { shapeStyle = defaultShapeStyle
- , shapeText = symbD}
- case (reads :: ReadS [Port] ) portsT of
- [(ports,"")] -> stop $ Just (agentD, shape, ports)
- _ -> do { errorDialog diaW "Parse error in list of Ports" "Parse error in list of Ports" [_$_]
- -- ; set portsC [ bgcolor := red ]
- } [_$_]
- }
- ]
- set ca [on command := stop Nothing ]
-
-createHelpWindow :: IO () [_$_]
-createHelpWindow =
- do f <- frame [ text := "Interaction Nets editor help"
- , position := pt 200 20
- , clientSize := sz 300 240 ]
-
- hw <- htmlWindowCreate f 1 (Rect 50 150 500 150) 5 "theWindow"
- htmlWindowLoadPage hw "html/HowToUse.html"
- set f [layout := fill $ widget hw]
-
-createAboutWindow :: Frame () -> IO ()
-createAboutWindow f = [_$_]
- do infoDialog f ("About " ++ toolName) $ [_$_]
- toolName ++ " is an Interaction Nets Editor.\n"
- ++ "The project is mainly developed by\n"
- ++ "Miguel Vilaca < " ++ "jmvilaca@di.uminho.pt" ++" >\n" [_$_]
- ++ "See the project webpage at\n"
- ++ "http://haskell.di.uminho.pt/jmvilaca/INblobs"
-
-
-
-[_^I_][_$_]
-lambdaDialog :: (InfoKind n g, InfoKind e g,Show g) => g -> n -> e -> State g n e -> IO (Maybe Int)
-lambdaDialog g n e state = [_$_]
- do ;theFrame <- getNetworkFrame state
- ;pDoc <- getDocument state
- ;doc <- PD.getDocument pDoc
- ;let pal = getPalette doc
- ;dial <- dialog theFrame [text := "Lambda term to Net", position := pt 200 20]
- ;p <- panel dial []
- ;termbox <- textCtrl p [text := "[x]x"]
- ;help <- button p [text := "Help"]
- ;goNet <- button p [text := "Create Net"]
- ;ok <- button p [text := "Done"]
- ;can <- button p [text := "Cancel" ]
- ;sc1 <- checkBox p [text := "Add Token", checked := False]
- ;set dial [ layout := container p $ [_$_]
- margin 10 $ [_$_]
- column 5 [ label "Lambda term input"
- , row 2 [hfill $ widget termbox, column 10 [widget help ,widget goNet]]
- , hrule 350
- , row 5 [widget ok, widget can,widget sc1]
- ]
- ]
- ;showModal dial $ \stop -> [_$_]
- do set goNet [on command := do {;ex <- get termbox text
- ;safetyNet theFrame $ do { ;sele <- get sc1 checked[_^I_][_$_]
- ;s <- drawLambda g n e state pal ex sele
- ;case s of [_$_]
- Nothing -> do ;let rep = getlambdaReport ex
- ;case rep of
- Nothing -> return ()
- Just i -> errorDialog dial "Lambda Terms" $ i [_$_]
- ;return ()
- Just nt -> do ;PD.updateDocument "Draw Lambda" ( updateNetwork (\a -> nt)) pDoc
- ;repaintAll state
- ;return ()
- }
- -- ;stop Nothing
- }
- ]
- set help [on command := do infoDialog dial "Help" $ helpString
- ]
- set ok [on command := stop (Just 0)]
- set can [on command := stop (Just 0) ]
- [_$_]
- where helpString = "Before starting to create Nets you must load the LambdaC palette in your Palettes folder.\n"
- ++ "To change the agent palette go to Symbols -> Change shape palettes and choose the LambdaC Palette\n\n"
- ++ "************* Lambda Term Grammar: ***************\n\n"
- ++ "Term -> \'[\' ListOfVars \']\' Term \n"
- ++ " | \'(\' Term \')\' \n"
- ++ " | Term Term \n"
- ++ " | Var\n\n"
- ++ "ListOfVars -> Var\n"
- ++ " | Var \',\' ListOfVars \n"
- ++ " \n"
- ++ "Var -> String \n\n\n************* Some Examples: *************** \n\n\n"
- ++ "Lambda Notation INblobs Lambda Notation\n\n"
- ++ " \\x.x [x]x\n"
- ++ " \\x y.x y [x,y]x y or [x][y]x y \n"
- ++ " (\\x.x x) (\\x. x x) ([x]x x) ([x]x x)\n"
- ++ " x x \n"
- [_$_]
-safeAndClear :: Window a -> TextCtrl b -> IO c -> IO ()
-safeAndClear theFrame textlog comp =
- safetyNet theFrame $ textCtrlClear textlog >> comp
-
}