Fri Apr 7 18:52:49 WEST 2006 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Reduction
This adds the interpreter;
- interactive one step reduction
- full reduction
- reduction step-by-step
{
binary ./INblobs.exe
hunk ./Makefile 28
+ src/INReduction.hs \
hunk ./Makefile 121
+src/GUIEvents.o : src/INReduction.hi
hunk ./Makefile 168
+src/NetWorkUI.o : src/INReduction.hi
hunk ./Makefile 222
+src/ContextMenu.o : src/INReduction.hi
hunk ./Makefile 290
+src/INReduction.o : src/Network.hi
+src/INReduction.o : src/Document.hi
+src/INReduction.o : src/PersistentDocument.hi
+src/INReduction.o : src/State.hi
+src/INReduction.o : src/StateUtil.hi
+src/INReduction.o : src/SafetyNet.hi
+src/INReduction.o : src/INRules.hi
+src/INReduction.o : src/INRule.hi
+src/INReduction.o : src/Ports.hi
+src/INReduction.o : src/Shape.hi
+src/INReduction.o : src/Math.hi
+src/INReduction.o : src/Common.hi
+src/INReduction.o : src/InfoKind.hi
hunk ./index.html 4
- <meta name="keywords" content="IN, Interaction Nets, editor, INblobs" />
- <meta name="description" content="Free Interaction Nets editor." />
+ <meta name="keywords" content="IN, Interaction Nets, editor, interpreter, INblobs" />
+ <meta name="description" content="Free Interaction Nets editor and interpreter." />
hunk ./index.html 10
- <h1>INblobs editor</h1>
- <h2>an editor for Interaction Nets</h2>
+ <h1>INblobs</h1>
+ <h2>An editor and interpreter for Interaction Nets</h2>
hunk ./index.html 16
- INblobs is an editor for Interaction Nets. It is in its beginings so only some features are already implemented.<p/>
+ INblobs is an editor and interpreter for Interaction Nets.<p/>
hunk ./index.html 74
- <li> In Linux, the tool give some errors when opening an INblobs file. If you press OK to this errors it will get you to a correct state.
- <li> In Linux, and due to the same problem, removing one rule crashs the aplication. Until this bug is fixed don't remove rules. [_$_]
+ <li> When reducing, the application show the rule used, but don't actualize the selection in the tree of rules. [_$_]
hunk ./src/ContextMenu.hs 15
+import INReduction
hunk ./src/ContextMenu.hs 50
- Frame () -> DoublePoint -> State g n e -> IO ()
-edge theFrame mousepoint state =
+ Frame () -> DoublePoint -> State g n e -> Bool -> IO ()
+edge theFrame mousepoint state isActivepair =
hunk ./src/ContextMenu.hs 67
+ ; menuItem contextMenu
+ [ text := "Reduce active pair"
+ , enabled := isActivepair
+ , on command := reduce state
+ ]
hunk ./src/GUIEvents.hs 15
+import INReduction
hunk ./src/GUIEvents.hs 29
+
+ ; disableReduce state
+
hunk ./src/GUIEvents.hs 42
+
+ do let toReduce = canvas == Net && isActivePair edgeNr network
+ when toReduce $
+ do button <- getReduceButton state
+ set button [enabled := True]
+
hunk ./src/GUIEvents.hs 49
- selectEdge edgeNr state
- else
+ selectEdge edgeNr state
+ else
hunk ./src/GUIEvents.hs 52
- ; ContextMenu.edge theFrame doubleMousePoint state
+ ; ContextMenu.edge theFrame doubleMousePoint state toReduce
hunk ./src/GUIEvents.hs 90
+
+ ; disableReduce state
+
hunk ./src/GUIEvents.hs 130
+
+ ; disableReduce state
+
hunk ./src/GUIEvents.hs 211
+ do disableReduce state
hunk ./src/GUIEvents.hs 216
+ do disableReduce state
hunk ./src/GUIEvents.hs 221
+ do disableReduce state
hunk ./src/GUIEvents.hs 226
+ do disableReduce state
hunk ./src/GUIEvents.hs 231
+ do disableReduce state
hunk ./src/GUIEvents.hs 236
+ do disableReduce state
hunk ./src/GUIEvents.hs 241
+ do disableReduce state
addfile ./src/INReduction.hs
hunk ./src/INReduction.hs 1
+module INReduction [_$_]
+ ( isActivePair
+ , reduce
+ , reduceAll
+ ) where
+
+import Network
+import Document
+import qualified PersistentDocument as PD
+import State
+import StateUtil
+import SafetyNet
+import INRules
+import INRule
+import Ports
+import Shape
+import Math
+import Common
+import InfoKind
+
+import Data.Maybe
+import Data.List
+
+import Graphics.UI.WXCore
+
+isActivePair :: EdgeNr -> Network g n e -> Bool [_$_]
+isActivePair edgeNr network = [_$_]
+ case (getPortFrom edge, getPortTo edge) of
+ (Just (nodeNrFrom, portFrom), Just (nodeNrTo, portTo) ) [_$_]
+ -> isPrincipalPort network nodeNrFrom portFrom
+ && isPrincipalPort network nodeNrTo portTo
+ && not (isInterfaceNode (nodeNrFrom, getNode nodeNrFrom network) ) [_$_]
+ && not (isInterfaceNode (nodeNrTo, getNode nodeNrTo network) )
+ _ -> False
+ where edge = getEdge edgeNr network
+
+-- | Reduce the selected edge in the network; one step reduction.
+reduce :: (InfoKind n g, InfoKind e g) => State g n e -> IO ()
+reduce state = [_$_]
+ do pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ theFrame <- getNetworkFrame state
+
+ safetyNet theFrame $
+
+ case getSelection doc of
+ EdgeSelection Net edgeNr [_$_]
+ -> do disableReduce state
+
+ let network = getNetwork doc
+ edge = getEdge edgeNr network
+ case (getPortFrom edge, getPortTo edge) of
+ (Just (nodeNrFrom, portFrom), Just (nodeNrTo, portTo) )
+ -> let nodeFrom = getNode nodeNrFrom network [_$_]
+ nodeTo = getNode nodeNrTo network
+
+ in case findMatchingRules nodeFrom nodeTo portFrom portTo $ getRules doc of
+ [] -> warningDialog theFrame "No matching rule" [_$_]
+ "Reduction not performed because no rule matches this active pair." [_$_]
+ [(rule, lhsN1Nr, lhsN2Nr, lhsEdgeNr)] [_$_]
+ -> -- good case; exactly one rule applies
+ do logMessage $ "Rule \"" ++ INRule.getName rule ++ "\" will be applied."
+ putStrLn $ "Rule \"" ++ INRule.getName rule ++ "\" will be applied."
+
+ PD.updateDocument "reduce" [_$_]
+ ( (updateNetwork $ [_$_]
+ reallyReduce [_$_]
+ nodeNrFrom portFrom nodeNrTo portTo edgeNr
+ rule [_$_]
+ lhsN1Nr lhsN2Nr lhsEdgeNr ) [_$_]
+ . setSelection NoSelection ) [_$_]
+ pDoc
+ [_$_]
+ setActiveRule (INRule.getName rule) state
+ -- tree <- getTree state
+ -- item <- get item by name
+ -- treeCtrlSelect tree item [_$_]
+ repaintAll state [_$_]
+
+ _ -> warningDialog theFrame "Wrong system" [_$_]
+ $ "Reduction not performed because more than one rule can be applied to"
+ ++ " the selected active pair.\n\n"
+ ++ "This set of rules isn't an Interaction system.\n"
+ ++ "Correct the rules."
+ _ -> error "something unexpected happened" [_$_]
+ _ -> error "unexpected error: function reduce shouldn't be called."
+
+
+reallyReduce :: (InfoKind n g, InfoKind e g) => [_$_]
+ NodeNr -> Port -> NodeNr -> Port -> EdgeNr -- ^ active pair details from the net to reduce
+ -> INRule g n e -- ^ rule [_$_]
+ -> NodeNr -> NodeNr -> EdgeNr -- ^ active pair details from the lhs of rule
+ -> Network g n e -> Network g n e
+reallyReduce nFromNr portFrom nToNr portTo edgeNr rule lhsnNr1 lhsnNr2 lhsEdgeNr network =
+ let (inter, noInter) = partition isInterfaceNode . getNodeAssocs . getRHS $ rule
+ (interNrs, noInterNrs) = map fst >< map fst $ (inter, noInter)
+
+ (net1, nrs) = copy2network (map snd noInter) $ getNodePosition network nFromNr
+ nodeMaps = zip noInterNrs nrs
+
+ -- [_$_]
+ nFromPorts = tail . cleanJust $ getNodePorts network nFromNr -- excludes the principal one
+ nToPorts = tail . cleanJust $ getNodePorts network nToNr -- excludes the principal one
+
+ nFromPorts' = map (cleanJust . otherExtremeOfEdgeConnectedOnPort network nFromNr) nFromPorts
+ nToPorts' = map (cleanJust . otherExtremeOfEdgeConnectedOnPort network nToNr) nToPorts
+
+ nFromInterLHS :: [(NodeNr, Port)]
+ nFromInterLHS = map (cleanJust . otherExtremeOfEdgeConnectedOnPort (getLHS rule) lhsnNr1) nFromPorts
+ nToInterLHS = map (cleanJust . otherExtremeOfEdgeConnectedOnPort (getLHS rule) lhsnNr2) nToPorts
+
+ nFromInterRHS :: [(NodeNr, Port)]
+ nFromInterRHS = map ((\(nNr, mPort) -> (nNr,cleanJust mPort)) . moveThroughMapping (getMapping rule) . (id >< Just) ) nFromInterLHS
+ nToInterRHS = map ((\(nNr, mPort) -> (nNr,cleanJust mPort)) . moveThroughMapping (getMapping rule) . (id >< Just) ) nToInterLHS
+
+ nFromPortsRHS :: [(NodeNr, Port)]
+ nFromPortsRHS = map (\(nNr, port) -> cleanJust . otherExtremeOfEdgeConnectedOnPort (getRHS rule) nNr $ port) nFromInterRHS
+ nToPortsRHS = map (\(nNr, port) -> cleanJust . otherExtremeOfEdgeConnectedOnPort (getRHS rule) nNr $ port) nToInterRHS
+
+ oneStepBeforeRelation = zip nFromInterRHS nFromPorts' ++ zip nToInterRHS nToPorts'
+
+ listEdges' = [_$_]
+ map (id >< either id (updateNr nodeMaps >< id)) . [_$_]
+ eliminateDummyConnections oneStepBeforeRelation . [_$_]
+ map (id >< sepInterface) [_$_]
+ $ zip nFromPorts' nFromPortsRHS ++ zip nToPorts' nToPortsRHS
+
+
+ net3 = removeNode nToNr . removeNode nFromNr .
+ -- add edges from RHS that don't involve interface agents
+ copyEdgesWithoutInterface nodeMaps net1 . edgesWithoutInterface interNrs . getRHS $ rule
+ [_$_]
+ in foldl ( \network ((nF,pF),(nT,pT)) -> addEdge nF (Just pF) nT (Just pT) network) net3 listEdges'
+ where -- | copy agents others than interface from rhs to network updating node positions
+ copy2network [] _ = (network, [])
+ copy2network l@(rhsN1:xs) netPos = [_$_]
+ let delta = subtractDoublePoint netPos $ getPosition rhsN1
+ in mapAccumL (addNodeUpd delta) network l
+
+ -- addNodeUpd :: DoublePoint -> Network g n e -> Node n -> (Network g n e, NodeNr)
+ addNodeUpd delta net node = swap $ addExistingNode (updatePosition delta node) net
+
+ updatePosition delta node = [_$_]
+ setPosition (translate delta $ getPosition node) node
+
+ isConnectedToInterface :: [EdgeNr] -> Edge e -> Bool
+ isConnectedToInterface interNrs edge = [_$_]
+ getEdgeFrom edge `elem` interNrs || getEdgeTo edge `elem` interNrs
+
+ -- edges from network that are not connected to an interface agent
+ edgesWithoutInterface :: [NodeNr] -> Network g n e -> [Edge e]
+ edgesWithoutInterface interNrs = filter (not . isConnectedToInterface interNrs) . getEdges
+
+ -- copyEdgesWithoutInterface :: [(NodeNr, NodeNr)] -> Network g n e -> [Edge e] [_$_]
+ -- -> Network g n e
+ copyEdgesWithoutInterface nodeMaps = foldl $ addEdgeUpdatingNodeNrs nodeMaps
+
+ addEdgeUpdatingNodeNrs nodeMaps network edge = [_$_]
+ addEdge (updateNr nodeMaps $ getEdgeFrom edge) (takePort $ getPortFrom edge) [_$_]
+ (updateNr nodeMaps $ getEdgeTo edge) (takePort $ getPortTo edge) network
+
+ takePort = maybe Nothing (Just . snd)
+
+ updateNr :: [(NodeNr, NodeNr)] -> NodeNr -> NodeNr
+ updateNr nodeMaps nodeNr = maybe nodeNr id $ lookup nodeNr nodeMaps
+
+ cleanJust = takeJust "A port were expected here."
+
+ moveThroughMapping :: [((NodeNr, Maybe Port),(NodeNr, Maybe Port))] -> (NodeNr, Maybe Port) -> (NodeNr, Maybe Port)
+ moveThroughMapping maps elem = takeJust "Mapping not found." $ lookup elem maps
+
+ sepInterface :: (NodeNr, Port) -> Either (NodeNr, Port) (NodeNr, Port)
+ sepInterface x@(nodeNr, port) = if isInterfacePort port then Left x else Right x
+
+ eliminateDummyConnections :: [((NodeNr, Port),(NodeNr, Port))] [_$_]
+ -> [(a, Either (NodeNr, Port) (NodeNr, Port))] [_$_]
+ -> [(a, Either (NodeNr, Port) (NodeNr, Port))]
+ eliminateDummyConnections oneStepBeforeRelation = [_$_]
+ map (id >< either onLeftCase Right )
+ where onLeftCase interA = Left . takeJust "unexpected error" $ lookup interA oneStepBeforeRelation
+
+
+
+reduceAll :: (InfoKind n g, InfoKind e g) => Bool -> State g n e -> IO ()
+reduceAll continue state =
+ do pDoc <- getDocument state
+ doc <- PD.getDocument pDoc
+ theFrame <- getNetworkFrame state
+
+ safetyNet theFrame $
+
+ case filterActivePairs $ getNetwork doc of
+ [] -> return ()
+ l -> do let chosen = strategy l
+ PD.superficialUpdateDocument (setSelection $ EdgeSelection Net chosen) pDoc
+ repaintAll state [_$_]
+ reduce state
+ when continue $ reduceAll continue state
+
+ where filterActivePairs network = filter (\edgeNr -> isActivePair edgeNr network) . map fst $ getEdgeAssocs network
+
+ -- | Choose one active pair from the none empty list of active pairs
+ strategy :: [EdgeNr] -> EdgeNr
+ strategy = head [_$_]
+
+
+findMatchingRules :: Node n -> Node m -> Port -> Port -> INRules g n e [_$_]
+ -> [(INRule g n e, NodeNr, NodeNr, EdgeNr)]
+findMatchingRules nodeFrom nodeTo portFrom portTo rules = [_$_]
+ catMaybes [_$_]
+ . map ( findCorrespondence (getShape nodeFrom) (getShape nodeTo) portFrom portTo ) [_$_]
+ $ rules
+
+findCorrespondence :: Either String Shape -> Either String Shape -> Port -> Port [_$_]
+ -> INRule g n e [_$_]
+ -> Maybe (INRule g n e, NodeNr, NodeNr, EdgeNr)
+findCorrespondence shapeFrom shapeTo portFrom portTo rule =
+ case filter (not . isInterfaceNode) . getNodeAssocs . getLHS $ rule of
+ [(n1Nr,n1),(n2Nr,n2)] [_$_]
+ | (getShape n1, getShape n2) == (shapeFrom, shapeTo) -> aux n1Nr n2Nr
+ | (getShape n2, getShape n1) == (shapeFrom, shapeTo) -> aux n2Nr n1Nr
+ | otherwise -> Nothing
+ _ -> error $ "The LHS of rule \"" ++ INRule.getName rule ++ [_$_]
+ "\" is wrong; exactly two agents other than interface were expected but not found."
+ where aux nNr1 nNr2 = [_$_]
+ case findEdge nNr1 (Just portFrom) nNr2 (Just portTo) (getLHS rule) of
+ Nothing -> case findEdge nNr2 (Just portTo) nNr1 (Just portFrom) (getLHS rule) of
+ Just edgeNr -> Just (rule, nNr1, nNr2, edgeNr)
+ Nothing -> Nothing
+ Just edgeNr -> Just (rule, nNr1, nNr2, edgeNr)
+
hunk ./src/NetworkUI.hs 31
+import INReduction
hunk ./src/NetworkUI.hs 88
- ****** canvas
+ ****** netPan :: Panel ()
+ ******* canvas
+ ******* reduceB :: Button ()
+ ******* reduceAllB :: Button ()
+ ******* reduceStepB :: Button ()
hunk ./src/NetworkUI.hs 120
+ ; netPan <- panel sp3 []
hunk ./src/NetworkUI.hs 130
- ; canvas <- scrolledWindow sp3
+ ; canvas <- scrolledWindow netPan
hunk ./src/NetworkUI.hs 436
+ ; reduceB <- button netPan [_$_]
+ [ text := "Reduce" [_$_]
+ , enabled := False
+ , on command := reduce state
+ ]
+ ; setReduceButton reduceB state
+
+ ; reduceAllB <- button netPan [_$_]
+ [ text := "Reduce All" [_$_]
+ , on command := reduceAll True state
+ ]
+ ; reduceStepB <- button netPan [_$_]
+ [ text := "Reduce one step" [_$_]
+ , on command := reduceAll False state
+ ]
hunk ./src/NetworkUI.hs 477
- (fill $ widget canvas) ) [_$_]
+ (container netPan $ [_$_]
+ column 5 [ fill $ widget canvas
+ , hfloatLeft $ row 5 [ widget reduceB
+ , widget reduceAllB
+ , widget reduceStepB
+ ]
+ ]
+) ) [_$_]
hunk ./src/State.hs 23
+ , getReduceButton, setReduceButton
+
+ , disableReduce
hunk ./src/State.hs 57
+ , stReduceButton :: Button () [_$_]
hunk ./src/State.hs 83
+ , stOkButton = error "State.empty: Ok button has not been set" [_$_]
+ , stReduceButton = error "State.empty: Reduce button has not been set"
hunk ./src/State.hs 138
+getReduceButton :: State g n e -> IO (Button () )
+getReduceButton = getFromState stReduceButton
+
hunk ./src/State.hs 214
+
+setReduceButton :: Button () -> State g n e -> IO ()
+setReduceButton reduceButton stateRef =
+ varUpdate_ stateRef (\state -> state { stReduceButton = reduceButton })
+
+--
+
+disableReduce :: State g n e -> IO ()
+disableReduce state =
+ do button <- getReduceButton state
+ set button [enabled := False]
}