INblobs-0.1.1: src/INReduction.hs
module INReduction
(
reduce
, globalReduce
, strategiesList
) where
import INReductionStrategies
import Network
import NetworkControl
import Document as Doc
import qualified Palette
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
-- | 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 =
do pDoc <- getDocument state
doc <- PD.getDocument pDoc
theFrame <- getNetworkFrame state
let network = getNetwork doc
edge = getEdge edgeNr network
safetyNet theFrame $
let (nodeNrFrom, portFrom) = getFullPortFrom edge
(nodeNrTo , portTo ) = getFullPortTo edge
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"
(\doc -> (updateNetwork $
reallyReduce (getPalette doc)
nodeNrFrom portFrom nodeNrTo portTo edgeNr
rule
lhsN1Nr lhsN2Nr lhsEdgeNr )
. setSelection NoSelection $ doc)
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."
reallyReduce :: (InfoKind n g, InfoKind e g) => Palette.Palette n ->
NodeNr -> PortName -> NodeNr -> PortName -> 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 palette 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, nToPorts :: Ports
nFromPorts = tail . cleanJust $ getPorts palette network nFromNr -- excludes the principal one
nToPorts = tail . cleanJust $ getPorts palette network nToNr -- excludes the principal one
nFromPorts', nToPorts' :: [(NodeNr, PortName)]
nFromPorts' = map (cleanJust . otherExtremeOfEdgeConnectedOnPort network nFromNr . fst) nFromPorts
nToPorts' = map (cleanJust . otherExtremeOfEdgeConnectedOnPort network nToNr . fst) nToPorts
nFromInterLHS, nToInterLHS :: [(NodeNr, PortName)]
nFromInterLHS = map (cleanJust . otherExtremeOfEdgeConnectedOnPort (getLHS rule) lhsnNr1 . fst) nFromPorts
nToInterLHS = map (cleanJust . otherExtremeOfEdgeConnectedOnPort (getLHS rule) lhsnNr2 . fst) nToPorts
nFromInterRHS, nToInterRHS :: [(NodeNr, PortName)]
nFromInterRHS = map ( ( moveThroughMapping (getMapping rule) ) >< id ) nFromInterLHS
nToInterRHS = map ( ( moveThroughMapping (getMapping rule) ) >< id ) nToInterLHS
nFromPortsRHS, nToPortsRHS :: [(NodeNr, PortName)]
nFromPortsRHS = map (\(nNr, port) -> cleanJust . otherExtremeOfEdgeConnectedOnPort (getRHS rule) nNr $ port) nFromInterRHS
nToPortsRHS = map (\(nNr, port) -> cleanJust . otherExtremeOfEdgeConnectedOnPort (getRHS rule) nNr $ port) nToInterRHS
oneStepBeforeRelation :: [((NodeNr, PortName),(NodeNr, PortName))]
oneStepBeforeRelation = zip nFromInterRHS nFromPorts' ++ zip nToInterRHS nToPorts'
edgesInvolvingNodesToBeRemove e@((a,_),(b,_)) (ly,ln) | a `elem` [nToNr, nFromNr] = (e:ly , ln)
| b `elem` [nToNr, nFromNr] = (swap e : ly, ln)
| otherwise = (ly , e:ln)
correctEdge [(_,from), (_,to)] = (from, to)
correctEdge _ = error "A list of two elements was expected but one of different length was found in reduction function."
nodesToBeRemoveConnected :: ((NodeNr, PortName),(NodeNr, PortName)) -> ((NodeNr, PortName),(NodeNr, PortName)) -> Bool
nodesToBeRemoveConnected ((nr1,p1),_) (c,_) = Just c == otherExtremeOfEdgeConnectedOnPort network nr1 p1
listEdges' =
(\(a,b) -> a ++ b) .
((map correctEdge . groupBy nodesToBeRemoveConnected . nub) >< id) .
foldr edgesInvolvingNodesToBeRemove ([],[]) .
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 palette nF pF nT 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 palette (updateNr nodeMaps $ getEdgeFrom edge) (getPortFrom edge)
(updateNr nodeMaps $ getEdgeTo edge) (getPortTo edge) network
updateNr :: [(NodeNr, NodeNr)] -> NodeNr -> NodeNr
updateNr nodeMaps nodeNr = maybe nodeNr id $ lookup nodeNr nodeMaps
cleanJust = takeJust "A port was expected here."
moveThroughMapping :: Mapping -> NodeNr -> NodeNr
moveThroughMapping maps elem = takeJust "Mapping not found." $ lookup elem maps
sepInterface :: (NodeNr, PortName) -> Either (NodeNr, PortName) (NodeNr, PortName)
sepInterface x@(nodeNr, port) = if isInterfacePort port then Left x else Right x
eliminateDummyConnections :: [((NodeNr, PortName),(NodeNr, PortName))]
-> [(a, Either (NodeNr, PortName) (NodeNr, PortName))]
-> [(a, Either (NodeNr, PortName) (NodeNr, PortName))]
eliminateDummyConnections oneStepBeforeRelation =
map (id >< either onLeftCase Right )
where onLeftCase interA = Left . takeJust "unexpected error" $ lookup interA oneStepBeforeRelation
globalReduce :: (InfoKind n g, InfoKind e g) => Strategy -> Bool -> State g n e -> IO ()
globalReduce strategy manySteps state =
do pDoc <- getDocument state
doc <- PD.getDocument pDoc
theFrame <- getNetworkFrame state
let network = getNetwork doc
palette = getPalette doc
logMessage $ "STRATEGY: " ++ strategy
safetyNet theFrame $
case filterActivePairs palette 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 palette 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
where filterActivePairs palette network = filter (\edgeNr -> isActivePair edgeNr palette network)
. map fst $ getEdgeAssocs network
-- | 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
findMatchingRules :: Node n -> Node m -> PortName -> PortName -> 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 :: Palette.ShapeName -> Palette.ShapeName -> PortName -> PortName
-> 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 portFrom nNr2 portTo (getLHS rule) of
Nothing -> case findEdge nNr2 portTo nNr1 portFrom (getLHS rule) of
Just edgeNr -> Just (rule, nNr1, nNr2, edgeNr)
Nothing -> Nothing
Just edgeNr -> Just (rule, nNr1, nNr2, edgeNr)
-- | 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