Tue Feb 7 10:59:49 WET 2006 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Copy LHS to RHS
Adds functionalities that set the right hand side of a rule as a copy of the left hand side of the same rule: one copies everything and the other only the interface.
{
hunk ./src/Common.hs 160
+infix 6 /\
+infix 7 ><
+
+(/\) :: ( a -> b ) -> ( a -> c ) -> a -> (b,c)
+(/\) f1 f2 a = (f1 a, f2 a)
+
+(><) :: ( a -> c ) -> ( b -> d ) -> (a,b) -> (c,d)
+(><) f1 f2 (a, b) = (f1 a, f2 b)
+
+diag :: a -> (a,a)
+diag a = (a, a)
+
hunk ./src/INRule.hs 20
+ , copyLHS2RHS[_^M_][_$_]
+ , copyLHSInterface2RHS[_^M_][_$_]
hunk ./src/INRule.hs 29
+import Common[_^M_][_$_]
hunk ./src/INRule.hs 106
+copyLHS2RHS :: INRule g n e -> INRule g n e[_^M_][_$_]
+copyLHS2RHS rule = [_^M_][_$_]
+ rule { ruleRHS = lhs[_^M_][_$_]
+ , ruleMaps = map diag . map (id >< getPrincipalPort) [_^M_][_$_]
+ . filter isInterfaceNode $ getNodeAssocs lhs [_^M_][_$_]
+ }[_^M_][_$_]
+ where lhs = ruleLHS rule[_^M_][_$_]
+[_^M_][_$_]
+copyLHSInterface2RHS :: INRule g n e -> INRule g n e[_^M_][_$_]
+copyLHSInterface2RHS rule = [_^M_][_$_]
+ rule { ruleRHS = setNodeAssocs lhs' $ ruleRHS rule [_^M_][_$_]
+ , ruleMaps = map diag . map (id >< getPrincipalPort) $ lhs'[_^M_][_$_]
+ }[_^M_][_$_]
+ where lhs' = filter isInterfaceNode . getNodeAssocs $ ruleLHS rule[_^M_][_$_]
+ [_^M_][_$_]
hunk ./src/INRule.hs 123
-addMapping = insert [_^M_][_$_]
+addMapping = insert [_^M_][_$_]
+[_^M_][_$_]
+-- auxiliar functions[_^M_][_$_]
+isInterfaceNode :: (NodeNr, Node n) -> Bool[_^M_][_$_]
+isInterfaceNode (_, node) = case getShape node of[_^M_][_$_]
+ Left "interface" -> True[_^M_][_$_]
+ _ -> False[_^M_][_$_]
+[_^M_][_$_]
+getPrincipalPort :: Node n -> Maybe Port[_^M_][_$_]
+getPrincipalPort = maybe Nothing (Just. head) . getPorts[_^M_][_$_]
+ [_^M_][_$_]
hunk ./src/Network.hs 11
+ , Network.isEmpty
hunk ./src/Network.hs 39
- , addEdge, addEdges, removeEdge
+ , addEdge, addEdges, removeEdge, addEdgesWithPort, addEdgesWithJustPort
hunk ./src/Network.hs 385
+-- | Check if a network is empty. A network is empty is it has no nodes.
+isEmpty :: Network g n e -> Bool
+isEmpty = IntMap.isEmpty . networkNodes [_$_]
+
hunk ./src/Network.hs 466
+
+addEdgesWithPort :: InfoKind e g => [( (NodeNr, Maybe Port), (NodeNr, Maybe Port) )] [_$_]
+ -> Network g n e -> Network g n e
+addEdgesWithPort edgeTuples network =
+ foldr (\((fromNr, fromMPort), (toNr, toMPort)) net -> addEdge fromNr fromMPort toNr toMPort net) [_$_]
+ network edgeTuples
+ [_$_]
+addEdgesWithJustPort :: InfoKind e g => [( (NodeNr, Port), (NodeNr, Port) )] [_$_]
+ -> Network g n e -> Network g n e
+addEdgesWithJustPort = addEdgesWithPort . map ( (id >< Just) >< (id >< Just) )
hunk ./src/NetworkUI.hs 81
+ ****** lhs2rhsB :: Button ()
hunk ./src/NetworkUI.hs 87
- do{ theFrame <- frame [ text := "Diagram editor"
+ do{ theFrame <- frame [ text := "Interaction Nets editor"
hunk ./src/NetworkUI.hs 168
+
+ -- buttons to copy LHS to RHS
+ ; lhs2rhsB <- button ruleRHSPan [ text := "==>"
+ , tooltip := "Copy the LHS network to the RHS."
+ , on command := safetyNet theFrame [_$_]
+ $ lhs2rhsItem True state
+ ]
+ -- only copies the interface
+ ; lhsInt2rhsB <- button ruleRHSPan [ text := "=->"
+ , tooltip := "Copy the LHS interface to the RHS."
+ , on command := safetyNet theFrame [_$_]
+ $ lhs2rhsItem False state
+ ]
hunk ./src/NetworkUI.hs 392
- (container ruleRHSPan $ boxed "RHS" $ fill $ widget canvasRHS) )
+ (container ruleRHSPan $ row 5 [ vstretch $ valignCenter $ column 5 [ widget lhs2rhsB
+ , widget lhsInt2rhsB ]
+ , boxed "RHS" $ fill $ widget canvasRHS [_$_]
+ ] ) )
hunk ./src/NetworkUI.hs 734
- do{ item <- treeCtrlAppendItem tree item ruleName noImage noImage objectNull [_$_]
- ; return ()
- }
+ treeCtrlAppendItem tree item ruleName noImage noImage objectNull [_$_]
hunk ./src/NetworkUI.hs 743
- [_$_]
hunk ./src/NetworkUI.hs 851
+
+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 not everything || 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.superficialUpdateDocument [_$_]
+ (updateRules $ updateRule rule $ copyLHSInterface2RHS) pDoc
+ repaintAll state
+ setActiveCanvas (RHS rule) state
}