INblobs-0.1.1: src/CommonUI.hs
{-# 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.Parse as Parse
import INChecks
import SpecialSymbols
import Graphics.UI.WX hiding (Child, upKey, downKey, swap)
import Graphics.UI.WXCore hiding (Document, Palette)
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, map rem3 mPorts , info)
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, 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
, on mouse := \ev -> safetyNet frame $ mouseSymbol ev name action state
, tooltip := name
, 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
mouseSymbol :: InfoKind n g => EventMouse -> String -> (String -> State g n e -> IO ()) -> State g n e -> IO ()
mouseSymbol mouseEV name action state =
case mouseEV of
MouseLeftUp _ _ -> action name state
MouseRightUp _ _ -> removeSymbolUI name state
_ -> return ()
-- | 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, ports, Nothing))
; PD.updateDocument "change palette"
(\doc -> setPalette (Palette . (++ [newElem]) . shapes . getPalette $ doc)
doc)
pDoc
; setCurrentShape (agentName) state
; buildVisiblePalette state
}
_ -> return ()
removeSymbolUI :: (InfoKind n g) => String -> State g n e -> IO ()
removeSymbolUI name state =
when (name /= "interface") $
do contextMenu <- menuPane []
menuItem contextMenu
[ text := "Remove symbol"
, on command := removeSymbol name state
]
theFrame <- getNetworkFrame state
pointWithinWindow <- windowGetMousePosition theFrame
menuPopup contextMenu pointWithinWindow theFrame
objectDelete contextMenu
-- | Removes a symbol if it is not used or else don't remove and list its occurrences.
removeSymbol :: (InfoKind n g) => String -> State g n e -> IO ()
removeSymbol name state =
do theFrame <- getNetworkFrame state
if name == "interface"
then warningDialog theFrame "Deletion forbidden" "Interface symbol is a special one that can't be deleted."
else
do
pDoc <- getDocument state
doc <- PD.getDocument pDoc
let newpal = deleteShape name $ getPalette doc
symbs = map fst . shapes $ newpal
errors = undefinedAgents symbs doc
if Map.null errors
then do -- symbol can be safely removed
remove <- confirmDialog theFrame "Symbol deletion"
("Symbol \"" ++ name ++
"\" can be safely removed.\nAre you sure you want to delete it?")
False
if remove
then do PD.updateDocument ("Symbol " ++ name ++ " removed") (setPalette newpal) pDoc
buildVisiblePalette state
else return ()
else -- there are occurrences of symbol; list them
errorDialog theFrame "Deletion forbidden" $
"Symbol \"" ++ name ++
"\" can't be deleted because there are the following occurrences of it in the IN system:\n"
++ (unlines . map show $ Map.keys errors)
-- | 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.updateDocument ("add rule <<" ++ newName ++ ">>")
(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 palette = getPalette doc
;let ;(agent1, agent2, copyOption) = fromJust maybeRes
;copy = case copyOption of
Everything -> copyLHS2RHS
JustInterface -> copyLHSInterface2RHS
DontCopy -> id
DefaultRule -> defaultRuleSelector (agent1,agent2) state g n e palette
; (rule,nNr1,nNr2) <- createRuleWizard g n e palette agent1 agent2
; addNewRuleItem False state $ copy rule
}
-- An interaction net rule, whose left hand side is the active pair
-- of the two given agents, will be created.
-- A new name is created for this rule.
-- Empty RHS.
createRuleWizard :: (InfoKind n g, InfoKind e g) =>
g -> n -> e -> Palette n
-> String -> String -> IO (INRule g n e, NodeNr, NodeNr)
createRuleWizard g n e palette agent1 agent2 =
do{
; let
(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
-- edge connecting principal ports
; let lhs3 = addEdge palette nNr1 (fst pP1) nNr2 (fst 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 = rowNodes (DoublePoint 0.5 5.5) (orderConcat downs1 downs2)
. rowNodes (DoublePoint 0.5 0.5) (orderConcat ups1 ups2)
. addEdges palette -- edges agent2 to interface
[((nNr2, fst p'), (n', fst interPort)) | p' <- ports2 | n' <- nrs2]
. addEdges palette -- edges agent1 to interface
[((nNr1, fst p'), (n', fst interPort)) | p' <- ports1 | n' <- nrs1] $ lhs6
; let rhs = Network.empty g n e
mapping = []
; return (construct (agent1 ++ "_" ++ agent2) lhs7 rhs mapping, nNr1,nNr2)
}
where getPorts' = getSymbolPorts
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 (++)
getSymbolPorts :: String -> Palette.Palette n -> IO Ports
getSymbolPorts shape (Palette palette) =
case Data.List.lookup shape palette of
Nothing -> fail $ shape ++ " agent is missing."
Just e -> case snd3 e of
[] -> fail $ shape ++ " agent without port."
ps -> return ps
-- | For a list of nodes placed at the same position, change their positions to form a row.
rowNodes :: DoublePoint -> [NodeNr] -> Network g n e -> Network g n e
rowNodes 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 = rowNodes (DoublePoint 1.0 1.0) erasers rhs1
;rhs3 = addEdges palette (mix (map fst inter) erasers) rhs2
in (construct ("T:Erase_"++a1) lhs rhs3 (getMapping newRule))
where
mix [] [] = []
mix (x:y ) (a:b) = [((x, "interface"),(a, "down")) ]++ 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
(spas,rhs2) = addNodes a2 palette ((\x -> x-1) . length . snd3 . takeJust "Undefined symbol" $ getSymbol a1 palette) rhs1
rhs3 = rowNodes (DoublePoint 1.0 4.0) spas $ (rowNodes (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 :: [((NodeNr, PortName), (NodeNr, PortName))]
newC = newConections $ makeConnection alphas spas rhs4
rhs5 = addEdges palette newC rhs4
in (construct ('T':':':a2++'_':a1) 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 addEdges palette (zip (zip inter pp_i) (zip node pp_n)) ne
;getInterfaceList nodes ne = map (const "interface") nodes
-- ; getJustPorts :: Network g n e -> NodeNr -> [PortName]
; getJustPorts ne y = map fst . fromJust $ getPorts palette ne y
-- ;makeConnection :: [NodeNr] -> [NodeNr] -> Network g n e ->([((NodeNr,PortName),(Int,Int))] , [((NodeNr,PortName),(Int,Int))])
;makeConnection alphs sps ne = let
;alp_p :: [[PortName]]
;alp_p = map (reverse . drop 1 . getJustPorts 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 . getJustPorts 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,PortName)]))) -> [((NodeNr,PortName),(Int,Int))]
;f (_,(_ ,([]))) = []
;f(nodeNr,(node_i,((port_i,port) : l ))) = [((nodeNr,port),(node_i,port_i))] ++ f (nodeNr,(node_i,( l )))
getOther :: [((NodeNr,PortName),(Int,Int))] -> (Int,Int) -> (NodeNr,PortName)
getOther (((nr,p),(ni,pi)) :l) (a,b) | (b == ni) && (a==pi) = (nr,p)
| otherwise = getOther l (a,b)
newConections :: ([((NodeNr,PortName),(Int,Int))],[((NodeNr,PortName),(Int,Int))]) ->[((NodeNr,PortName),(NodeNr,PortName))]
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 one.\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 []
ok <- button p [ text := "Ok"
, enabled := False
]
setOkButton ok state
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)]
reallyBuildVisiblePalette palette p1 state $ onClick r1 setJustShape1
reallyBuildVisiblePalette palette p2 state $ onClick r1 setJustShape2
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
}
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 []
nb <- notebook p []
p1 <- panel nb []
agent1 <- entry p1 [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] ]
symb1 <- entry p1 [text := "Displayed name" ]
-- set symb [ on keyboard := \k -> do propagateEvent
-- set symb [ bgcolor := green ]
-- repaint agentG
portsC1 <- textCtrl p1 [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]
p2 <- panel nb []
agent2 <- entry p2 [text := "Symbol name"]
symb2 <- entry p2 [text := "Displayed name" ]
portsC2 <- textCtrl p2 [text := "[ (\"port_name\", DoublePoint 0.3 (-0.3))\n]" ]
p3 <- panel nb []
symbs3 <- radioBox p3 Vertical (map fst $ shapes managementSymbols)
[ text := "Management symbols:"
, selection := 1
]
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 page <- notebookGetSelection nb
case page of
0 -> -- Standard symbol
do { symbD <- get symb1 text
; portsT <- get portsC1 text
; case (reads :: ReadS [Port] ) portsT of
[(ports,"")] ->
if haveRepeateds (map fst ports)
then logMessage "port names repeated"
else
do let shape =
TextInEllipse { shapeStyle = defaultShapeStyle
, shapeText = symbD}
drawFig dc r shape ports []
_ -> logMessage "bad parsing in ports" -- return ()
}
1 -> -- Syntactical symbol
do { symbD <- get symb2 text
; portsT <- get portsC2 text
; case (reads :: ReadS [Port] ) portsT of
[(ports,"")] ->
if haveRepeateds (map fst ports)
then logMessage "port names repeated"
else
do let shape =
Composite { shapeSegments =
[ Polygon
{ shapeStyle = defaultShapeStyle
, shapePerimeter =
[ DoublePoint 0 (-0.7)
, DoublePoint (-0.7) 0.15
, DoublePoint 0.7 0.15
]
}
, Text { shapeStyle = defaultShapeStyle
, shapeText = symbD} ]}
drawFig dc r shape ports []
_ -> logMessage "bad parsing in ports" -- return ()
}
2 -> -- Management symbol
do i <- get symbs3 selection
let (shape, ports, _) = snd $ (shapes managementSymbols) !! i
drawFig dc r shape ports []
]
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
[
label "New symbol"
, tabs nb
[ tab "Standard" . container p1 .
fill $ grid 5 5
[[label "Symbol name", hfill $ widget agent1]
,[label "Symbol displayed name", hfill $ widget symb1]
,[label "list of ports", hfill $ widget portsC1]]
, tab "Syntactical" . container p2 .
fill $ grid 5 5
[[label "Symbol name", hfill $ widget agent2]
,[label "Symbol displayed name", hfill $ widget symb2]
,[label "list of ports", hfill $ widget portsC2]]
, tab "Management" . container p3 . fill $ widget symbs3
]
, hfill $ widget test
, fill $ widget agentG
, floatBottomRight $ row 5 [widget ok, widget ca]
]
]
showModal diaW $ \stop ->
do set ok [on command :=
do page <- notebookGetSelection nb
case page of
0 -> -- Standard symbol
do{ agentD <- get agent1 text
; symbD <- get symb1 text
; portsT <- get portsC1 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 (shapes 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,"")] ->
if haveRepeateds (map fst ports)
then errorDialog diaW "Bad Ports" "port names repeated"
else stop $ Just (agentD, shape, ports)
_ -> do { errorDialog diaW "Parse error in list of Ports" "Parse error in list of Ports"
-- ; set portsC [ bgcolor := red ]
}
}
1 -> -- Syntactical symbol
do{ agentD <- get agent2 text
; symbD <- get symb2 text
; portsT <- get portsC2 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 (shapes 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 =
Composite { shapeSegments =
[ Polygon
{ shapeStyle = defaultShapeStyle
, shapePerimeter =
[ DoublePoint 0 (-0.7)
, DoublePoint (-0.7) 0.15
, DoublePoint 0.7 0.15
]
}
, Text { shapeStyle = defaultShapeStyle
, shapeText = symbD} ]}
case (reads :: ReadS [Port] ) portsT of
[(ports,"")] ->
if haveRepeateds (map fst ports)
then errorDialog diaW "Bad Ports" "port names repeated"
else stop $ Just (agentD, shape, ports)
_ -> do { errorDialog diaW "Parse error in list of Ports" "Parse error in list of Ports"
-- ; set portsC [ bgcolor := red ]
}
}
2 -> -- Management symbol
do{ i <- get symbs3 selection
; let symb = (shapes managementSymbols) !! i
agentD = fst symb
(shape, ports, _) = snd symb
; if agentD `elem` paletteNames
then errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."
else
stop $ Just (agentD, shape, ports)
}
]
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"
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
-- | Add text to a 'TextCtrl' putting it in the current position.
addTxtInPlace2TextCtrl :: TextCtrl () -> String -> IO ()
addTxtInPlace2TextCtrl t str =
do
pos <- textCtrlGetInsertionPoint t
textCtrlSetInsertionPoint t pos
textCtrlWriteText t str