Internal.hs

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

import Prelude hiding (minimum)

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

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

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

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

minimumI' d kMax
  | numVertices d <= 1 = Just ([], 0)
  | kMax <= 0 = Nothing
  | otherwise = 
      let candidates = [ (v, d', cs) | v <- vertices d
                       , let d' = removeVertex v d
                       , let cs = strongComponents d'
                       -- , any (\c -> null $ drop 1 c) cs
                       ]
          bestChoice solution _ [] = solution
          bestChoice solution kMax' ((v, d', cs) : xs) = 
            case minimumIComponents d'
                                    (if isNothing solution then kMax' - 1 else kMax' - 2)
                                    cs
            of
              Nothing -> bestChoice solution kMax' xs
              (Just (vs, k)) -> bestChoice (Just (v : vs, k + 1)) (k + 1) xs
      in bestChoice Nothing kMax candidates
        
minimumIComponents d kMax cs
  | 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 minimumI' h kMax' of
          Nothing -> Nothing
          Just (xs, k0) -> fmap (\(ys, k') -> (xs ++ ys, k0 + k')) $ minComponents (kMax' - k0) cs'