Tue Feb 7 11:14:45 WET 2006 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Automatically create LHS of an interaction rule
The LHS of an interaction net rule is formed by to agents connected by their principal ports and the rest of the ports to be the interface of that net. This let the user choose the two agents and automatically create the LHS and the RHS interface, thus representing a significantly faster process of creation/edition of Interaction net systems.
{
hunk ./src/INRules.hs 16
+ , addNewEmptyRule[_^M_][_$_]
hunk ./src/INRules.hs 53
-addNewRule :: (InfoKind e g, InfoKind n g) => [_^M_][_$_]
+addNewRule :: INRule g n e -> INRules g n e -> INRules g n e[_^M_][_$_]
+addNewRule newRule rules = rules ++ [newRule][_^M_][_$_]
+[_^M_][_$_]
+addNewEmptyRule :: (InfoKind e g, InfoKind n g) => [_^M_][_$_]
hunk ./src/INRules.hs 58
-addNewRule ruleName g n e rules = [_^M_][_$_]
+addNewEmptyRule ruleName g n e rules = [_^M_][_$_]
hunk ./src/INRules.hs 60
- in rules ++ [newRule] [_^M_][_$_]
+ in addNewRule newRule rules [_^M_][_$_]
hunk ./src/NetworkUI.hs 32
-import Graphics.UI.WX hiding (Child, upKey, downKey)
+import Graphics.UI.WX hiding (Child, upKey, downKey, swap)
hunk ./src/NetworkUI.hs 35
-
+import Data.List
hunk ./src/NetworkUI.hs 676
- ; list <- mapM (drawNodeButton pp state) . shapes $ palette
- ; let table = list2Table 2 list [_$_]
+ [_$_]
+ ; reallyBuildVisiblePalette palette pp state setCurrentShape
+ }
hunk ./src/NetworkUI.hs 680
- ; set pp [layout := boxed "Palette" (grid 4 4 table) ]
- --; refit pp
+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 [_$_]
hunk ./src/NetworkUI.hs 687
- -- should redraw the all window acordingly
- --; windo <- getNetworkFrame state
- --; refit windo
+ set panel [layout := boxed "Palette" (grid 4 4 table) ]
hunk ./src/NetworkUI.hs 689
- ; return ()
- }
hunk ./src/NetworkUI.hs 690
-drawNodeButton :: InfoKind n g => Window w -> State g n e -> (String, (Shape, Maybe Ports, Maybe n)) -> IO Layout
-drawNodeButton w state (name, (shape, ports, _info)) = [_$_]
+drawNodeButton :: InfoKind n g => Window w -> State g n e -> (String -> State g n e -> IO ()) [_$_]
+ -> (String, (Shape, Maybe Ports, Maybe n)) -> IO Layout
+drawNodeButton w state action (name, (shape, ports, _info)) = [_$_]
hunk ./src/NetworkUI.hs 694
- ; doc <- getDocument state
hunk ./src/NetworkUI.hs 696
- , on command := setCurrentShape name state
+ , on command := action name state
hunk ./src/NetworkUI.hs 788
- , on command := safetyNet theFrame $ addNewRuleItem state g n e
+ , on command := safetyNet theFrame $ addNewRuleItem state $ initial g n e
hunk ./src/NetworkUI.hs 790
+ menuItem contextMenu [_$_]
+ [ text := "Create new Interaction Net rule"
+ , on command := safetyNet theFrame $ createRuleItem theFrame state g n e
+ ]
hunk ./src/NetworkUI.hs 802
- $ removeRuleItem state ruleName
+ $ removeRuleItem state ruleName item
hunk ./src/NetworkUI.hs 813
--- | Create a new empty rule with a new name.
+-- | Adds a new rule setting it with a new name.
hunk ./src/NetworkUI.hs 815
- State g n e -> g -> n -> e -> IO ()
-addNewRuleItem state g n e = [_$_]
+ State g n e -> INRule g n e -> IO ()
+addNewRuleItem state newRule = [_$_]
hunk ./src/NetworkUI.hs 818
- PD.updateDocument "add rule" (updateRules $ addNew 1) pDoc
- reAddRules2Tree state
- where -- addNew :: Int -> INRules g n e -> INRules g n e
- addNew i rules =
- let newName = "Rule " ++ show i [_$_]
- in case findRule newName rules of
- Just _ -> addNew (i+1) rules
- Nothing -> INRules.addNewRule newName g n e rules [_$_]
+ doc <- PD.getDocument pDoc
+ [_$_]
+ let newName = addNew 1 . rulesNames $ getRules doc
+
+ PD.updateDocument "add rule" [_$_]
+ (updateRules $ addNewRule $ INRule.setName newName $ 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 [_$_]
hunk ./src/NetworkUI.hs 835
- State g n e -> String -> IO ()
-removeRuleItem state ruleName = [_$_]
+ State g n e -> String -> TreeItem -> IO ()
+removeRuleItem state ruleName item = [_$_]
hunk ./src/NetworkUI.hs 838
+ tree <- getTree state
hunk ./src/NetworkUI.hs 845
- reAddRules2Tree state [_$_]
+ treeCtrlDelete tree item [_$_]
hunk ./src/NetworkUI.hs 861
- (updateRules $ addNewRule "Rule 1" g n e) pDoc
+ (updateRules $ addNewEmptyRule "Rule 1" g n e) pDoc
hunk ./src/NetworkUI.hs 887
+
+data CopyLHS2RHS = Everything | JustInterface | DontCopy deriving (Show)
+
+-- | Create a dialog where the user have to choose to agents. [_$_]
+-- 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{ let (agent1, agent2, copyOption) = fromJust maybeRes
+ copy = case copyOption of [_$_]
+ Everything -> copyLHS2RHS [_$_]
+ JustInterface -> copyLHSInterface2RHS [_$_]
+ DontCopy -> id
+ [_$_]
+ ; pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let palette = getPalette doc
+ (nNr1, lhs1) = addNode agent1 palette [_$_]
+ $ Network.empty g n e
+ (nNr2, lhs2) = addNode agent2 palette lhs1
+ [_$_]
+ ; (pP1:ports1) <- getPorts' agent1 palette
+ ; (pP2:ports2) <- getPorts' agent2 palette
+
+ -- edge connecting principal ports
+ ; let lhs3 = addEdge nNr1 (Just pP1) nNr2 (Just pP2) lhs2
+ [_$_]
+ (pos1, pos2) = givePositions pP1 pP2 -- (DoublePoint 2.0 2.0, DoublePoint 6.0 3.0) -- ??
+ lhs4 = setNodePosition nNr1 pos1 [_$_]
+ . setNodePosition nNr2 pos2 $ lhs3
+
+ -- adding as many interface nodes as needed
+ (nrs1, lhs5) = addNodes "interface" palette (length ports1) lhs4
+ (nrs2, lhs6) = addNodes "interface" palette (length ports2) lhs5
+
+ ; interPort <- getInterfacePort palette
+ [_$_]
+ -- choose interface agents better positions; up or down
+ ; let (ups1, downs1) = (map snd >< map snd ) . partition sep $ zip ports1 nrs1
+ (ups2, downs2) = (map snd >< map snd ) . partition sep $ zip ports2 nrs2
+ orderConcat = chooseOrder pos1 pos2
+ [_$_]
+ -- add edges between not principal ports in agents to interface nodes and set their positions [_$_]
+ lhs7 = specialFoldl (DoublePoint 0.5 5.5) (orderConcat downs1 downs2)
+ . specialFoldl (DoublePoint 0.5 0.5) (orderConcat ups1 ups2)
+ . addEdgesWithJustPort -- edges agent2 to interface
+ [((nNr2, p'), (n', interPort)) | p' <- ports2 | n' <- nrs2] [_$_]
+ . addEdgesWithJustPort -- edges agent1 to interface
+ [((nNr1, p'), (n', interPort)) | p' <- ports1 | n' <- nrs1] $ lhs6
+
+ ; let rhs = Network.empty g n e
+ mapping = [] [_$_]
+ ; addNewRuleItem state . copy $ construct "" lhs7 rhs mapping
+ }
+ where getPorts' :: String -> Palette.Palette n -> IO Ports
+ getPorts' shape (Palette palette) = [_$_]
+ case Data.List.lookup shape palette of [_$_]
+ Nothing -> fail $ shape ++ " agent is missing." [_$_]
+ Just e -> case snd3 e of [_$_]
+ Nothing -> fail $ shape ++ " agent without port."
+ Just [] -> fail $ shape ++ " agent without port."
+ Just ps -> return ps
+
+ getInterfacePort :: Palette.Palette n -> IO Port
+ getInterfacePort palette = [_$_]
+ do ps <- getPorts' "interface" palette
+ case ps of [_$_]
+ [port] -> return port
+ _ -> fail "Interface port with more than one port."
+ givePositions :: Port -> Port -> (DoublePoint, DoublePoint)
+ givePositions port1 port2 = g (portZone port1) (portZone port2)
+ where g Ztop Ztop = lineH
+ g Zbottom Zbottom = lineH
+ g Zleft Zleft = lineV
+ g Zright Zright = lineV
+ g Ztop Zbottom = invert lineV
+ g Zbottom Ztop = lineV
+ g Zleft Zright = invert lineH
+ g Zright Zleft = lineH
+ g Ztop Zleft = invert lineI
+ g Ztop Zright = invert lineD
+ g Zbottom Zleft = lineD
+ g Zbottom Zright = lineI
+ g Zleft Ztop = lineI
+ g Zleft Zbottom = invert lineD
+ g Zright Ztop = lineD
+ g Zright Zbottom = invert lineI
+ [_$_]
+ c1 = 2.0
+ c2 = 4.0 [_$_]
+ p1 = DoublePoint c1 c1
+ p2 = DoublePoint c2 c1
+ p3 = DoublePoint c1 c2
+ p4 = DoublePoint c2 c2
+ lineH = (p1, p2)
+ lineV = (p1, p3)
+ lineD = (p1, p4)
+ lineI = (p2, p3)
+ invert = swap
+
+ sep :: (Port, NodeNr) -> Bool
+ sep (port, _) = isUp port
+ chooseOrder pos1 pos2 = if doublePointX pos1 <= doublePointX pos2
+ then (++)
+ else flip (++)
+
+ specialFoldl :: DoublePoint -> [NodeNr] -> Network g n e -> Network g n e
+ specialFoldl startingPoint nodes net = snd $ foldl gene (startingPoint, net) nodes
+ gene :: (DoublePoint, Network g n e) -> NodeNr -> (DoublePoint, Network g n e)
+ gene (actual, oldNet) nNr = (translate actual diff, setNodePosition nNr actual oldNet)
+ diff = DoublePoint 1.0 0.0
+
+
+ [_$_]
+
+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 agent
+ let palette = Palette . filter ( (/= "interface").fst ) [_$_]
+ . shapes $ getPalette doc
+
+ -- no button was pressed
+ setShape1 Nothing state
+ setShape2 Nothing state
+
+ -- create Dialog [_$_]
+ dia <- dialog theFrame [ text := "Choose agents", visible := True]
+ p <- panel dia []
+ p1 <- panel p []
+ p2 <- panel p []
+
+ reallyBuildVisiblePalette palette p1 state $ onClick setJustShape1 [_$_]
+ reallyBuildVisiblePalette palette p2 state $ onClick setJustShape2
+
+ let rinfo = [ ("all nodes", Everything)
+ , ( "just interface nodes", JustInterface)
+ , ("nothing", DontCopy) [_$_]
+ ]
+ (rlabels, rdata) = unzip rinfo
+ r1 <- radioBox p Vertical rlabels [_$_]
+ [ text := "What to copy automatically from LHS to RHS ?"
+ , selection := 1 ]
+
+ ok <- button p [ text := "Ok"
+ , enabled := False [_$_]
+ ]
+ setOkButton ok state
+
+ ca <- button p [ text := "Cancel" ]
+
+
+ set dia [ layout := container p $ [_$_]
+ margin 10 $ [_$_]
+ column 5 [ label "Choose one agent in each palette."
+ , widget p1
+ , 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)
hunk ./src/NetworkUI.hs 1067
+ stop (Just res) ]
+ set ca [on command := stop Nothing ]
+ [_$_]
+ where setJustShape1 = setShape1 . Just [_$_]
+ setJustShape2 = setShape2 . Just
+ onClick func name state = [_$_]
+ do func name state
+ mAgent1 <- getShape1 state
+ mAgent2 <- getShape2 state
+ okButton <- getOkButton state
+ set okButton [ enabled := isJust mAgent1 && isJust mAgent2]
hunk ./src/Ports.hs 1
-module Ports where[_^M_][_$_]
+module Ports [_^M_][_$_]
+ ( Port[_^M_][_$_]
+ , Ports[_^M_][_$_]
+ , PortZone(..)[_^M_][_$_]
hunk ./src/Ports.hs 6
+ , isTheSameAs[_^M_][_$_]
+ , isInterfacePort[_^M_][_$_]
+ , drawPorts[_^M_][_$_]
+ , drawPort [_^M_][_$_]
+ , drawPrincipalPort [_^M_][_$_]
+ , portZone [_^M_][_$_]
+ , isUp[_^M_][_$_]
+ ) where[_^M_][_$_]
+[_^M_][_$_]
hunk ./src/Ports.hs 82
+data PortZone = Ztop | Zbottom | Zleft | Zright deriving (Show)[_^M_][_$_]
+[_^M_][_$_]
+-- | Divides the 2D space with y=x and y=-x rects [_^M_][_$_]
+portZone :: Port -> PortZone[_^M_][_$_]
+portZone (_, DoublePoint x y) | y > x && y <= -x = Zleft[_^M_][_$_]
+ | y >= x && y > -x = Zbottom[_^M_][_$_]
+ | y < x && y >= -x = Zright[_^M_][_$_]
+ | y <= x && y < -x = Ztop[_^M_][_$_]
+[_^M_][_$_]
+-- | A different division in 2D space; the port is in the upper part of the node?[_^M_][_$_]
+isUp :: Port -> Bool[_^M_][_$_]
+isUp (_, DoublePoint _ y) = y <= 0[_^M_][_$_]
hunk ./src/State.hs 20
+ , getShape1, setShape1
+ , getShape2, setShape2
+ , getOkButton, setOkButton
hunk ./src/State.hs 51
+ , stShape1 :: Maybe String -- ^ a shape name
+ , stShape2 :: Maybe String -- ^ a shape name
+ , stOkButton :: Button () [_$_]
hunk ./src/State.hs 77
+ , stShape1 = Nothing
+ , stShape2 = Nothing
hunk ./src/State.hs 123
+getShape1 :: State g n e -> IO (Maybe String )
+getShape1 = getFromState stShape1
+
+getShape2 :: State g n e -> IO (Maybe String )
+getShape2 = getFromState stShape2
+
+getOkButton :: State g n e -> IO (Button () )
+getOkButton = getFromState stOkButton
+
hunk ./src/State.hs 193
+
+setShape1 :: Maybe String -> State g n e -> IO ()
+setShape1 shape1 stateRef =
+ varUpdate_ stateRef (\state -> state { stShape1 = shape1 })
+
+setShape2 :: Maybe String -> State g n e -> IO ()
+setShape2 shape2 stateRef =
+ varUpdate_ stateRef (\state -> state { stShape2 = shape2 })
+
+setOkButton :: Button () -> State g n e -> IO ()
+setOkButton okButton stateRef =
+ varUpdate_ stateRef (\state -> state { stOkButton = okButton })
}