Internal.hs

module HGraph.Directed.Packing.Cycles.Internal where

import HGraph.Directed
import HGraph.Directed.Connectivity

import Prelude hiding (maximum)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe

-- | A packing of pairwise arc-disjoint cycles of maximum size.
arcMaximumI d =
  let (ld, iToA) = lineDigraphI d
      iToA' = M.fromList iToA
      (packing', k) = maximumI ld
  in (map (map fst . map (iToA' M.!)) packing', k)

-- | Computes a packing of pairwise disjoint cycles of maximum size.
maximum :: (DirectedGraph t, Mutable t, Adjacency t) => t a -> ([[a]], Int)
maximum d = 
  let (di, iToL) = linearizeVertices d
      (cs, k) =  maximumI di
      labels = M.fromList iToL
  in (map (map (labels M.!)) cs, k)

-- | Computes a packing of pairwise disjoint cycles of maximum size.
-- Vertices of the input digraph must be labeled with integers from `0` to `n - 1`.
maximumI :: (DirectedGraph t, Mutable t, Adjacency t) => t Int -> ([[Int]], Int)
maximumI d
  | numVertices d == 0 = ([], 0)
  | otherwise = 
      let loops = [v | v <- vertices d, arcExists d (v,v)]
          d' = foldr removeVertex d loops
          components = strongComponents d'
      in foldr
           (\c (cs', k') ->
              let h = inducedSubgraph d $ S.fromList c
                  (cs1, k1) = fromJust $ maximumI' h 1
              in (cs1 ++ cs', k1 + k')
           )
           (map (:[]) loops, length loops)
           (filter (\c -> not $ null $ drop 1 c) components)

maximumI' d kMin 
  | numVertices d <= 1 && kMin <= 0 = Just ([], 0)
  | numVertices d < (2 * kMin) = Nothing
  | numArcs d == 0 = Nothing
  | otherwise = guessArc d kMin $ head (arcs d)

maximumIWeak d kMin = 
  let components = strongComponents d
      ds = map (\c -> inducedSubgraph d $ S.fromList c) $ filter (\c -> not $ null $ drop 1 c) components
      kMaxs = map (\h -> (numVertices h) `div` 2) ds
      kMax = sum kMaxs
      solution = fst $ foldr 
                 (\(h, kMaxH) (solution, kMaxRest) ->
                     case solution of
                       Nothing -> (Nothing, kMaxRest)
                       Just (cs', k') ->
                         case maximumI' h $ max 1 (kMin - kMaxRest - k' - kMaxH) of
                           Nothing -> (Nothing, kMaxRest)
                           Just (csH, kH) -> (Just (csH ++ cs', kH + k'), kMaxRest - kMaxH))
                 ( Just ([], 0)
                 , kMax)
                 (zip ds kMaxs)
  in case solution of
      Nothing -> Nothing
      sol@(Just ([], 0)) ->
        if kMin <= 0 then
          sol
        else
          Nothing
      sol@(Just (cs, k)) ->
        if k >= kMin then
          sol
        else
          Nothing

guessArc d kMin (v,u) = 
  let withArc = packArc d kMin [u,v] v (v,u)
      d' = removeArc (v,u) d
      withoutArc kMin' = maximumIWeak d' kMin'
  in case withArc of
      Nothing -> withoutArc kMin
      Just (cs, k) -> 
        case withoutArc (k + 1) of
          Nothing -> withArc
          Just (cs', k') -> if k' > k then Just (cs', k') else withArc

packArc :: (DirectedGraph t, Mutable t, Adjacency t) 
        => t Int -> Int -> [Int] -> Int -> (Int, Int) -> Maybe ([[Int]], Int)
packArc d kMin cv w (v,u)
  | u == w = 
    let h = foldr removeVertex d $ drop 1 cv
    in case maximumIWeak h (kMin - 1) of
          Nothing -> Nothing
          Just (cs, k) -> Just ((reverse $ drop 1 cv) : cs, k + 1)
  | otherwise = 
      let d1 = foldr removeArc d
                            [(v,x) | x <- outneighbors d v
                            , x /= u]
          d' = foldr removeArc 
                     d1
                     [(x,u) | x <- inneighbors d1 u
                     , x /= v]
          candidates = [ x | x <- 
                              if v == w then
                                outneighbors d' u
                              else
                                filter (/=v) $ outneighbors d' u
                       , reachable d' x w
                       ]
          bestChoice solution _ [] = solution
          bestChoice solution kMin' (x:xs) = 
            case packArc d' kMin' (x : cv) w (u,x) of
              Nothing -> bestChoice solution kMin' xs
              sol@(Just (cs, k')) -> bestChoice sol (k' + 1) xs
      in 
      if arcExists d (u, w) then
        bestChoice Nothing kMin [w]
      else
        bestChoice Nothing kMin candidates