Tue Feb 6 14:42:35 WET 2007 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Standard reduction stragies system
Allow for a much simpler an concise implementation of
new reduction strategies.
{
hunk ./Makefile 37
+ src/INReductionStrategies.hs \
hunk ./Makefile 229
+src/INReductionStrategies.o : src/INReductionStrategies.hs
+src/INReductionStrategies.o : src/INRule.hi
+src/INReductionStrategies.o : src/Network.hi
+src/INReductionStrategies.o : src/Document.hi
hunk ./Makefile 263
-src/INTextualUI.o : src/INTextualUI.hs
-src/INTextualUI.o : src/State.hi
-src/INTextualUI.o : src/InfoKind.hi
-src/INTextualUI.o : src/INTextual.hi
-src/INTextualUI.o : src/SafetyNet.hi
-src/INTextualUI.o : src/Operations.hi
hunk ./Makefile 276
-src/INReduction.o : src/Network.hi
hunk ./Makefile 277
+src/INReduction.o : src/Network.hi
+src/INReduction.o : src/INReductionStrategies.hi
hunk ./Makefile 328
+src/INTextualUI.o : src/INTextualUI.hs
+src/INTextualUI.o : src/State.hi
+src/INTextualUI.o : src/InfoKind.hi
+src/INTextualUI.o : src/INTextual.hi
+src/INTextualUI.o : src/SafetyNet.hi
+src/INTextualUI.o : src/Operations.hi
hunk ./src/INReduction.hs 4
- , reduceAll
- , reduceWRINF
+ , globalReduce
+ , strategiesList
hunk ./src/INReduction.hs 8
+import INReductionStrategies
hunk ./src/INReduction.hs 11
-import Document
+import Document as Doc
hunk ./src/INReduction.hs 29
-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
hunk ./src/INReduction.hs 30
--- | Reduce the selected edge in the network; one step reduction.
-reduce :: (InfoKind n g, InfoKind e g) => State g n e -> IO ()
-reduce state = [_$_]
+-- | Tries to reduce the given edge in the network; one step reduction.
+-- Its assumed that the edge is an active pair.
+reduceStep :: (InfoKind n g, InfoKind e g) => EdgeNr -> State g n e -> IO ()
+reduceStep edgeNr state = [_$_]
hunk ./src/INReduction.hs 37
+ let network = getNetwork doc
+ edge = getEdge edgeNr network
hunk ./src/INReduction.hs 42
- case getSelection doc of
- EdgeSelection Net edgeNr [_$_]
- -> do disableReduce state
-
- let network = getNetwork doc
- edge = getEdge edgeNr network
hunk ./src/INReduction.hs 76
- _ -> error "unexpected error: function reduce shouldn't be called."
hunk ./src/INReduction.hs 183
-
-reduceAll :: (InfoKind n g, InfoKind e g) => Bool -> State g n e -> IO ()
-reduceAll continue state =
+globalReduce :: (InfoKind n g, InfoKind e g) => Strategy -> Bool -> State g n e -> IO ()
+globalReduce strategy manySteps state =
hunk ./src/INReduction.hs 188
+ let network = getNetwork doc
+[_^I_][_$_]
+ logMessage $ "STRATEGY: " ++ strategy
hunk ./src/INReduction.hs 194
- 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
+ case filterActivePairs network of
+ [] -> infoDialog theFrame "Nothing to be done" "The net has no active pairs, so there is nothing to reduce."
+ l -> case choose l strategy doc of -- choose one active pair
+ Result chosen | isActivePair chosen network -> [_$_]
+ do PD.superficialUpdateDocument (setSelection $ EdgeSelection Net chosen) pDoc
+ repaintAll state [_$_]
+ wxcAppYield
+ reduceStep chosen state
+ continue <- getContinueReduction state
+ when (manySteps && continue) $ globalReduce strategy manySteps state
+ Result _ -> errorDialog theFrame "Not an active pair" $ [_$_]
+ "The given/choosen edge is not an active pair.\nThis is due to " [_$_]
+ ++ case strategy of [_$_]
+ "Manual selection" -> "wrong user choice.\nPlease choose one edge that is an active pair."
+ _ -> "wrong strategy implementation.\nPlease report bug to authors."
+ ErrorD str1 str2 -> errorDialog theFrame str1 str2
+ InfoD str1 str2 -> infoDialog theFrame str1 str2
+
hunk ./src/INReduction.hs 215
- -- | Choose one active pair from the none empty list of active pairs
- strategy :: [EdgeNr] -> EdgeNr
- strategy = head [_$_]
+-- | Choose one active pair from the none empty list of active pairs
+choose :: [EdgeNr] -- ^ none empty list of all active pairs in the network
+ -> Strategy -- ^ strategy to use in choice process
+ -> Doc.Document g n e -- ^ document
+ -> PossibleResult EdgeNr -- ^ edgeNr to reduce or thrown error message
+choose lAPs strategy doc =
+ case lookup strategy strategiesList of
+ Nothing -> ErrorD "Error" "Strategy name without choose function.\nPlease report bug to authors."
+ Just func -> func lAPs doc
hunk ./src/INReduction.hs 252
-
-
--- | WRINF Strategy [_$_]
-reduceWRINF ::(Show n,InfoKind n g, InfoKind e g) => State g n e -> IO ()
-reduceWRINF state = do{;pDoc <- getDocument state
- ;doc <- PD.getDocument pDoc
- ;theFrame <- getNetworkFrame state
- ;network <- return $ getNetwork doc
- ;pairList <- return $ getNodeAssocs network
- ;interfaces <- return $ filter isInterfaceNode pairList
- ;if ((length interfaces) /= 1)
- then infoDialog theFrame "Error" $ "The WRINF reduction can only be applyed to Interaction Nets with one interface"
- else do {;interface <- return $ fst $ head interfaces
- ;if (isTheInterfaceActivePair (dd network interface) network)
- then do infoDialog theFrame "WRINF is done" $ "Nothing to be done using WRINF strategy";
- else do {;activePair <- return $ walk network [] interface [_$_]
- ;case activePair of
- Nothing -> do {infoDialog theFrame "WRINF is done" $ "Nothing to be done using WRINF strategy";}
- (Just e) -> do {;selectEdge e state
- ;reduce state
- }
- }
-
- }
- }
-
-walk :: Network g n e -> [NodeNr] -> NodeNr -> Maybe EdgeNr
-walk network visited node_start | (node_start `elem` visited) = Nothing
- | otherwise = let pp = filter (\x -> (isPrincipalPort network node_start x) ==True) [_$_]
- $ fromMaybe [] $ getPorts $ getNode node_start network
- in case pp of [_$_]
- [] -> Nothing;
- (x:[]) -> let edgeOnPPort = edgeConnectedOnPort network node_start x; [_$_]
- in case edgeOnPPort of
- (Just e) -> if (isActivePair e network ) [_$_]
- then (Just e) [_$_]
- else let next_node = fst $ fromJust $ otherExtremeOfEdgeConnectedOnPort network node_start x [_$_]
- in walk network (node_start:visited) next_node;
- _ -> Nothing;
-[_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_] [_$_]
-[_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_][_^I_] [_$_]
-dd :: Network g n e -> NodeNr -> EdgeNr
-dd nt nr = let por = fromMaybe [] $ getPorts $ getNode nr nt [_$_]
- in head ( map (\(Just a) -> (a)) $ [_$_]
- filter (/=Nothing) $ [_$_]
- map (edgeConnectedOnPort nt nr ) por )
-
-
--- | checks if the an interface node is an active pair. [_$_]
-isTheInterfaceActivePair :: EdgeNr -> Network g n e -> Bool [_$_]
-isTheInterfaceActivePair edgeNr network = [_$_]
- case (getPortFrom edge, getPortTo edge) of
- (Just (nodeNrFrom, portFrom), Just (nodeNrTo, portTo) ) [_$_]
- -> isPrincipalPort network nodeNrFrom portFrom
- && isPrincipalPort network nodeNrTo portTo
- _ -> 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 = globalReduce "Manual selection" False
addfile ./src/INReductionStrategies.hs
hunk ./src/INReductionStrategies.hs 1
+-- | If someone wants to give a new reduction strategy have to:
+-- 1. add a new entry in @strategiesList@ (e.g. @("New Strategy string", choose_NewStrategy_function)@)
+-- 2. define @choose_NewStrategy_function :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr@
+module INReductionStrategies where
+
+import Document
+import Network
+import INRule
+
+import Data.Maybe
+
+data PossibleResult a = Result a | ErrorD String String | InfoD String String
+
+-- | Checks if the given edge is an active pair.
+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
+
+-- | Checks if an interface node is connected through an active pair. [_$_]
+isTheInterfaceActivePair :: EdgeNr -> Network g n e -> Bool [_$_]
+isTheInterfaceActivePair edgeNr network = [_$_]
+ case (getPortFrom edge, getPortTo edge) of
+ (Just (nodeNrFrom, portFrom), Just (nodeNrTo, portTo) ) [_$_]
+ -> isPrincipalPort network nodeNrFrom portFrom
+ && isPrincipalPort network nodeNrTo portTo
+ _ -> False
+ where edge = getEdge edgeNr network
+
+
+type Strategy = String
+
+-- | List of pairs (Strategy name, strategy choose function)
+strategiesList :: [(Strategy -- ^ strategy name
+ , [EdgeNr] -- ^ none empty list of all active pairs in the network
+ -> Document g n e -- ^ document
+ -> PossibleResult EdgeNr -- ^ edgeNr to reduce or thrown error message
+ )]
+strategiesList = [_$_]
+ [ ("Manual selection", chooseManualSelection)
+ , ("Random", chooseRandom)
+ , ("WRINF", chooseWRINF)
+ ] [_$_]
+
+chooseManualSelection :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr
+chooseManualSelection _ doc = case getSelection doc of
+ EdgeSelection Net edgeNr -> Result edgeNr [_$_]
+ _ -> ErrorD "Reduction error" "Please select an active pair first and press 'REDUCE' again."
+
+chooseRandom :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr
+chooseRandom lAPs _ = Result $ head lAPs
+
+
+-- | WRINF Strategy [_$_]
+chooseWRINF :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr
+chooseWRINF _ doc = [_$_]
+ case filter isInterfaceNode $ getNodeAssocs network of
+ [(interface,_)] -> [_$_]
+ if (isTheInterfaceActivePair (dd network interface) network)
+ then InfoD "WRINF is done" "Nothing to be done using WRINF strategy"
+ else case walk network [] interface of
+ Nothing -> InfoD "WRINF is done" "Nothing to be done using WRINF strategy"
+ Just e -> Result e
+ where network = getNetwork doc
+
+walk :: Network g n e -> [NodeNr] -> NodeNr -> Maybe EdgeNr
+walk network visited node_start | (node_start `elem` visited) = Nothing
+ | otherwise = let pp = filter (\x -> (isPrincipalPort network node_start x) ==True) [_$_]
+ . fromMaybe [] . getPorts $ getNode node_start network
+ in case pp of [_$_]
+ [] -> Nothing
+ (x:[]) -> let edgeOnPPort = edgeConnectedOnPort network node_start x; [_$_]
+ in case edgeOnPPort of
+ (Just e) -> if (isActivePair e network ) [_$_]
+ then (Just e) [_$_]
+ else let next_node = fst . fromJust $ otherExtremeOfEdgeConnectedOnPort network node_start x [_$_]
+ in walk network (node_start:visited) next_node;
+ _ -> Nothing;
+
+dd :: Network g n e -> NodeNr -> EdgeNr
+dd nt nr = let por = fromMaybe [] $ getPorts $ getNode nr nt [_$_]
+ in head . catMaybes $ map (edgeConnectedOnPort nt nr ) por [_$_]
+-- END of WRINF
+
+
+-- chooseNewStrategy :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr
+
hunk ./src/NetworkUI.hs 91
+ ******* strategies :: RadioBox ()
+ ******* steps :: RadioBox ()
hunk ./src/NetworkUI.hs 94
- ******* reduceAllB :: Button ()
- ******* reduceStepB :: Button ()
+ ******* reduceStopB :: Button ()
hunk ./src/NetworkUI.hs 117
-#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
+#if !defined(__APPLE__)
hunk ./src/NetworkUI.hs 160
-#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER) [_$_]
+#if !defined(__APPLE__)
hunk ./src/NetworkUI.hs 365
- ; palMenu <- menuPane [ text := "&Agents" ]
+ ; palMenu <- menuPane [ text := "&Symbols" ]
hunk ./src/NetworkUI.hs 431
- ; addAgent <- button palettePan [ text := "add new agent"
+ ; addAgent <- button palettePan [ text := "Create new symbol"
hunk ./src/NetworkUI.hs 438
+
+ -- reduction
hunk ./src/NetworkUI.hs 442
- , enabled := False
- , on command := reduce state
+ , enabled := True [_$_]
hunk ./src/NetworkUI.hs 446
- ; reduceAllB <- button netPan [_$_]
- [ text := "Reduce All" [_$_]
- , on command := reduceAll True state
- ]
- ; reduceStepB <- button netPan [_$_]
- [ text := "Reduce one step" [_$_]
- , on command := reduceAll False state
- ]
- ; reduceWRINF <- button netPan
- [ text := "Reduce WRINF"
- , on command := reduceWRINF state
- ]
+ ; reduceStopB <- button netPan [_$_]
+ [ text := "Stop" [_$_]
+ , enabled := False
+ ]
+ ; let (stratsS, _) = unzip strategiesList
+
+ ; strategies <- radioBox netPan Vertical stratsS [_$_]
+ [ text := "Strategy"
+ , selection := 1 ] [_$_]
+
+ ; steps <- radioBox netPan Vertical ["one", "many"] [_$_]
+ [ text := "Steps"
+ , selection := 0 ] [_$_]
+
+ ; set reduceB [on command := do logMessage "Button Reduce pressed"
+ set reduceB [enabled := False]
+ set reduceStopB [enabled := True]
+ set strategies [enabled := False]
+ set steps [enabled := False]
+ setContinueReduction True state
+ s <- get steps selection
+ i <- get strategies selection
+ globalReduce (stratsS !! i) (s==1) state
+ set reduceStopB [enabled := False]
+ set strategies [enabled := True]
+ set steps [enabled := (stratsS !! i /= "Manual selection")]
+ set reduceB [enabled := True]
+ ]
+ [_$_]
+ ; set reduceStopB [ on command := do stopReduction state
+ set reduceStopB [enabled := False]
+ set reduceB [enabled := True]
+ ]
+
+ ; set strategies [ on select := [_$_]
+ do i <- get strategies selection
+ if stratsS !! i == "Manual selection"
+ then set steps [ enabled := False
+ , selection := 0
+ ]
+ else do set steps [ enabled := True]
+ set reduceB [ enabled := True]
+
+ ] [_$_]
+
+
hunk ./src/NetworkUI.hs 511
-#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
+#if !defined(__APPLE__)
hunk ./src/NetworkUI.hs 525
- , hfloatLeft $ row 5 [ widget reduceB
- , widget reduceAllB
- , widget reduceStepB
- , widget reduceWRINF [_$_]
- ]
+ , [_$_]
+#if !defined(__APPLE__)
+ boxed "Reduction" $
+#endif
+ hfloatLeft $ row 5 [ widget strategies
+ , widget steps
+ , column 5 [ widget reduceB
+ , widget reduceStopB]
+ ]
hunk ./src/NetworkUI.hs 535
-) ) [_$_]
+ ) [_$_]
+ ) [_$_]
hunk ./src/NetworkUI.hs 670
- -- set the initial palette only with interface agent [_$_]
+ -- set the initial palette only with interface symbol [_$_]
hunk ./src/NetworkUI.hs 1115
--- | Create a dialog where the user have to choose to agents. [_$_]
+-- | Create a dialog where the user have to choose two symbols. [_$_]
hunk ./src/NetworkUI.hs 1315
- -- palette without interface agent
+ -- palette without interface symbol
hunk ./src/NetworkUI.hs 1321
- do warningDialog theFrame "No agents" "There are no agents other then interface ones.\nAdd agents first."
+ do warningDialog theFrame "No symbols" "There are no symbols other than interface ones.\nAdd symbol first."
hunk ./src/NetworkUI.hs 1364
- column 5 [ label "Choose one agent in each palette."
+ column 5 [ label "Choose one symbol in each palette."
hunk ./src/NetworkUI.hs 1405
- ;errorDialog theFrame "Not Defined" "No rules defined for any of the agents in the pallete"
+ ;errorDialog theFrame "Not Defined" "No rules defined for any of the symbols in the pallete"
hunk ./src/NetworkUI.hs 1431
- diaW <- dialog theFrame [ text := "Create new agent"
+ diaW <- dialog theFrame [ text := "Create new symbol"
hunk ./src/NetworkUI.hs 1438
- agent <- entry p [text := "agent name"]
+ agent <- entry p [text := "Symbol name"]
hunk ./src/NetworkUI.hs 1444
- symb <- entry p [text := "agent symbol" ]
+ symb <- entry p [text := "Displayed name" ]
hunk ./src/NetworkUI.hs 1492
- boxed "New agent with" $
+ boxed "New symbol with" $
hunk ./src/NetworkUI.hs 1495
- [[label "agent name", hfill $ widget agent]
- ,[label "agent symbol", hfill $ widget symb]
+ [[label "Symbol name", hfill $ widget agent]
+ ,[label "Symbol displayed name", hfill $ widget symb]
hunk ./src/NetworkUI.hs 1511
- then do { errorDialog diaW "Repeated agent name" $ "Already exists one agent with name \"" ++ agentD ++ "\". Choose a different one."
+ then do { errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."
hunk ./src/State.hs 24
+ , getContinueReduction, setContinueReduction
hunk ./src/State.hs 26
+ , stopReduction
hunk ./src/State.hs 60
+ , stContinueReduct :: Bool -- ^ reduction process should continue or stop [_$_]
hunk ./src/State.hs 88
+ , stContinueReduct = True
hunk ./src/State.hs 145
+getContinueReduction :: State g n e -> IO Bool
+getContinueReduction = getFromState stContinueReduct
+
+
hunk ./src/State.hs 227
+setContinueReduction :: Bool -> State g n e -> IO ()
+setContinueReduction continue stateRef =
+ varUpdate_ stateRef (\state -> state { stContinueReduct = continue })
hunk ./src/State.hs 233
-disableReduce state =
- do button <- getReduceButton state
- set button [enabled := False]
+disableReduce state = return ()
+-- do button <- getReduceButton state
+-- set button [enabled := False]
+
+stopReduction :: State g n e -> IO ()
+stopReduction = setContinueReduction False
}