Internal.hs

module HGraph.Directed.EditDistance.Acyclic.ArcDeletion.Internal where

import Prelude hiding (minimum)

import HGraph.Directed
import HGraph.Directed.Connectivity.Basic
import HGraph.Directed.Connectivity.Flow

import Control.Monad
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Map as M

import qualified Debug.Trace as D (trace)

minimum :: (DirectedGraph t, Adjacency t, Mutable t)
         => t a -> ([(a,a)], Int)
minimum d =
  let (di, iToL) = linearizeVertices d
      iToLM = M.fromList iToL
      (xs, k) = minimumI di
  in ( map (\(v,u) -> (iToLM M.! v, iToLM M.! u)) xs, k)

minimumI :: (DirectedGraph t, Adjacency t, Mutable t)
         => t Int -> ([(Int, Int)], Int)
minimumI d 
  | numArcs d == 0 = ([], 0)
  | otherwise = 
      let loops = [(v,v) | v <- vertices d, arcExists d (v,v)]
          d' = foldr removeArc d loops
      in foldr 
               (\c (x, l) -> 
                  let h = inducedSubgraph d' $ S.fromList c
                      (x', l') = fromJust $ guessArc h (numArcs h - 1) (foldr addVertex (empty d) (vertices d))
                  in (x ++ x', l + l')) (loops, length loops) $
               strongComponents d'

guessArc d kMax fixed  =
  case filter (\e -> not $ arcExists fixed e) $ arcs d of
    [] -> Just ([], 0)
    e@(v,u) : _ ->
      let fixed' = addArc e fixed
          forced = filter (\(x,y) -> reachable fixed' y x) $ arcs d
          dKeep = foldr removeArc d forced
          csKeep = strongComponents dKeep
          kForced = length forced
          dRemove = removeArc e d
          -- csRemove = strongComponents dRemove
      in
      if kMax <= 0 then
        Nothing
      else if kForced > kMax then
        separateVertices' d kMax fixed [] [e]
        -- minimumIComponents dRemove (kMax - 1) csRemove fixed
      else if reachable fixed u v then
        separateVertices' d kMax (addArc (u,v) fixed) [] [e]
      else
        case minimumIComponents dKeep (kMax - kForced) csKeep fixed' of
          Nothing -> separateVertices' d kMax fixed [] [e] -- minimumIComponents dRemove (kMax - 1) csRemove fixed
          keep@(Just (es, kKeep)) ->
            case separateVertices' d (min kMax (kKeep - 1)) fixed [] [e] of
              Nothing -> Just (forced ++ es, kKeep + kForced)
              solution -> solution

separateVertices d kMax fixed [] = 
  let cs = strongComponents d
  in minimumIComponents d kMax cs fixed
separateVertices d kMax fixed ((v,u) : forbidden)
  | arcExists fixed (v,u) = Nothing
  | otherwise = 
    let directArc = arcExists d (v,u)
        d' = if directArc then removeArc (v,u) d else d
        ps = maxArcDisjointPaths d' v u
        cutSize = length ps
        kMax' = if directArc then kMax - 1 else kMax
        addSolution (hs, k) =
          if directArc then
            ((v,u) : hs, k + 1)
          else
            (hs, k)
    in -- D.trace (show (take 10 forbidden, take 10 $ arcs fixed)) $ 
    if cutSize > kMax' then
      Nothing
    else
      case ps of
        [] -> separateVertices d' kMax' fixed forbidden
        ((_ : w : _) : _) ->
          let (w : _) = drop 1 $ head ps
          in
          fmap addSolution $
            if arcExists fixed (v,w) then
              separateVertices' d' kMax' fixed ((v,u) : forbidden) [(w,v), (w,u)]
            else if reachable fixed w v then
              separateVertices' d' kMax' fixed ((v, u) : forbidden) [(v, w)]
            else
              case separateVertices' d' kMax' (addArc (v,w) fixed) ((v,u) : forbidden) [(w,v), (w,u) ]  of
                Nothing -> separateVertices' d' kMax' fixed ((v, u) : forbidden) [(v, w)]
                solution@(Just (hs, k')) -> 
                  (separateVertices' d' (k' - 1) fixed ((v, u) : forbidden)) [(v, w)]
                  `mplus`
                  solution

separateVertices' d kMax fixed forbidden newForbidden = 
  let newRemoved = filter (arcExists d) newForbidden
      kNew = length newRemoved
      d' = foldr removeArc d newRemoved
      kMax' = kMax - kNew
  in 
  if kMax' < 0 then
    Nothing
  else
    fmap (\(hs, k) -> (newRemoved ++ hs, k + kNew)) $
      separateVertices d' kMax' fixed (newForbidden ++ forbidden)

--minimumI' d kMax fixed
--  | numArcs d <= 1 = Just ([], 0)
--  | kMax <= 0 = Nothing
--  | otherwise = 
--      let forced = filter (\(v,u) -> reachable fixed u v) $ arcs d
--          d' = foldr removeArc d forced
--          kForced = length forced
--          candidates = [ (e, d'', cs) | e <- arcs d'
--                       , let d'' = removeArc e d'
--                       , let cs = strongComponents d''
--                       , not $ arcExists fixed e
--                       -- , any (\c -> null $ drop 1 c) cs
--                       ]
--          bestChoice solution _ [] _ = solution
--          bestChoice solution kMax' ((e, d'', cs) : xs) fixed' = 
--            case minimumIComponents d''
--                                    (if isNothing solution then kMax' - 1 else kMax' - 2)
--                                    cs
--                                    fixed
--            of
--              Nothing -> bestChoice solution kMax' xs (addArc e fixed)
--              (Just (es, k)) -> bestChoice (Just (e : es, k + 1)) (k + 1) xs (addArc e fixed)
--      in 
--      if kForced > kMax then
--        Nothing
--      else
--        bestChoice Nothing (kMax - kForced) candidates fixed
        
minimumIComponents d kMax cs fixed
  | length (filter (\c -> not $ null $ drop 1 c) cs) > kMax = Nothing
  | otherwise = minComponents kMax cs
  where
    minComponents kMax' [] = Just ([], 0)
    minComponents kMax' (c':cs') = 
      let h = inducedSubgraph d $ S.fromList c'
      in case guessArc h kMax' fixed of
          Nothing -> Nothing
          Just (xs, k0) -> fmap (\(ys, k') -> (xs ++ ys, k0 + k')) $ minComponents (kMax' - k0) cs'