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 :: forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t) =>
t a -> ([a], Int)
minimum t a
d =
  let (t Int
di, [(Int, a)]
iToL) = t a -> (t Int, [(Int, a)])
forall a. t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t a
d
      iToLM :: Map Int a
iToLM = [(Int, a)] -> Map Int a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, a)]
iToL
      ([Int]
xs, Int
k) = t Int -> ([Int], Int)
forall (t :: * -> *).
(DirectedGraph t, Adjacency t, Mutable t) =>
t Int -> ([Int], Int)
minimumI t Int
di
  in ( (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
v -> Map Int a
iToLM Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v) [Int]
xs, Int
k)

minimumI :: (DirectedGraph t, Adjacency t, Mutable t)
         => t Int -> ([Int], Int)
minimumI :: forall (t :: * -> *).
(DirectedGraph t, Adjacency t, Mutable t) =>
t Int -> ([Int], Int)
minimumI t Int
d 
  | t Int -> Integer
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t Int
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = ([], Int
0)
  | Bool
otherwise = 
      let loops :: [Int]
loops = [Int
v | Int
v <- t Int -> [Int]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t Int
d, t Int -> (Int, Int) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t Int
d (Int
v,Int
v)]
          d' :: t Int
d' = (Int -> t Int -> t Int) -> t Int -> [Int] -> t Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> t Int -> t Int
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
removeVertex t Int
d [Int]
loops
      in ([Int] -> ([Int], Int) -> ([Int], Int))
-> ([Int], Int) -> [[Int]] -> ([Int], Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 
               (\[Int]
c ([Int]
x, Int
l) -> 
                  let h :: t Int
h = t Int -> Set Int -> t Int
forall {t :: * -> *} {a}.
(Mutable t, DirectedGraph t, Ord a) =>
t a -> Set a -> t a
inducedSubgraph t Int
d' (Set Int -> t Int) -> Set Int -> t Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList [Int]
c
                      ([Int]
x', Int
l') = Maybe ([Int], Int) -> ([Int], Int)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ([Int], Int) -> ([Int], Int))
-> Maybe ([Int], Int) -> ([Int], Int)
forall a b. (a -> b) -> a -> b
$ t Int -> Int -> Maybe ([Int], Int)
forall {t :: * -> *} {a}.
(DirectedGraph t, Mutable t, Adjacency t, Ord a) =>
t a -> Int -> Maybe ([a], Int)
minimumI' t Int
h (t Int -> Int
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                  in ([Int]
x [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
x', Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l')) ([Int]
loops, [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
loops) ([[Int]] -> ([Int], Int)) -> [[Int]] -> ([Int], Int)
forall a b. (a -> b) -> a -> b
$
               t Int -> [[Int]]
forall {t :: * -> *} {a}.
(DirectedGraph t, Adjacency t, Mutable t, Ord a) =>
t a -> [[a]]
strongComponents t Int
d'

minimumI' :: t a -> Int -> Maybe ([a], Int)
minimumI' t a
d Int
kMax
  | t a -> Integer
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
d Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
1 = ([a], Int) -> Maybe ([a], Int)
forall a. a -> Maybe a
Just ([], Int
0)
  | Int
kMax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Maybe ([a], Int)
forall a. Maybe a
Nothing
  | Bool
otherwise = 
      let candidates :: [(a, t a, [[a]])]
candidates = [ (a
v, t a
d', [[a]]
cs) | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
                       , let d' :: t a
d' = a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
removeVertex a
v t a
d
                       , let cs :: [[a]]
cs = t a -> [[a]]
forall {t :: * -> *} {a}.
(DirectedGraph t, Adjacency t, Mutable t, Ord a) =>
t a -> [[a]]
strongComponents t a
d'
                       -- , any (\c -> null $ drop 1 c) cs
                       ]
          bestChoice :: Maybe ([a], Int) -> Int -> [(a, t a, [[a]])] -> Maybe ([a], Int)
bestChoice Maybe ([a], Int)
solution Int
_ [] = Maybe ([a], Int)
solution
          bestChoice Maybe ([a], Int)
solution Int
kMax' ((a
v, t a
d', [[a]]
cs) : [(a, t a, [[a]])]
xs) = 
            case t a -> Int -> [[a]] -> Maybe ([a], Int)
minimumIComponents t a
d'
                                    (if Maybe ([a], Int) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ([a], Int)
solution then Int
kMax' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
kMax' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
                                    [[a]]
cs
            of
              Maybe ([a], Int)
Nothing -> Maybe ([a], Int) -> Int -> [(a, t a, [[a]])] -> Maybe ([a], Int)
bestChoice Maybe ([a], Int)
solution Int
kMax' [(a, t a, [[a]])]
xs
              (Just ([a]
vs, Int
k)) -> Maybe ([a], Int) -> Int -> [(a, t a, [[a]])] -> Maybe ([a], Int)
bestChoice (([a], Int) -> Maybe ([a], Int)
forall a. a -> Maybe a
Just (a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
vs, Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(a, t a, [[a]])]
xs
      in Maybe ([a], Int) -> Int -> [(a, t a, [[a]])] -> Maybe ([a], Int)
bestChoice Maybe ([a], Int)
forall a. Maybe a
Nothing Int
kMax [(a, t a, [[a]])]
candidates
        
minimumIComponents :: t a -> Int -> [[a]] -> Maybe ([a], Int)
minimumIComponents t a
d Int
kMax [[a]]
cs
  | [[a]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\[a]
c -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
c) [[a]]
cs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
kMax = Maybe ([a], Int)
forall a. Maybe a
Nothing
  | Bool
otherwise = Int -> [[a]] -> Maybe ([a], Int)
minComponents Int
kMax [[a]]
cs
  where
    minComponents :: Int -> [[a]] -> Maybe ([a], Int)
minComponents Int
kMax' [] = ([a], Int) -> Maybe ([a], Int)
forall a. a -> Maybe a
Just ([], Int
0)
    minComponents Int
kMax' ([a]
c':[[a]]
cs') = 
      let h :: t a
h = t a -> Set a -> t a
forall {t :: * -> *} {a}.
(Mutable t, DirectedGraph t, Ord a) =>
t a -> Set a -> t a
inducedSubgraph t a
d (Set a -> t a) -> Set a -> t a
forall a b. (a -> b) -> a -> b
$ [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
c'
      in case t a -> Int -> Maybe ([a], Int)
minimumI' t a
h Int
kMax' of
          Maybe ([a], Int)
Nothing -> Maybe ([a], Int)
forall a. Maybe a
Nothing
          Just ([a]
xs, Int
k0) -> (([a], Int) -> ([a], Int)) -> Maybe ([a], Int) -> Maybe ([a], Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([a]
ys, Int
k') -> ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys, Int
k0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k')) (Maybe ([a], Int) -> Maybe ([a], Int))
-> Maybe ([a], Int) -> Maybe ([a], Int)
forall a b. (a -> b) -> a -> b
$ Int -> [[a]] -> Maybe ([a], Int)
minComponents (Int
kMax' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k0) [[a]]
cs'