1 {-# OPTIONS -cpp -fglasgow-exts #-}
15 import qualified PersistentDocument as PD
16 import qualified PDDefaults as PD
20 import Text.XML.HaXml.XmlContent (XmlContent)
21 import Text.Parse as Parse
27 import Graphics.UI.WX hiding (Child, upKey, downKey, swap)
28 import Graphics.UI.WXCore
32 { nfcWinDimensions :: (Int, Int, Int, Int) -- x, y, width, height
33 , nfcFileName :: Maybe String
34 , nfcSelection :: Document.Selection
38 getConfig :: State g n e -> IO Config
40 do{ theFrame <- getNetworkFrame state
41 ; (x, y) <- safeGetPosition theFrame
42 ; winSize <- get theFrame clientSize
43 ; pDoc <- getDocument state
44 ; maybeFileName <- PD.getFileName pDoc
45 ; doc <- PD.getDocument pDoc
47 { nfcWinDimensions = (x, y, sizeW winSize, sizeH winSize)
48 , nfcFileName = maybeFileName
49 , nfcSelection = getSelection doc
54 create :: (InfoKind n g, InfoKind e g, XmlContent g, Parse g, Show g) =>
55 State g n e -> g -> n -> e -> GraphOps g n e -> IO ()
56 create state g n e ops =
58 {- Containment structure of widgets:
60 * theFrame :: Frame ()
61 ** mainPan :: Panel ()
62 *** sp :: SplitterWindow ()
63 **** sp1 :: SplitterWindow ()
64 ***** sp2 :: SplitterWindow ()
65 ****** palettePan :: Panel ()
66 ******* palPan :: Panel ()
67 ******* addAgent :: Button ()
68 ****** rulesTreePan :: Panel ()
69 ******* tree :: TreeCtrl ()
70 ******* buttonNewRule :: Button ()
71 ******* buttonNewIRule :: Button ()
72 ***** sp3 :: SplitterWindow ()
73 ****** sp4 :: SplitterWindow ()
74 ******* ruleLHSPan :: Panel ()
76 ******* ruleRHSPan :: Panel ()
77 ****** lhs2rhsB :: Button ()
79 ****** netPan :: Panel ()
81 ******* strategies :: RadioBox ()
82 ******* steps :: RadioBox ()
83 ******* reduceB :: Button ()
84 ******* reduceStopB :: Button ()
85 **** textlog :: TextCtrl ()
88 do{ theFrame <- frame [ text := "Interaction Nets editor"
89 , position := pt 200 20
90 , clientSize := sz 300 240 ]
91 ; setNetworkFrame theFrame state
93 -- Panels and SplitterWindows
94 ; mainPan <- panel theFrame []
95 ; sp <- splitterWindow mainPan []
96 ; sp1 <- splitterWindow sp []
97 ; sp2 <- splitterWindow sp1 []
98 ; sp3 <- splitterWindow sp1 []
100 -- create a panel and put the Visible Palette with buttons on it
101 ; palettePan <- panel sp2 []
102 ; palPan <- panel palettePan []
103 ; setPalettePanel palPan state
105 ; rulesTreePan <- panel sp2 []
106 ; sp4 <- splitterWindow sp3 []
107 #if !defined(__APPLE__)
108 ; ruleLHSPan <- panel sp4 []
110 ; ruleRHSPan <- panel sp4 []
112 ; netPan <- panel sp3 []
113 -- Create page setup dialog and save in state
114 ; pageSetupData <- pageSetupDialogDataCreate
115 ; initialPageSetupDialog <- pageSetupDialogCreate theFrame pageSetupData
116 ; objectDelete pageSetupData
117 ; setPageSetupDialog initialPageSetupDialog state
119 -- Drawing area for net
120 ; let (width, height) = getCanvasSize (Network.empty g n e)
121 ; ppi <- getScreenPPI
122 ; canvas <- scrolledWindow netPan
123 [ virtualSize := sz (logicalToScreenX ppi width)
124 (logicalToScreenY ppi height)
125 , scrollRate := sz 10 10
126 , bgcolor := wxcolor paneBackgroundColor
127 , fullRepaintOnResize := False
129 ; State.setCanvas canvas state
131 -- Dummy persistent document to pass around
132 ; pDoc <- getDocument state
134 -- Attach handlers to drawing area
136 [ on paint := \dc _ -> safetyNet theFrame $ paintHandler state dc Net
137 , on mouse := \p -> safetyNet theFrame $
138 do setActiveCanvas Net state
139 mouseEvent p canvas theFrame state
141 , on keyboard := \k -> safetyNet theFrame $
142 do setActiveCanvas Net state
143 keyboardEvent theFrame state k
147 -- Drawing area for LHS
148 ; let (width, height) = (100, 100) -- getCanvasSize (Network.empty g n e)
149 ; ppi <- getScreenPPI
150 #if !defined(__APPLE__)
151 ; canvasLHS <- scrolledWindow ruleLHSPan
153 ; canvasLHS <- scrolledWindow sp4
155 [ virtualSize := sz (logicalToScreenX ppi width)
156 (logicalToScreenY ppi height)
157 , scrollRate := sz 10 10
158 , bgcolor := wxcolor paneBackgroundColor
159 , fullRepaintOnResize := False
161 ; State.setLHSCanvas canvasLHS state
163 -- Attach handlers to drawing area
165 [ on paint := \dc _ -> safetyNet theFrame
166 $ do rule <- getActiveRule state
167 paintHandler state dc $ LHS rule
168 , on mouse := \p -> safetyNet theFrame $
169 do setActiveCanvas (LHS "") state
170 mouseEvent p canvasLHS theFrame state
171 --; focusOn canvasLHS
172 , on keyboard := \k -> safetyNet theFrame $
173 do setActiveCanvas (LHS "") state
174 keyboardEvent theFrame state k
175 --; focusOn canvasLHS
178 -- buttons to copy LHS to RHS
179 ; lhs2rhsB <- button ruleRHSPan [ text := "==>"
180 , tooltip := "Copy the LHS network to the RHS."
181 , on command := safetyNet theFrame
182 $ lhs2rhsItem True state
184 -- only copies the interface
185 ; lhsInt2rhsB <- button ruleRHSPan [ text := "=->"
186 , tooltip := "Copy the LHS interface to the RHS."
187 , on command := safetyNet theFrame
188 $ lhs2rhsItem False state
191 -- Drawing area for RHS
192 ; let (width, height) = (100, 100) -- getCanvasSize (Network.empty g n e)
193 ; ppi <- getScreenPPI
194 ; canvasRHS <- scrolledWindow ruleRHSPan
195 [ virtualSize := sz (logicalToScreenX ppi width)
196 (logicalToScreenY ppi height)
197 , scrollRate := sz 10 10
198 , bgcolor := wxcolor paneBackgroundColor
199 , fullRepaintOnResize := False
201 ; State.setRHSCanvas canvasRHS state
203 -- Attach handlers to drawing area
205 [ on paint := \dc _ -> safetyNet theFrame
206 $ do rule <- getActiveRule state
207 paintHandler state dc $ RHS rule
208 , on mouse := \p -> safetyNet theFrame $
209 do setActiveCanvas (RHS "") state
210 mouseEvent p canvasRHS theFrame state
211 --; focusOn canvasLHS
212 , on keyboard := \k -> safetyNet theFrame $
213 do setActiveCanvas (RHS "") state
214 keyboardEvent theFrame state k
215 --; focusOn canvasLHS
219 ; textlog <- textCtrlRich sp [enabled := False, wrap := WrapNone]
220 -- use text control as logger
221 ; textCtrlMakeLogActiveTarget textlog
224 ; fileMenu <- menuPane [ text := "&File" ]
226 [ text := "New\tCtrl+N"
227 , on command := safetyNet theFrame $ newItem state g n e
230 [ text := "Open...\tCtrl+O"
231 , on command := safetyNet theFrame $ openItem theFrame state
232 >> singleCheckOverIN iNCheck state
234 ; saveItem <- menuItem fileMenu
235 [ text := "Save\tCtrl+S"
236 , on command := safetyNet theFrame $ checkValidINOnSave state $ PD.save pDoc
239 [ text := "Save as..."
240 , on command := safetyNet theFrame $ checkValidINOnSave state $ PD.saveAs pDoc
246 [ text := "Page setup..."
247 , on command := safetyNet theFrame $
248 do{ psd <- getPageSetupDialog state
249 ; dialogShowModal psd
256 , on command := safetyNet theFrame $
257 let printFun _ printInfo _ dc _ =
258 do { dcSetUserScale dc
259 (fromIntegral (sizeW (printerPPI printInfo))
260 / fromIntegral (sizeW (screenPPI printInfo)))
261 (fromIntegral (sizeH (printerPPI printInfo))
262 / fromIntegral (sizeH (screenPPI printInfo)))
263 ; paintHandler state dc Net
265 pageFun _ _ _ = (1, 1)
267 do{ psd <- getPageSetupDialog state
268 ; printDialog psd (toolName ++ " print") pageFun printFun
273 [ text := "Print preview"
274 , on command := safetyNet theFrame $
275 let printFun _ _ _ dc _ = paintHandler state dc Net
276 pageFun _ _ _ = (1, 1)
278 do{ psd <- getPageSetupDialog state
279 ; printPreview psd (toolName ++ " preview") pageFun printFun
287 , on command := close theFrame
291 ; editMenu <- menuPane [ text := "&Edit" ]
292 ; undoItem <- menuItem editMenu
293 [ on command := safetyNet theFrame $ do PD.undo pDoc; repaintAll state ]
294 ; redoItem <- menuItem editMenu
295 [ on command := safetyNet theFrame $ do PD.redo pDoc; repaintAll state ]
299 [ text := "Edit global info..."
300 , on command := safetyNet theFrame $ changeGlobalInfo theFrame state
305 ; viewMenu <- menuPane [ text := "&View" ]
306 ; (DP opts) <- getDisplayOptions state
308 [ text := "Node Label"
310 , checked := NodeLabel `elem` opts
311 , on command := safetyNet theFrame $ do
312 { changeDisplayOptions (toggle NodeLabel) state
313 ; repaintAll state } ]
316 [ text := "Node Info"
318 , checked := NodeInfo `elem` opts
319 , on command := safetyNet theFrame $ do
320 { changeDisplayOptions (toggle NodeInfo) state
321 ; repaintAll state } ]
324 [ text := "Edge Label"
326 , checked := EdgeLabel `elem` opts
327 , on command := safetyNet theFrame $ do
328 { changeDisplayOptions (toggle EdgeLabel) state
329 ; repaintAll state } ]
332 [ text := "Edge Info"
334 , checked := EdgeInfo `elem` opts
335 , on command := safetyNet theFrame $ do
336 { changeDisplayOptions (toggle EdgeInfo) state
337 ; repaintAll state } ]
341 ; opsMenu <- menuPane [ text := "&Operations" ]
342 ; mapM_ (\ (name,_)->
345 , on command := safetyNet theFrame $ do
346 { callPureGraphOp name ops state
350 ; when (not . null $ pureOps ops)
353 ; mapM_ (\ (name,_)->
356 , on command := safetyNet theFrame $ do
357 { callIOGraphOp name ops state
361 ; when (not . null $ ioOps ops)
365 [ text := "Functional term to IN system"
366 , on command := safetyNet theFrame $ compileUI state g n e
370 ; palMenu <- menuPane [ text := "&Symbols" ]
372 [ text := "Save palette as ..."
373 , on command := safetyNet theFrame $ savePalette theFrame state
376 [ text := "Change shape palette..."
377 , on command := safetyNet theFrame $
378 do yes <- confirmDialog theFrame "Dangerous operation!!" "Changing the palette can lead to severe errors.\nUnless you know what you are doing, don't proceed.\nDo you really want to proceed ?" False
379 when yes $ openPalette theFrame state
383 ; chksMenu <- menuPane [text := "&Checks"]
384 ; mapM_ (\ chk@(name, desc,_,_,_) ->
385 menuItem chksMenu [ text := name
386 , on command := safeAndClear theFrame textlog $ singleCheckOverIN chk state
390 ; menuItem chksMenu [ text := "Multiple checks at once"
391 , on command := safeAndClear theFrame textlog $ multipleChecksOverIN_UI theFrame state
393 ; menuItem chksMenu [ text := "Checks over multiple files"
394 , on command := safeAndClear theFrame textlog $ multipleChecksOverINs_UI state
398 ; helpMenu <- menuPane [ text := "&Help" ]
400 [ text := "How to use?"
401 , on command := createHelpWindow
405 , on command := createAboutWindow theFrame
408 ; PD.initialise pDoc (PD.PD
409 { PD.document = Document.empty g n e
413 , PD.fileName = Nothing
415 , PD.saveToDisk = saveToDisk theFrame
416 , PD.updateUndo = PD.defaultUpdateUndo undoItem
417 , PD.updateRedo = PD.defaultUpdateRedo redoItem
418 , PD.updateSave = PD.defaultUpdateSave saveItem
419 , PD.updateTitleBar = PD.defaultUpdateTitlebar theFrame toolName
420 , PD.saveChangesDialog = PD.defaultSaveChangesDialog theFrame toolName
421 , PD.saveAsDialog = PD.defaultSaveAsDialog theFrame extensions
424 ; setInterfacePalette n state
426 ; initializeRules state g n e
428 ; tree <- treeCtrl rulesTreePan [style :~ (wxTR_EDIT_LABELS .+.)]
430 ; top <- treeCtrlAddRoot tree "Rules" noImage noImage objectNull
431 -- ; treeCtrlSetItemClientData tree top (return ()) ""
432 ; addRules2Tree tree top state
433 ; treeCtrlExpand tree top
434 ; set tree [ on treeEvent := onTreeEvent tree state g n e]
436 ; buttonNewRule <- button rulesTreePan
437 [ text := "Add new rule"
438 , on command := safetyNet theFrame $ addNewRuleItem True state $ initial g n e
440 ; buttonNewIRule <- button rulesTreePan
441 [ text := "Rule creation wizard"
442 , on command := safetyNet theFrame $ createRuleItem theFrame state g n e
446 ; addAgent <- button palettePan [ text := "Create new symbol"
447 , on command := createNewAgentItem state
450 ; set palettePan [ layout := column 5 [ widget addAgent
451 , hfloatCentre $ widget palPan ] ]
455 ; reduceB <- button netPan
459 ; setReduceButton reduceB state
461 ; reduceStopB <- button netPan
465 ; let (stratsS, _) = unzip strategiesList
467 ; strategies <- radioBox netPan Vertical stratsS
471 ; steps <- radioBox netPan Vertical ["one", "many"]
475 ; set reduceB [on command := do
476 set reduceB [enabled := False]
477 set reduceStopB [enabled := True]
478 set strategies [enabled := False]
479 set steps [enabled := False]
480 setContinueReduction True state
481 s <- get steps selection
482 i <- get strategies selection
483 globalReduce (stratsS !! i) (s==1) state
484 set reduceStopB [enabled := False]
485 set strategies [enabled := True]
486 set steps [enabled := (stratsS !! i /= "Manual selection")]
487 set reduceB [enabled := True]
490 ; set reduceStopB [ on command := do stopReduction state
491 set reduceStopB [enabled := False]
492 set reduceB [enabled := True]
495 ; set strategies [ on select :=
496 do i <- get strategies selection
497 if stratsS !! i == "Manual selection"
498 then set steps [ enabled := False
501 else do set steps [ enabled := True]
502 set reduceB [ enabled := True]
507 -- Layout the main window
509 [ menuBar := [ fileMenu, editMenu, viewMenu, opsMenu, palMenu, chksMenu, helpMenu ]
510 , layout := container mainPan $ margin 5 $ fill $
511 hsplit sp 5 500 ( -- to remove. just for debug
515 (container rulesTreePan $
516 column 5 [ fill $ widget tree
517 , hfloatCentre $ widget buttonNewRule
518 , hfloatCentre $ widget buttonNewIRule
526 #if !defined(__APPLE__)
527 container ruleLHSPan $ boxed "LHS" $
529 fill $ widget canvasLHS)
530 (container ruleRHSPan $ row 5 [ vstretch $ valignCenter $ column 5 [ widget lhs2rhsB
531 , widget lhsInt2rhsB ]
533 #if !defined(__APPLE__)
536 fill $ widget canvasRHS
539 column 5 [ fill $ widget canvas
541 #if !defined(__APPLE__)
544 hfloatLeft $ row 5 [ widget strategies
546 , column 5 [ widget reduceB
547 , widget reduceStopB]
552 )(widget textlog) -- to remove. just for debug
555 , clientSize := sz 900 600
557 , on closing := safetyNet theFrame $ checkValidINOnSave state $ exit state
561 -- [ position := pt 200 20
562 -- , clientSize := sz 300 240