16 import qualified PersistentDocument as PD
17 import qualified PDDefaults as PD
24 import Text.XML.HaXml.XmlContent (XmlContent)
25 import Text.Parse as Parse
29 import Graphics.UI.WX hiding (Child, upKey, downKey, swap)
30 import Graphics.UI.WXCore hiding (Document, Palette)
34 import qualified Data.Map as Map
39 -- | Prints a document in a none XMl format
40 printy :: (InfoKind n g, InfoKind e g, Show g) => Document.Document g n e -> IO ()
42 do let network = getNetwork doc
45 putStrLn "+++++++++++++++++++++++++++++++"
47 where mostraNodos network = print $ map Network.getName $ getNodes network
48 f rule = do putStrLn $ INRule.getName rule
50 mostraNodos $ getLHS rule
52 mostraNodos $ getRHS rule
53 print $ INRule.getMapping rule
54 putStrLn "-----------------------------------"
56 paintHandler :: (InfoKind n g, InfoKind e g) =>
57 State g n e -> DC () -> ActiveCanvas -> IO ()
58 paintHandler state dc canvas =
59 do{ pDoc <- getDocument state
60 ; doc <- PD.getDocument pDoc
61 ; dp <- getDisplayOptions state
62 ; let network = selectNetwork doc canvas
63 selection = getSelection doc
64 palette = getPalette doc
65 selection' = selection `filterSelectionTo` canvas
66 ; mapp <- case canvas of
68 LHS rule -> maybe (fail $ rule ++ " not found.")
69 (return . map fst . getMapping)
70 . findRule rule $ getRules doc
71 RHS rule -> maybe (fail $ rule ++ " not found.")
72 (return . map snd . getMapping)
73 . findRule rule $ getRules doc
75 ; drawCanvas network palette selection' mapp dc dp
77 where filterSelectionTo :: Document.Selection -> ActiveCanvas
79 filterSelectionTo selection canvas =
81 NodeSelection canv _ _ | canv == canvas -> selection
82 EdgeSelection canv _ | canv == canvas -> selection
83 ViaSelection canv _ _ | canv == canvas -> selection
84 MultipleSelection canv _ _ _ | canv == canvas -> selection
88 chooseNetwork :: State g n e -> IO (Network g n e)
90 do canvas <- getActiveCanvas state
91 pDoc <- getDocument state
92 doc <- PD.getDocument pDoc
94 Net -> return $ getNetwork doc
95 LHS rule -> maybe (fail $ "Invalid rule name: " ++ rule) return
96 $ getLHS `fromRule` rule $ getRules doc
97 RHS rule -> maybe (fail $ "Invalid rule name: " ++ rule) return
98 $ getRHS `fromRule` rule $ getRules doc
100 mouseEvent :: (InfoKind n g, InfoKind e g, Show g, Parse g) =>
101 EventMouse -> ScrolledWindow () -> Frame () -> State g n e -> IO ()
102 mouseEvent eventMouse canvas theFrame state = case eventMouse of
103 MouseLeftDown mousePoint mods
104 | shiftDown mods -> leftMouseDownWithShift mousePoint state
105 | metaDown mods || controlDown mods -> leftMouseDownWithMeta mousePoint state
106 | otherwise -> mouseDown True mousePoint theFrame state
107 MouseRightDown mousePoint _ ->
108 mouseDown False mousePoint theFrame state
109 MouseLeftDrag mousePoint _ ->
110 leftMouseDrag mousePoint canvas state
111 MouseLeftUp mousePoint _ ->
112 leftMouseUp mousePoint state
116 keyboardEvent :: (InfoKind n g, InfoKind e g) =>
117 Frame () -> State g n e -> EventKey -> IO ()
118 keyboardEvent theFrame state (EventKey theKey _ _) =
120 KeyDelete -> deleteKey state
121 KeyBack -> backspaceKey state
122 KeyF2 -> f2Key theFrame state
123 KeyChar 'r' -> pressRKey theFrame state
124 KeyChar 'i' -> pressIKey theFrame state
126 KeyDown -> downKey state
129 closeDocAndThen :: State g n e -> IO () -> IO ()
130 closeDocAndThen state action =
131 do{ pDoc <- getDocument state
132 ; continue <- PD.isClosingOkay pDoc
133 ; when continue $ action
136 setInterfacePalette :: (InfoKind n g) => n -> State g n e -> IO ()
137 setInterfacePalette n state =
138 do pDoc <- getDocument state
140 let interfacePal = Palette [interfaceSymbol]
141 -- set the initial palette only with interface symbol
142 PD.superficialUpdateDocument (setPalette interfacePal) pDoc
143 setCurrentShape (fst interfaceSymbol) state
145 buildVisiblePalette state
148 newItem :: (InfoKind n g, InfoKind e g) => State g n e -> g -> n -> e -> IO ()
149 newItem state g n e =
150 closeDocAndThen state $
151 do{ pDoc <- getDocument state
152 ; PD.resetDocument Nothing (Document.empty g n e) pDoc
153 ; initializeRules state g n e
154 ; reAddRules2Tree state
155 ; setInterfacePalette n state
159 openItem :: (InfoKind n g, InfoKind e g, XmlContent g) =>
160 Frame () -> State g n e -> IO ()
161 openItem theFrame state =
162 do{ mbfname <- fileOpenDialog
164 False -- change current directory
165 True -- allowReadOnly
168 "" "" -- no default directory or filename
169 ; ifJust mbfname $ \fname -> openNetworkFile fname state (Just theFrame)
172 -- Third argument: Nothing means exceptions are ignored (used in Configuration)
173 -- Just f means exceptions are shown in a dialog on top of frame f
174 openNetworkFile :: (InfoKind n g, InfoKind e g, XmlContent g) =>
175 String -> State g n e -> Maybe (Frame ()) -> IO ()
176 openNetworkFile fname state exceptionsFrame =
177 closeDocAndThen state $
179 (\exc -> case exceptionsFrame of
181 Just f -> errorDialog f "Open network"
182 ( "Error while opening '" ++ fname ++ "'. \n\n"
183 ++ "Reason: " ++ show exc)
185 do{ contents <- strictReadFile fname
186 ; let errorOrDocument = DocumentFile.fromString contents
187 ; case errorOrDocument of {
188 Left err -> ioError (userError err);
189 Right (doc, warnings, oldFormat) ->
191 ; pDoc <- getDocument state
192 ; PD.resetDocument (if null warnings then Just fname else Nothing)
194 ; applyCanvasSize state
195 ; when (not (null warnings)) $
196 case exceptionsFrame of
199 do{ errorDialog f "File read warnings"
200 ( "Warnings while reading file " ++ show fname ++ ":\n\n"
201 ++ unlines ( map ("* " ++) (take 10 warnings)
202 ++ if length warnings > 10 then ["..."] else []
206 , "Most likely you are reading a file that is created by a newer version of " ++ toolName ++ ". If you save this file with"
207 , "this version of " ++ toolName ++ " information may be lost. For safety the file name is set to \"untitled\" so that you do"
208 , "not accidentally overwrite the file"
211 ; PD.setFileName pDoc Nothing
214 do{ case exceptionsFrame of
217 errorDialog f "File read warning" $
219 [ "The file you opened has the old " ++ toolName ++ " file format which will become obsolete in newer versions of " ++ toolName ++ "."
220 , "When you save this network, the new file format will be used. To encourage you to do so the network has"
221 , "been marked as \"modified\"."
223 ; PD.setDirty pDoc True
226 ; buildVisiblePalette state
227 ; reAddRules2Tree state
231 openPalette :: (InfoKind n g, Parse n) => Frame () -> State g n e -> IO ()
232 openPalette theFrame state =
233 do{ mbfname <- fileOpenDialog
235 False -- change current directory
236 True -- allowReadOnly
239 "" "" -- no default directory or filename
240 ; ifJust mbfname $ \fname -> openPaletteFile fname state (Just theFrame)
243 -- Third argument: Nothing means exceptions are ignored (used in Configuration)
244 -- Just f means exceptions are shown in a dialog on top of frame f
245 openPaletteFile :: (InfoKind n g, Parse n) =>
246 String -> State g n e -> Maybe (Frame ()) -> IO ()
247 openPaletteFile fname state exceptionsFrame =
249 (\exc -> case exceptionsFrame of
251 Just f -> errorDialog f "Open shape palette"
252 ( "Error while opening '" ++ fname ++ "'. \n\n"
253 ++ "Reason: " ++ show exc)
255 do{ contents <- readFile fname
256 ; case fst (runParser parse contents) of {
257 Left msg -> ioError (userError ("Cannot parse shape palette file: "
258 ++fname++"\n\t"++msg));
259 Right p -> do{ pDoc <- getDocument state
260 ; doc <- PD.getDocument pDoc
261 ; let newPalette = removeQuotesFromNames p
262 oldPalette = getPalette doc
263 newNames = shapesNames newPalette
264 oldNames = shapesNames oldPalette
266 ; let cont = newNames `union` oldNames == newNames
270 case exceptionsFrame of
271 Nothing -> return False
272 Just f -> confirmDialog f
273 "Conflict with palettes"
274 ("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
275 ; when (cont || yes) $
276 do PD.updateDocument "change palette"
277 (setPalette newPalette)
279 -- the shape name of the first palette's element is chosen
280 -- as the default one
281 setCurrentShape (fst . head . shapes $ newPalette) state
283 buildVisiblePalette state
286 where remQuot = init . tail
287 removeQuotesFromNames = Palette . map (\(a,b) -> (remQuot a, rem1 b) ) . shapes
288 rem1 (shape, mPorts, info) = (shape, map rem3 mPorts , info)
289 rem3 (str, dpoint) = (remQuot str, dpoint)
291 savePalette :: Show n => Frame () -> State g n e -> IO ()
292 savePalette theFrame state =
293 do pDoc <- getDocument state
294 doc <- PD.getDocument pDoc
295 mfname <- PD.defaultSaveAsDialog theFrame paletteExtensions Nothing
297 Just fname -> do safeWriteFile theFrame fname . show $ getPalette doc
301 -- | Get the canvas size from the network and change the size of
302 -- the widget accordingly
303 applyCanvasSize :: State g n e -> IO ()
304 applyCanvasSize state =
305 do{ pDoc <- getDocument state
306 ; doc <- PD.getDocument pDoc
307 ; let network = getNetwork doc
308 (width, height) = getCanvasSize network
309 ; canvas <- getCanvas state
310 ; ppi <- getScreenPPI
311 ; set canvas [ virtualSize := sz (logicalToScreenX ppi width)
312 (logicalToScreenY ppi height) ]
316 saveToDisk :: (InfoKind n g, InfoKind e g, XmlContent g) =>
317 Frame () -> String -> Document.Document g n e -> IO Bool
318 saveToDisk theFrame fileName doc =
319 safeWriteFile theFrame fileName (DocumentFile.toString doc)
321 exit :: State g n e -> IO ()
323 closeDocAndThen state $ propagateEvent
325 -- Code for build the Visible Palette
327 buildVisiblePalette :: InfoKind n g => State g n e -> IO ()
328 buildVisiblePalette state =
329 do{ pDoc2 <- getDocument state
330 ; pp <- getPalettePanel state
331 ; doc <- PD.getDocument pDoc2
332 ; let palette = getPalette doc
334 -- its necessary to delete the old elements in the panel
335 ; windowChildren pp >>= mapM objectDelete
337 ; reallyBuildVisiblePalette palette pp state setCurrentShape
340 reallyBuildVisiblePalette :: InfoKind n g =>
341 Palette.Palette n -> Panel () -> State g n e
342 -> (String -> State g n e -> IO ()) -> IO ()
343 reallyBuildVisiblePalette palette panel state action =
344 do list <- mapM (drawNodeButton panel state action) . shapes $ palette
345 let table = list2Table 2 list
348 #if !defined(__APPLE__)
349 boxed "Symbol palette"
354 drawNodeButton :: InfoKind n g => Window w -> State g n e -> (String -> State g n e -> IO ())
355 -> (String, (Shape, Ports, Maybe n)) -> IO Layout
356 drawNodeButton w state action (name, (shape, ports, _info)) =
357 do{ frame <- getNetworkFrame state
358 ; node <- button w [ text := name
359 -- , clientSize := sz 50 50 -- due to a wxHaskell problem forcing the size don't works
360 , on command := action name state
361 , on mouse := \ev -> safetyNet frame $ mouseSymbol ev name action state
364 , on paint := \dc r -> safetyNet frame $
365 do { logicalDraw ppi dc (center r) shape []
366 ; drawPorts ppi dc (center r) ports []
370 ; return (widget node)
372 where factor f (DoublePoint x y) = DoublePoint (x/f) (y/f)
373 ppi = (sz 40 40) -- (rectSize r) this is the correct code if
374 center r = factor 14.0 $ intPointToDoublePoint $ rectCentralPoint r
376 mouseSymbol :: InfoKind n g => EventMouse -> String -> (String -> State g n e -> IO ()) -> State g n e -> IO ()
377 mouseSymbol mouseEV name action state =
379 MouseLeftUp _ _ -> action name state
380 MouseRightUp _ _ -> removeSymbolUI name state
383 -- | Transforms a list in a table of n columns
384 list2Table :: Int -> [a] -> [[a]]
385 list2Table n l | null l = []
386 | otherwise = a : list2Table n b
387 where (a,b) = splitAt n l
389 createNewAgentItem :: InfoKind n g => State g n e -> IO ()
390 createNewAgentItem state =
391 do mRes <- createAgentByNameDialog state
393 Just (agentName, agentShape, ports) ->
394 do{ pDoc <- getDocument state
395 ; let newElem = (agentName, (agentShape, ports, Nothing))
396 ; PD.updateDocument "change palette"
397 (\doc -> setPalette (Palette . (++ [newElem]) . shapes . getPalette $ doc)
401 ; setCurrentShape (agentName) state
403 ; buildVisiblePalette state
407 removeSymbolUI :: (InfoKind n g) => String -> State g n e -> IO ()
408 removeSymbolUI name state =
409 when (name /= "interface") $
410 do contextMenu <- menuPane []
412 [ text := "Remove symbol"
413 , on command := removeSymbol name state
415 theFrame <- getNetworkFrame state
416 pointWithinWindow <- windowGetMousePosition theFrame
417 menuPopup contextMenu pointWithinWindow theFrame
418 objectDelete contextMenu
420 -- | Removes a symbol if it is not used or else don't remove and list its occurrences.
421 removeSymbol :: (InfoKind n g) => String -> State g n e -> IO ()
422 removeSymbol name state =
423 do theFrame <- getNetworkFrame state
424 if name == "interface"
425 then warningDialog theFrame "Deletion forbidden" "Interface symbol is a special one that can't be deleted."
428 pDoc <- getDocument state
429 doc <- PD.getDocument pDoc
431 let newpal = deleteShape name $ getPalette doc
432 symbs = map fst . shapes $ newpal
433 errors = undefinedAgents symbs doc
435 then do -- symbol can be safely removed
436 remove <- confirmDialog theFrame "Symbol deletion"
437 ("Symbol \"" ++ name ++
438 "\" can be safely removed.\nAre you sure you want to delete it?")
441 then do PD.updateDocument ("Symbol " ++ name ++ " removed") (setPalette newpal) pDoc
442 buildVisiblePalette state
445 else -- there are occurrences of symbol; list them
446 errorDialog theFrame "Deletion forbidden" $
447 "Symbol \"" ++ name ++
448 "\" can't be deleted because there are the following occurrences of it in the IN system:\n"
449 ++ (unlines . map show $ Map.keys errors)
451 -- | List the rules on a one level tree.
452 addRules2Tree :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) =>
453 TreeCtrl a -> TreeItem -> State g n e -> IO ()
454 addRules2Tree tree item state =
455 do pDoc <- getDocument state
456 doc <- PD.getDocument pDoc
458 treeCtrlDeleteChildren tree item
459 let rNames = rulesNames $ getRules doc
460 mapM_ addItemRule rNames
462 -- choose the last rule as the active (displayed) one
463 rule <- treeCtrlGetLastChild tree item
464 ruleName <- treeCtrlGetItemText tree rule
465 setActiveRule ruleName state
466 treeCtrlSelectItem tree rule
467 where addItemRule ruleName =
468 treeCtrlAppendItem tree item ruleName noImage noImage objectNull
470 -- | Eliminates old rules and add the newer ones.
471 reAddRules2Tree :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) =>
473 reAddRules2Tree state =
474 do tree <- getTree state
475 root <- treeCtrlGetRootItem tree
476 addRules2Tree tree root state
478 onTreeEvent :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) =>
479 TreeCtrl a -> State g n e -> g -> n -> e -> EventTree -> IO ()
480 onTreeEvent tree state g n e event =
482 TreeSelChanged item olditem | treeItemIsOk item
483 -> do wxcBeginBusyCursor
484 ruleName <- treeCtrlGetItemText tree item
485 when (ruleName /= "Rules") $
486 do setActiveRule ruleName state
490 TreeBeginLabelEdit item str action
491 | str == "Rules" -> action -- prevents the root from be editable
492 TreeEndLabelEdit item new wasCanceled veto | not wasCanceled ->
493 do -- change rule name
494 old <- treeCtrlGetItemText tree item
497 do pDoc <- getDocument state
498 frame <- getNetworkFrame state
499 doc <- PD.getDocument pDoc
500 let rNames = rulesNames $ getRules doc
503 warningDialog frame "Warning"
504 $ "Already exists one rule with name \"" ++ new
505 ++ "\".\n Please choose a different identifier."
506 else do PD.updateDocument "change rule name"
509 $ INRule.setName new) pDoc
510 setActiveRule new state
512 TreeItemRightClick item ->
513 do ruleName <- treeCtrlGetItemText tree item
514 contextMenu <- menuPane []
515 theFrame <- getNetworkFrame state
517 if (ruleName == "Rules") -- means right click on root item
519 do menuItem contextMenu
520 [ text := "Add new rule"
521 , on command := safetyNet theFrame $ addNewRuleItem True state $ initial g n e
524 [ text := "Create new Interaction Net rule"
525 , on command := safetyNet theFrame $ createRuleItem theFrame state g n e
528 do menuItem contextMenu
529 [ text := "Rename rule"
530 , on command := treeCtrlEditLabel tree item
533 [ text := "Remove rule"
534 , on command := do safetyNet theFrame
535 $ removeRuleItem state ruleName item
540 pointWithinWindow <- windowGetMousePosition theFrame
541 menuPopup contextMenu pointWithinWindow theFrame
542 objectDelete contextMenu
546 -- | Adds a new rule setting it with a new name.
547 addNewRuleItem :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) =>
548 Bool -> State g n e -> INRule g n e -> IO ()
549 addNewRuleItem genNewName state newRule =
550 do pDoc <- getDocument state
551 doc <- PD.getDocument pDoc
553 let newName = if genNewName then (addNew 1 . rulesNames $ getRules doc) else (INRule.getName newRule)
555 PD.updateDocument ("add rule <<" ++ newName ++ ">>")
556 (updateRules $ addNewRule $ (if genNewName then INRule.setName newName else id) $ newRule ) pDoc
558 tree <- getTree state
559 root <- treeCtrlGetRootItem tree
560 item <- treeCtrlAppendItem tree root newName noImage noImage objectNull
561 treeCtrlSelectItem tree item
562 where addNew :: Int -> [String] -> String
563 addNew i rules | newName `elem` rules = addNew (i+1) rules
564 | otherwise = newName
565 where newName = "Rule " ++ show i
566 updateTreeSelection :: State g n e -> IO ()
567 updateTreeSelection state =
568 do tree <- getTree state
569 root <- treeCtrlGetRootItem tree
570 selItem <- treeCtrlGetLastChild tree root
571 treeCtrlSelectItem tree selItem
573 removeRuleItem :: (InfoKind n g, InfoKind e g) =>
574 State g n e -> String -> TreeItem -> IO ()
575 removeRuleItem state ruleName item =
576 do frame <- getNetworkFrame state
577 pDoc <- getDocument state
578 doc <- PD.getDocument pDoc
580 if (1 == ) . length . rulesNames $ getRules doc
581 then warningDialog frame "Removal forbidden"
582 "You cannot remove the rule because it is the last one."
583 else do tree <- getTree state
584 delete <- confirmDialog frame "Rule deletion" msg yesDefault
587 do treeCtrlDelete tree item
588 updateTreeSelection state
590 PD.updateDocument ("remove rule " ++ ruleName)
591 (updateRules $ removeRule ruleName) pDoc
593 where yesDefault = False
594 msg = "Are you sure you want to delete rule \"" ++ ruleName ++ "\" ?"
596 -- | If there are none rules it creates a empty one.
597 initializeRules :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) =>
598 State g n e -> g -> n -> e -> IO ()
599 initializeRules state g n e =
600 do pDoc <- getDocument state
601 doc <- PD.getDocument pDoc
602 let rNames = rulesNames $ getRules doc
606 do -- adds an initial rule
607 PD.superficialUpdateDocument
608 (updateRules $ addNewEmptyRule "Rule 1" g n e) pDoc
609 setActiveRule "Rule 1" state
610 else setActiveRule (head rNames) state
612 lhs2rhsItem :: Bool -> State g n e -> IO ()
613 lhs2rhsItem everything state =
614 do pDoc <- getDocument state
615 rule <- getActiveRule state
616 theFrame <- getNetworkFrame state
617 doc <- PD.getDocument pDoc
618 let rhs = selectNetwork doc $ RHS rule
620 copy <- if isEmpty rhs
622 else proceedDialog theFrame "Non empty RHS" $
623 "The RHS side of the rule is not empty.\n" ++
624 "Copying the LHS will make you loosing it.\n" ++
625 "Do you want to proceed ?"
628 then PD.updateDocument ("copy of LHS to RHS on rule " ++ rule)
629 (updateRules $ updateRule rule $ copyLHS2RHS) pDoc
630 else PD.updateDocument ("copy of LHS interface to RHS on rule " ++ rule)
631 (updateRules $ updateRule rule $ copyLHSInterface2RHS) pDoc
633 setActiveCanvas (RHS rule) state
635 data CopyLHS2RHS = Everything | JustInterface | DontCopy | DefaultRule deriving (Show)
637 -- | Create a dialog where the user have to choose two symbols.
638 -- An interaction net rule, whose left hand side is the active pair
639 -- of those two agents, will then be created.
640 -- A new name is created for this rule.
641 createRuleItem :: (InfoKind n g, InfoKind e g) =>
642 Frame () -> State g n e -> g -> n -> e -> IO ()
643 createRuleItem frame state g n e =
645 maybeRes <- chooseAgentsDialog state
646 when (isJust maybeRes) $
648 ; pDoc <- getDocument state
649 ; doc <- PD.getDocument pDoc
650 ;let palette = getPalette doc
651 ;let ;(agent1, agent2, copyOption) = fromJust maybeRes
652 ;copy = case copyOption of
653 Everything -> copyLHS2RHS
654 JustInterface -> copyLHSInterface2RHS
656 DefaultRule -> defaultRuleSelector (agent1,agent2) state g n e palette
657 ; (rule,nNr1,nNr2) <- createRuleWizard g n e palette agent1 agent2
658 ; addNewRuleItem False state $ copy rule
661 -- An interaction net rule, whose left hand side is the active pair
662 -- of the two given agents, will be created.
663 -- A new name is created for this rule.
665 createRuleWizard :: (InfoKind n g, InfoKind e g) =>
666 g -> n -> e -> Palette n
667 -> String -> String -> IO (INRule g n e, NodeNr, NodeNr)
668 createRuleWizard g n e palette agent1 agent2 =
671 (nNr1, lhs1) = addNode agent1 palette
672 $ Network.empty g n e
673 (nNr2, lhs2) = addNode agent2 palette lhs1
675 ; (pP1:ports1) <- getPorts' agent1 palette
676 ; (pP2:ports2) <- getPorts' agent2 palette
678 -- edge connecting principal ports
679 ; let lhs3 = addEdge palette nNr1 (fst pP1) nNr2 (fst pP2) lhs2
681 (pos1, pos2) = givePositions pP1 pP2 -- (DoublePoint 2.0 2.0, DoublePoint 6.0 3.0) -- ??
682 lhs4 = setNodePosition nNr1 pos1
683 . setNodePosition nNr2 pos2 $ lhs3
685 -- adding as many interface nodes as needed
686 (nrs1, lhs5) = addNodes (fst interfaceSymbol) palette (length ports1) lhs4
687 (nrs2, lhs6) = addNodes (fst interfaceSymbol) palette (length ports2) lhs5
689 ; interPort <- getInterfacePort palette
691 -- choose interface agents better positions; up or down
692 ; let (ups1, downs1) = (map snd >< map snd ) . partition sep $ zip ports1 nrs1
693 (ups2, downs2) = (map snd >< map snd ) . partition sep $ zip ports2 nrs2
694 orderConcat = chooseOrder pos1 pos2
696 -- add edges between not principal ports in agents to interface nodes and set their positions
697 lhs7 = rowNodes (DoublePoint 0.5 5.5) (orderConcat downs1 downs2)
698 . rowNodes (DoublePoint 0.5 0.5) (orderConcat ups1 ups2)
699 . addEdges palette -- edges agent2 to interface
700 [((nNr2, fst p'), (n', fst interPort)) | p' <- ports2 | n' <- nrs2]
701 . addEdges palette -- edges agent1 to interface
702 [((nNr1, fst p'), (n', fst interPort)) | p' <- ports1 | n' <- nrs1] $ lhs6
703 ; let rhs = Network.empty g n e
705 ; return (construct (agent1 ++ "_" ++ agent2) lhs7 rhs mapping, nNr1,nNr2)
707 where getPorts' = getSymbolPorts
709 getInterfacePort :: Palette.Palette n -> IO Port
710 getInterfacePort palette =
711 do ps <- getPorts' "interface" palette
713 [port] -> return port
714 _ -> fail "Interface agent with more than one port."
715 givePositions :: Port -> Port -> (DoublePoint, DoublePoint)
716 givePositions port1 port2 = g (portZone port1) (portZone port2)
717 where g Ztop Ztop = lineH
718 g Zbottom Zbottom = lineH
719 g Zleft Zleft = lineV
720 g Zright Zright = lineV
721 g Ztop Zbottom = invert lineV
722 g Zbottom Ztop = lineV
723 g Zleft Zright = invert lineH
724 g Zright Zleft = lineH
725 g Ztop Zleft = invert lineI
726 g Ztop Zright = invert lineD
727 g Zbottom Zleft = lineD
728 g Zbottom Zright = lineI
730 g Zleft Zbottom = invert lineD
731 g Zright Ztop = lineD
732 g Zright Zbottom = invert lineI
736 p1 = DoublePoint c1 c1
737 p2 = DoublePoint c2 c1
738 p3 = DoublePoint c1 c2
739 p4 = DoublePoint c2 c2
746 sep :: (Port, NodeNr) -> Bool
747 sep (port, _) = isUp port
748 chooseOrder pos1 pos2 = if doublePointX pos1 <= doublePointX pos2
752 getSymbolPorts :: String -> Palette.Palette n -> IO Ports
753 getSymbolPorts shape (Palette palette) =
754 case Data.List.lookup shape palette of
755 Nothing -> fail $ shape ++ " agent is missing."
756 Just e -> case snd3 e of
757 [] -> fail $ shape ++ " agent without port."
760 -- | For a list of nodes placed at the same position, change their positions to form a row.
761 rowNodes :: DoublePoint -> [NodeNr] -> Network g n e -> Network g n e
762 rowNodes startingPoint nodes net = snd $ foldl gene (startingPoint, net) nodes
763 gene :: (DoublePoint, Network g n e) -> NodeNr -> (DoublePoint, Network g n e)
764 gene (actual, oldNet) nNr = (translate actual diff, setNodePosition nNr actual oldNet)
765 diff = DoublePoint 1.0 0.0
770 defaultRuleSelector :: (InfoKind n g, InfoKind e g) => (String,String) -> State g n e-> g ->n -> e ->
771 Palette.Palette n -> INRule g n e -> INRule g n e
772 defaultRuleSelector (a1,a2) state g n e pal rule = case a2 of
773 "copy" -> copyORduplicatorDefaultRule (a1,a2) rule state g n e pal
774 "duplicator" -> copyORduplicatorDefaultRule (a1,a2) rule state g n e pal
775 "Erase" -> eraseDefaultRule a1 rule state g n e pal
778 ------------------------------------------------------------------------------------------------------------------------
780 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)
781 eraseDefaultRule a1 rule state g n e palette =
782 let ;newRule = copyLHSInterface2RHS $ construct "" lhs (Network.empty g n e) []
783 ;rhs = getRHS newRule
784 ;inter = getNodeAssocs rhs
785 ;(erasers, rhs1) = addNodes "Erase" palette (length inter) rhs
786 ;rhs2 = rowNodes (DoublePoint 1.0 1.0) erasers rhs1
787 ;rhs3 = addEdges palette (mix (map fst inter) erasers) rhs2
788 in (construct ("T:Erase_"++a1) lhs rhs3 (getMapping newRule))
792 mix (x:y ) (a:b) = [((x, "interface"),(a, "down")) ]++ mix y b
800 copyORduplicatorDefaultRule :: (InfoKind n g, InfoKind e g) => (String,String) -> INRule g n e ->
801 State g n e -> g -> n -> e -> Palette.Palette n -> (INRule g n e)
802 copyORduplicatorDefaultRule (a1,a2) rule state g n e palette = let
803 newRule = copyLHSInterface2RHS $ construct "" lhs (Network.empty g n e) []
805 inter = getNodeAssocs rhs
806 (alphas, rhs1) = addNodes a1 palette 2 rhs
807 (spas,rhs2) = addNodes a2 palette ((\x -> x-1) . length . snd3 . takeJust "Undefined symbol" $ getSymbol a1 palette) rhs1
808 rhs3 = rowNodes (DoublePoint 1.0 4.0) spas $ (rowNodes (DoublePoint 1.0 2.0) alphas rhs2)
809 (copyI,alphaI) = splitAt ((length inter)-2) inter
810 rhs4 = makeInterfaceConection (map fst alphaI) alphas $ makeInterfaceConection (map fst (reverse copyI)) spas rhs3
811 newC :: [((NodeNr, PortName), (NodeNr, PortName))]
812 newC = newConections $ makeConnection alphas spas rhs4
813 rhs5 = addEdges palette newC rhs4
814 in (construct ('T':':':a2++'_':a1) lhs rhs5 (getMapping newRule))
815 where ;lhs = getLHS rule
816 -- ;makeInterfaceConection :: [NodeNr] -> [NodeNr] -> Network g n e -> Network g n e
817 ;makeInterfaceConection inter node ne = let pp_i = getInterfaceList inter ne
818 pp_n = getInterfaceList node ne
819 in addEdges palette (zip (zip inter pp_i) (zip node pp_n)) ne
820 ;getInterfaceList nodes ne = map (const "interface") nodes
821 -- ; getJustPorts :: Network g n e -> NodeNr -> [PortName]
822 ; getJustPorts ne y = map fst . fromJust $ getPorts palette ne y
824 -- ;makeConnection :: [NodeNr] -> [NodeNr] -> Network g n e ->([((NodeNr,PortName),(Int,Int))] , [((NodeNr,PortName),(Int,Int))])
825 ;makeConnection alphs sps ne = let
826 ;alp_p :: [[PortName]]
827 ;alp_p = map (reverse . drop 1 . getJustPorts ne ) alphs
828 ;alp_p_i = map (zip [1..] ) alp_p
829 ;alp_Nr_p = zip [1..] alp_p_i
830 ;alp_fin = zip alphs alp_Nr_p
831 ;sps_p = map (drop 1 . getJustPorts ne) sps
832 ;sps_p_i = map (zip [1..] ) sps_p
833 ;sps_Nr_p = zip [1..] sps_p_i
834 ;sps_fin = zip sps sps_Nr_p
835 in (foldr (++) [] $ map f alp_fin , foldr (++) [] $ map f sps_fin)
836 ;f :: (Int,(Int,([(Int,PortName)]))) -> [((NodeNr,PortName),(Int,Int))]
837 ;f (_,(_ ,([]))) = []
838 ;f(nodeNr,(node_i,((port_i,port) : l ))) = [((nodeNr,port),(node_i,port_i))] ++ f (nodeNr,(node_i,( l )))
839 getOther :: [((NodeNr,PortName),(Int,Int))] -> (Int,Int) -> (NodeNr,PortName)
840 getOther (((nr,p),(ni,pi)) :l) (a,b) | (b == ni) && (a==pi) = (nr,p)
841 | otherwise = getOther l (a,b)
842 newConections :: ([((NodeNr,PortName),(Int,Int))],[((NodeNr,PortName),(Int,Int))]) ->[((NodeNr,PortName),(NodeNr,PortName))]
843 newConections ([],_) = []
844 newConections ((((nr,p),(ni,pi)) :l), ll) = [((nr,p), getOther ll (ni,pi) ) ] ++ (newConections (l,ll))
847 chooseAgentsDialog :: InfoKind n g => State g n e
848 -> IO ( Maybe (String, String, CopyLHS2RHS))
849 chooseAgentsDialog state =
850 do theFrame <- getNetworkFrame state
851 pDoc <- getDocument state
852 doc <- PD.getDocument pDoc
854 -- palette without interface symbol
855 let pal = filter ( (/= fst interfaceSymbol).fst )
856 . shapes $ getPalette doc
860 do warningDialog theFrame "No symbols" "There are no symbols other than interface one.\nAdd symbol first."
863 do let palette = Palette pal
864 -- no button was pressed
865 setShape1 Nothing state
866 setShape2 Nothing state
869 dia <- dialog theFrame [ text := "Rule creation wizard"]
875 ok <- button p [ text := "Ok"
880 let rinfo = [ ("all nodes", Everything)
881 , ( "just interface nodes", JustInterface)
882 , ("nothing", DontCopy)
883 , ("Rule template",DefaultRule)
885 (rlabels, rdata) = unzip rinfo
886 r1 <- radioBox p Vertical rlabels
887 [ text := "What to copy automatically from LHS to RHS ?"
892 ca <- button p [ text := "Cancel" ]
894 ;set r1 [ on select ::= logSelect pal p2 state (onClick r1 setJustShape2)]
897 reallyBuildVisiblePalette palette p1 state $ onClick r1 setJustShape1
898 reallyBuildVisiblePalette palette p2 state $ onClick r1 setJustShape2
901 set dia [ layout := container p $
903 column 5 [ label "Choose one symbol in each palette."
908 , row 5 [widget ok, widget ca]
913 showModal dia $ \stop ->
914 do set ok [on command :=
915 do mAgent1 <- getShape1 state
916 mAgent2 <- getShape2 state
917 i <- get r1 selection
918 let res = (fromJust mAgent1, fromJust mAgent2, rdata !! i)
921 set ca [on command := stop Nothing ]
923 where setJustShape1 = setShape1 . Just
924 setJustShape2 = setShape2 . Just
925 onClick r1 func name state =
927 mAgent1 <- getShape1 state
928 mAgent2 <- getShape2 state
929 i <- get r1 selection
930 okButton <- getOkButton state
931 set okButton [ enabled := if (i==3) then (((fromMaybe "" mAgent2) `elem` ["Erase","duplicator","copy"] ) && isJust mAgent1)
932 else (isJust mAgent1 && isJust mAgent2)
934 logSelect pal p2 state f w
935 = do ;i <- get w selection
936 ;mAgent2 <- getShape2 state
937 ;mAgent1 <- getShape1 state
938 ;okButton <- getOkButton state
940 then do ;set okButton [enabled := (fromMaybe "" mAgent2) `elem` ["Erase","duplicator","copy"] ]
941 ;let specialPalette = filter (\x -> (fst x) == "Erase" || (fst x) == "duplicator" || (fst x) == "copy" ) pal
942 ;if (null specialPalette)
943 then do ;theFrame <- getNetworkFrame state
944 ;errorDialog theFrame "Not Defined" "No rules defined for any of the symbols in the pallete"
945 ;set w [selection := 1]
946 else do{ ; windowChildren p2 >>= mapM objectDelete
948 ;reallyBuildVisiblePalette (Palette specialPalette) n state f
950 else do {;set okButton [enabled := (isJust mAgent1 && isJust mAgent2) ]
951 ; windowChildren p2 >>= mapM objectDelete
953 ;reallyBuildVisiblePalette (Palette pal) n state f
960 createAgentByNameDialog :: State g n e -> IO (Maybe (String, Shape, [Port]))
961 createAgentByNameDialog state =
962 do theFrame <- getNetworkFrame state
963 pDoc <- getDocument state
964 doc <- PD.getDocument pDoc
966 -- palette shape names
967 let paletteNames = map fst . shapes $ getPalette doc
970 diaW <- dialog theFrame [ text := "Create new symbol"
973 , clientSize := sz 200 300
979 agent1 <- entry p1 [text := "Symbol name"]
980 -- set agent [ on keyboard := \k -> do propagateEvent
981 -- agentD <- get agent text
982 -- if agentD `elem` paletteNames
983 -- then set agent [bgcolor := red]
984 -- else set agent [bgcolor := green] ]
985 symb1 <- entry p1 [text := "Displayed name" ]
986 -- set symb [ on keyboard := \k -> do propagateEvent
987 -- set symb [ bgcolor := green ]
989 portsC1 <- textCtrl p1 [text := "[ (\"port_name\", DoublePoint 0.3 (-0.3))\n]" ]
990 -- set portsC [ on keyboard := \k -> do propagateEvent
991 -- portsT <- get portsC text
992 -- case (reads :: ReadS [Port] ) portsT of
993 -- [(ports,"")] -> do set portsC [ bgcolor := green]
995 -- _ -> set portsC [ bgcolor := red]
998 agent2 <- entry p2 [text := "Symbol name"]
999 symb2 <- entry p2 [text := "Displayed name" ]
1000 portsC2 <- textCtrl p2 [text := "[ (\"port_name\", DoublePoint 0.3 (-0.3))\n]" ]
1003 symbs3 <- radioBox p3 Vertical (map fst $ shapes managementSymbols)
1004 [ text := "Management symbols:"
1008 let (width, height) = (10,10)
1011 [ virtualSize := sz (logicalToScreenX ppi width)
1012 (logicalToScreenY ppi height)
1013 , clientSize := sz 300 50
1014 , fullRepaintOnResize := False
1015 , bgcolor := wxcolor paneBackgroundColor
1016 , on paint := \dc r -> safetyNet theFrame $
1017 do page <- notebookGetSelection nb
1019 0 -> -- Standard symbol
1020 do { symbD <- get symb1 text
1021 ; portsT <- get portsC1 text
1023 ; case (reads :: ReadS [Port] ) portsT of
1025 if haveRepeateds (map fst ports)
1026 then logMessage "port names repeated"
1029 TextInEllipse { shapeStyle = defaultShapeStyle
1030 , shapeText = symbD}
1032 drawFig dc r shape ports []
1034 _ -> logMessage "bad parsing in ports" -- return ()
1036 1 -> -- Syntactical symbol
1037 do { symbD <- get symb2 text
1038 ; portsT <- get portsC2 text
1039 ; case (reads :: ReadS [Port] ) portsT of
1041 if haveRepeateds (map fst ports)
1042 then logMessage "port names repeated"
1045 Composite { shapeSegments =
1047 { shapeStyle = defaultShapeStyle
1049 [ DoublePoint 0 (-0.7)
1050 , DoublePoint (-0.7) 0.15
1051 , DoublePoint 0.7 0.15
1054 , Text { shapeStyle = defaultShapeStyle
1055 , shapeText = symbD} ]}
1056 drawFig dc r shape ports []
1057 _ -> logMessage "bad parsing in ports" -- return ()
1059 2 -> -- Management symbol
1060 do i <- get symbs3 selection
1061 let (shape, ports, _) = snd $ (shapes managementSymbols) !! i
1062 drawFig dc r shape ports []
1064 set agentG [ on mouse := \p -> repaint agentG
1065 , on keyboard := \k -> repaint agentG
1068 test <- button p [text := "Test", on command := repaint agentG]
1070 ok <- button p [ text := "Ok"]
1071 ca <- button p [ text := "Cancel" ]
1073 set diaW [ layout := container p $
1079 [ tab "Standard" . container p1 .
1081 [[label "Symbol name", hfill $ widget agent1]
1082 ,[label "Symbol displayed name", hfill $ widget symb1]
1083 ,[label "list of ports", hfill $ widget portsC1]]
1084 , tab "Syntactical" . container p2 .
1086 [[label "Symbol name", hfill $ widget agent2]
1087 ,[label "Symbol displayed name", hfill $ widget symb2]
1088 ,[label "list of ports", hfill $ widget portsC2]]
1089 , tab "Management" . container p3 . fill $ widget symbs3
1091 , hfill $ widget test
1092 , fill $ widget agentG
1093 , floatBottomRight $ row 5 [widget ok, widget ca]
1097 showModal diaW $ \stop ->
1098 do set ok [on command :=
1099 do page <- notebookGetSelection nb
1101 0 -> -- Standard symbol
1102 do{ agentD <- get agent1 text
1103 ; symbD <- get symb1 text
1104 ; portsT <- get portsC1 text
1106 ; if agentD `elem` paletteNames
1107 then do { errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."
1108 -- ; set agent [bgcolor := red]
1111 if agentD `elem` map fst (shapes specialSymbols)
1112 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."
1114 do let shape = TextInEllipse { shapeStyle = defaultShapeStyle
1115 , shapeText = symbD}
1116 case (reads :: ReadS [Port] ) portsT of
1118 if haveRepeateds (map fst ports)
1119 then errorDialog diaW "Bad Ports" "port names repeated"
1120 else stop $ Just (agentD, shape, ports)
1121 _ -> do { errorDialog diaW "Parse error in list of Ports" "Parse error in list of Ports"
1122 -- ; set portsC [ bgcolor := red ]
1125 1 -> -- Syntactical symbol
1126 do{ agentD <- get agent2 text
1127 ; symbD <- get symb2 text
1128 ; portsT <- get portsC2 text
1130 ; if agentD `elem` paletteNames
1131 then do { errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."
1132 -- ; set agent [bgcolor := red]
1135 if agentD `elem` map fst (shapes specialSymbols)
1136 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."
1139 Composite { shapeSegments =
1141 { shapeStyle = defaultShapeStyle
1143 [ DoublePoint 0 (-0.7)
1144 , DoublePoint (-0.7) 0.15
1145 , DoublePoint 0.7 0.15
1148 , Text { shapeStyle = defaultShapeStyle
1149 , shapeText = symbD} ]}
1150 case (reads :: ReadS [Port] ) portsT of
1152 if haveRepeateds (map fst ports)
1153 then errorDialog diaW "Bad Ports" "port names repeated"
1154 else stop $ Just (agentD, shape, ports)
1155 _ -> do { errorDialog diaW "Parse error in list of Ports" "Parse error in list of Ports"
1156 -- ; set portsC [ bgcolor := red ]
1159 2 -> -- Management symbol
1160 do{ i <- get symbs3 selection
1161 ; let symb = (shapes managementSymbols) !! i
1163 (shape, ports, _) = snd symb
1164 ; if agentD `elem` paletteNames
1165 then errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."
1167 stop $ Just (agentD, shape, ports)
1170 set ca [on command := stop Nothing ]
1172 createHelpWindow :: IO ()
1174 do f <- frame [ text := "Interaction Nets editor help"
1175 , position := pt 200 20
1176 , clientSize := sz 300 240 ]
1178 hw <- htmlWindowCreate f 1 (Rect 50 150 500 150) 5 "theWindow"
1179 htmlWindowLoadPage hw "html/HowToUse.html"
1180 set f [layout := fill $ widget hw]
1182 createAboutWindow :: Frame () -> IO ()
1183 createAboutWindow f =
1184 do infoDialog f ("About " ++ toolName) $
1185 toolName ++ " is an Interaction Nets Editor.\n"
1186 ++ "The project is mainly developed by\n"
1187 ++ "Miguel Vilaca < " ++ "jmvilaca@di.uminho.pt" ++" >\n"
1188 ++ "See the project webpage at\n"
1189 ++ "http://haskell.di.uminho.pt/jmvilaca/INblobs"
1193 safeAndClear :: Window a -> TextCtrl b -> IO c -> IO ()
1194 safeAndClear theFrame textlog comp =
1195 safetyNet theFrame $ textCtrlClear textlog >> comp
1197 -- | Add text to a 'TextCtrl' putting it in the given 'Color'.
1198 addTxtOfColor2TextCtrl :: Color -> TextCtrl () -> String -> IO ()
1199 addTxtOfColor2TextCtrl color txt str =
1201 start <- textCtrlGetInsertionPoint txt
1202 textCtrlAppendText txt str
1203 end <- textCtrlGetInsertionPoint txt
1204 style <- textAttrCreateDefault
1205 textAttrSetTextColour style color
1206 textCtrlSetStyle txt start end style
1209 addError2TextCtrl, addGood2TextCtrl :: TextCtrl () -> String -> IO ()
1210 addError2TextCtrl = addTxtOfColor2TextCtrl red
1211 addGood2TextCtrl = addTxtOfColor2TextCtrl green
1213 -- | Add text to a 'TextCtrl' putting it in the current position.
1214 addTxtInPlace2TextCtrl :: TextCtrl () -> String -> IO ()
1215 addTxtInPlace2TextCtrl t str =
1217 pos <- textCtrlGetInsertionPoint t
1218 textCtrlSetInsertionPoint t pos
1219 textCtrlWriteText t str