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