8 import INReductionStrategies
11 import Document as Doc
12 import qualified Palette
13 import qualified PersistentDocument as PD
28 import Graphics.UI.WXCore
31 -- | Tries to reduce the given edge in the network; one step reduction.
32 -- Its assumed that the edge is an active pair.
33 reduceStep :: (InfoKind n g, InfoKind e g) => EdgeNr -> State g n e -> IO ()
34 reduceStep edgeNr state =
35 do pDoc <- getDocument state
36 doc <- PD.getDocument pDoc
37 theFrame <- getNetworkFrame state
38 let network = getNetwork doc
39 edge = getEdge edgeNr network
42 let (nodeNrFrom, portFrom) = getFullPortFrom edge
43 (nodeNrTo , portTo ) = getFullPortTo edge
44 nodeFrom = getNode nodeNrFrom network
45 nodeTo = getNode nodeNrTo network
47 in case findMatchingRules nodeFrom nodeTo portFrom portTo $ getRules doc of
48 [] -> warningDialog theFrame "No matching rule"
49 "Reduction not performed because no rule matches this active pair."
50 [(rule, lhsN1Nr, lhsN2Nr, lhsEdgeNr)]
51 -> -- good case; exactly one rule applies
52 do logMessage $ "Rule \"" ++ INRule.getName rule ++ "\" will be applied."
53 putStrLn $ "Rule \"" ++ INRule.getName rule ++ "\" will be applied."
55 PD.updateDocument "reduce"
56 (\doc -> (updateNetwork $
57 reallyReduce (getPalette doc)
58 nodeNrFrom portFrom nodeNrTo portTo edgeNr
60 lhsN1Nr lhsN2Nr lhsEdgeNr )
61 . setSelection NoSelection $ doc)
64 setActiveRule (INRule.getName rule) state
65 -- tree <- getTree state
66 -- item <- get item by name
67 -- treeCtrlSelect tree item
70 _ -> warningDialog theFrame "Wrong system"
71 $ "Reduction not performed because more than one rule can be applied to"
72 ++ " the selected active pair.\n\n"
73 ++ "This set of rules isn't an Interaction system.\n"
74 ++ "Correct the rules."
77 reallyReduce :: (InfoKind n g, InfoKind e g) => Palette.Palette n ->
78 NodeNr -> PortName -> NodeNr -> PortName -> EdgeNr -- ^ active pair details from the net to reduce
79 -> INRule g n e -- ^ rule
80 -> NodeNr -> NodeNr -> EdgeNr -- ^ active pair details from the lhs of rule
81 -> Network g n e -> Network g n e
82 reallyReduce palette nFromNr portFrom nToNr portTo edgeNr rule lhsnNr1 lhsnNr2 lhsEdgeNr network =
83 let (inter, noInter) = partition isInterfaceNode . getNodeAssocs . getRHS $ rule
84 (interNrs, noInterNrs) = map fst >< map fst $ (inter, noInter)
86 (net1, nrs) = copy2network (map snd noInter) $ getNodePosition network nFromNr
87 nodeMaps = zip noInterNrs nrs
89 nFromPorts, nToPorts :: Ports
90 nFromPorts = tail . cleanJust $ getPorts palette network nFromNr -- excludes the principal one
91 nToPorts = tail . cleanJust $ getPorts palette network nToNr -- excludes the principal one
93 nFromPorts', nToPorts' :: [(NodeNr, PortName)]
94 nFromPorts' = map (cleanJust . otherExtremeOfEdgeConnectedOnPort network nFromNr . fst) nFromPorts
95 nToPorts' = map (cleanJust . otherExtremeOfEdgeConnectedOnPort network nToNr . fst) nToPorts
97 nFromInterLHS, nToInterLHS :: [(NodeNr, PortName)]
98 nFromInterLHS = map (cleanJust . otherExtremeOfEdgeConnectedOnPort (getLHS rule) lhsnNr1 . fst) nFromPorts
99 nToInterLHS = map (cleanJust . otherExtremeOfEdgeConnectedOnPort (getLHS rule) lhsnNr2 . fst) nToPorts
101 nFromInterRHS, nToInterRHS :: [(NodeNr, PortName)]
102 nFromInterRHS = map ( ( moveThroughMapping (getMapping rule) ) >< id ) nFromInterLHS
103 nToInterRHS = map ( ( moveThroughMapping (getMapping rule) ) >< id ) nToInterLHS
105 nFromPortsRHS, nToPortsRHS :: [(NodeNr, PortName)]
106 nFromPortsRHS = map (\(nNr, port) -> cleanJust . otherExtremeOfEdgeConnectedOnPort (getRHS rule) nNr $ port) nFromInterRHS
107 nToPortsRHS = map (\(nNr, port) -> cleanJust . otherExtremeOfEdgeConnectedOnPort (getRHS rule) nNr $ port) nToInterRHS
109 oneStepBeforeRelation :: [((NodeNr, PortName),(NodeNr, PortName))]
110 oneStepBeforeRelation = zip nFromInterRHS nFromPorts' ++ zip nToInterRHS nToPorts'
112 edgesInvolvingNodesToBeRemove e@((a,_),(b,_)) (ly,ln) | a `elem` [nToNr, nFromNr] = (e:ly , ln)
113 | b `elem` [nToNr, nFromNr] = (swap e : ly, ln)
114 | otherwise = (ly , e:ln)
115 correctEdge [(_,from), (_,to)] = (from, to)
116 correctEdge _ = error "A list of two elements was expected but one of different length was found in reduction function."
118 nodesToBeRemoveConnected :: ((NodeNr, PortName),(NodeNr, PortName)) -> ((NodeNr, PortName),(NodeNr, PortName)) -> Bool
119 nodesToBeRemoveConnected ((nr1,p1),_) (c,_) = Just c == otherExtremeOfEdgeConnectedOnPort network nr1 p1
123 ((map correctEdge . groupBy nodesToBeRemoveConnected . nub) >< id) .
124 foldr edgesInvolvingNodesToBeRemove ([],[]) .
125 map (id >< either id (updateNr nodeMaps >< id)) .
126 eliminateDummyConnections oneStepBeforeRelation .
127 map (id >< sepInterface)
128 $ zip nFromPorts' nFromPortsRHS ++ zip nToPorts' nToPortsRHS
131 net3 = removeNode nToNr . removeNode nFromNr .
132 -- add edges from RHS that don't involve interface agents
133 copyEdgesWithoutInterface nodeMaps net1 . edgesWithoutInterface interNrs . getRHS $ rule
135 in foldl ( \network ((nF,pF),(nT,pT)) -> addEdge palette nF pF nT pT network) net3 listEdges'
136 where -- | copy agents others than interface from rhs to network updating node positions
137 copy2network [] _ = (network, [])
138 copy2network l@(rhsN1:xs) netPos =
139 let delta = subtractDoublePoint netPos $ getPosition rhsN1
140 in mapAccumL (addNodeUpd delta) network l
142 -- addNodeUpd :: DoublePoint -> Network g n e -> Node n -> (Network g n e, NodeNr)
143 addNodeUpd delta net node = swap $ addExistingNode (updatePosition delta node) net
145 updatePosition delta node =
146 setPosition (translate delta $ getPosition node) node
148 isConnectedToInterface :: [EdgeNr] -> Edge e -> Bool
149 isConnectedToInterface interNrs edge =
150 getEdgeFrom edge `elem` interNrs || getEdgeTo edge `elem` interNrs
152 -- edges from network that are not connected to an interface agent
153 edgesWithoutInterface :: [NodeNr] -> Network g n e -> [Edge e]
154 edgesWithoutInterface interNrs = filter (not . isConnectedToInterface interNrs) . getEdges
156 -- copyEdgesWithoutInterface :: [(NodeNr, NodeNr)] -> Network g n e -> [Edge e]
158 copyEdgesWithoutInterface nodeMaps = foldl $ addEdgeUpdatingNodeNrs nodeMaps
160 addEdgeUpdatingNodeNrs nodeMaps network edge =
161 addEdge palette (updateNr nodeMaps $ getEdgeFrom edge) (getPortFrom edge)
162 (updateNr nodeMaps $ getEdgeTo edge) (getPortTo edge) network
164 updateNr :: [(NodeNr, NodeNr)] -> NodeNr -> NodeNr
165 updateNr nodeMaps nodeNr = maybe nodeNr id $ lookup nodeNr nodeMaps
167 cleanJust = takeJust "A port was expected here."
169 moveThroughMapping :: Mapping -> NodeNr -> NodeNr
170 moveThroughMapping maps elem = takeJust "Mapping not found." $ lookup elem maps
172 sepInterface :: (NodeNr, PortName) -> Either (NodeNr, PortName) (NodeNr, PortName)
173 sepInterface x@(nodeNr, port) = if isInterfacePort port then Left x else Right x
175 eliminateDummyConnections :: [((NodeNr, PortName),(NodeNr, PortName))]
176 -> [(a, Either (NodeNr, PortName) (NodeNr, PortName))]
177 -> [(a, Either (NodeNr, PortName) (NodeNr, PortName))]
178 eliminateDummyConnections oneStepBeforeRelation =
179 map (id >< either onLeftCase Right )
180 where onLeftCase interA = Left . takeJust "unexpected error" $ lookup interA oneStepBeforeRelation
183 globalReduce :: (InfoKind n g, InfoKind e g) => Strategy -> Bool -> State g n e -> IO ()
184 globalReduce strategy manySteps state =
185 do pDoc <- getDocument state
186 doc <- PD.getDocument pDoc
187 theFrame <- getNetworkFrame state
188 let network = getNetwork doc
189 palette = getPalette doc
190 logMessage $ "STRATEGY: " ++ strategy
194 case filterActivePairs palette network of
195 [] -> infoDialog theFrame "Nothing to be done" "The net has no active pairs, so there is nothing to reduce."
196 l -> case choose l strategy doc of -- choose one active pair
197 Result chosen | isActivePair chosen palette network ->
198 do PD.superficialUpdateDocument (setSelection $ EdgeSelection Net chosen) pDoc
201 reduceStep chosen state
202 continue <- getContinueReduction state
203 when (manySteps && continue) $ globalReduce strategy manySteps state
204 Result _ -> errorDialog theFrame "Not an active pair" $
205 "The given/choosen edge is not an active pair.\nThis is due to "
207 "Manual selection" -> "wrong user choice.\nPlease choose one edge that is an active pair."
208 _ -> "wrong strategy implementation.\nPlease report bug to authors."
209 ErrorD str1 str2 -> errorDialog theFrame str1 str2
210 InfoD str1 str2 -> infoDialog theFrame str1 str2
213 where filterActivePairs palette network = filter (\edgeNr -> isActivePair edgeNr palette network)
214 . map fst $ getEdgeAssocs network
216 -- | Choose one active pair from the none empty list of active pairs
217 choose :: [EdgeNr] -- ^ none empty list of all active pairs in the network
218 -> Strategy -- ^ strategy to use in choice process
219 -> Doc.Document g n e -- ^ document
220 -> PossibleResult EdgeNr -- ^ edgeNr to reduce or thrown error message
221 choose lAPs strategy doc =
222 case lookup strategy strategiesList of
223 Nothing -> ErrorD "Error" "Strategy name without choose function.\nPlease report bug to authors."
224 Just func -> func lAPs doc
227 findMatchingRules :: Node n -> Node m -> PortName -> PortName -> INRules g n e
228 -> [(INRule g n e, NodeNr, NodeNr, EdgeNr)]
229 findMatchingRules nodeFrom nodeTo portFrom portTo rules =
231 . map ( findCorrespondence (getShape nodeFrom) (getShape nodeTo) portFrom portTo )
234 findCorrespondence :: Palette.ShapeName -> Palette.ShapeName -> PortName -> PortName
236 -> Maybe (INRule g n e, NodeNr, NodeNr, EdgeNr)
237 findCorrespondence shapeFrom shapeTo portFrom portTo rule =
238 case filter (not . isInterfaceNode) . getNodeAssocs . getLHS $ rule of
239 [(n1Nr,n1),(n2Nr,n2)]
240 | (getShape n1, getShape n2) == (shapeFrom, shapeTo) -> aux n1Nr n2Nr
241 | (getShape n2, getShape n1) == (shapeFrom, shapeTo) -> aux n2Nr n1Nr
242 | otherwise -> Nothing
243 _ -> error $ "The LHS of rule \"" ++ INRule.getName rule ++
244 "\" is wrong; exactly two agents other than interface were expected but not found."
245 where aux nNr1 nNr2 =
246 case findEdge nNr1 portFrom nNr2 portTo (getLHS rule) of
247 Nothing -> case findEdge nNr2 portTo nNr1 portFrom (getLHS rule) of
248 Just edgeNr -> Just (rule, nNr1, nNr2, edgeNr)
250 Just edgeNr -> Just (rule, nNr1, nNr2, edgeNr)
253 -- | Reduce the selected edge in the network; one step reduction.
254 reduce :: (InfoKind n g, InfoKind e g) => State g n e -> IO ()
255 reduce = globalReduce "Manual selection" False