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

minimumI :: (DirectedGraph t, Adjacency t, Mutable t)
         => t Int -> ([(Int, Int)], Int)
minimumI :: forall (t :: * -> *).
(DirectedGraph t, Adjacency t, Mutable t) =>
t Int -> ([(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
numArcs t Int
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = ([], Int
0)
  | Bool
otherwise = 
      let loops :: [(Int, Int)]
loops = [(Int
v,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, Int) -> t Int -> t Int) -> t Int -> [(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, Int) -> t Int -> t Int
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
removeArc t Int
d [(Int, Int)]
loops
      in ([Int] -> ([(Int, Int)], Int) -> ([(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, 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, Int)]
x', Int
l') = Maybe ([(Int, Int)], Int) -> ([(Int, Int)], Int)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ([(Int, Int)], Int) -> ([(Int, Int)], Int))
-> Maybe ([(Int, Int)], Int) -> ([(Int, Int)], Int)
forall a b. (a -> b) -> a -> b
$ t Int -> Int -> t Int -> Maybe ([(Int, Int)], Int)
forall {t :: * -> *} {a} {t :: * -> *}.
(DirectedGraph t, Mutable t, Mutable t, Adjacency t, Adjacency t,
 Integral a) =>
t a -> Int -> t a -> Maybe ([(a, a)], Int)
guessArc 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
numArcs t Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ((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
addVertex (t Int -> t Int
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t Int
d) (t Int -> [Int]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t Int
d))
                  in ([(Int, Int)]
x [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int)]
x', Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l')) ([(Int, Int)]
loops, [(Int, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
loops) ([[Int]] -> ([(Int, 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'

guessArc :: t a -> Int -> t a -> Maybe ([(a, a)], Int)
guessArc t a
d Int
kMax t a
fixed  =
  case ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a, a)
e -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ t a -> (a, a) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
fixed (a, a)
e) ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d of
    [] -> ([(a, a)], Int) -> Maybe ([(a, a)], Int)
forall a. a -> Maybe a
Just ([], Int
0)
    e :: (a, a)
e@(a
v,a
u) : [(a, a)]
_ ->
      let fixed' :: t a
fixed' = (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc (a, a)
e t a
fixed
          forced :: [(a, a)]
forced = ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
x,a
y) -> t a -> a -> a -> Bool
forall {a} {t :: * -> *}.
(Adjacency t, Ord a) =>
t a -> a -> a -> Bool
reachable t a
fixed' a
y a
x) ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d
          dKeep :: t a
dKeep = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
removeArc t a
d [(a, a)]
forced
          csKeep :: [[a]]
csKeep = t a -> [[a]]
forall {t :: * -> *} {a}.
(DirectedGraph t, Adjacency t, Mutable t, Ord a) =>
t a -> [[a]]
strongComponents t a
dKeep
          kForced :: Int
kForced = [(a, a)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, a)]
forced
          dRemove :: t a
dRemove = (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
removeArc (a, a)
e t a
d
          -- csRemove = strongComponents dRemove
      in
      if Int
kMax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then
        Maybe ([(a, a)], Int)
forall a. Maybe a
Nothing
      else if Int
kForced Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
kMax then
        t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d Int
kMax t a
fixed [] [(a, a)
e]
        -- minimumIComponents dRemove (kMax - 1) csRemove fixed
      else if t a -> a -> a -> Bool
forall {a} {t :: * -> *}.
(Adjacency t, Ord a) =>
t a -> a -> a -> Bool
reachable t a
fixed a
u a
v then
        t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d Int
kMax ((a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc (a
u,a
v) t a
fixed) [] [(a, a)
e]
      else
        case t a -> Int -> [[a]] -> t a -> Maybe ([(a, a)], Int)
minimumIComponents t a
dKeep (Int
kMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
kForced) [[a]]
csKeep t a
fixed' of
          Maybe ([(a, a)], Int)
Nothing -> t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d Int
kMax t a
fixed [] [(a, a)
e] -- minimumIComponents dRemove (kMax - 1) csRemove fixed
          keep :: Maybe ([(a, a)], Int)
keep@(Just ([(a, a)]
es, Int
kKeep)) ->
            case t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
kMax (Int
kKeep Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) t a
fixed [] [(a, a)
e] of
              Maybe ([(a, a)], Int)
Nothing -> ([(a, a)], Int) -> Maybe ([(a, a)], Int)
forall a. a -> Maybe a
Just ([(a, a)]
forced [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a, a)]
es, Int
kKeep Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kForced)
              Maybe ([(a, a)], Int)
solution -> Maybe ([(a, a)], Int)
solution

separateVertices :: t a -> Int -> t a -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices t a
d Int
kMax t a
fixed [] = 
  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
  in t a -> Int -> [[a]] -> t a -> Maybe ([(a, a)], Int)
minimumIComponents t a
d Int
kMax [[a]]
cs t a
fixed
separateVertices t a
d Int
kMax t a
fixed ((a
v,a
u) : [(a, a)]
forbidden)
  | t a -> (a, a) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
fixed (a
v,a
u) = Maybe ([(a, a)], Int)
forall a. Maybe a
Nothing
  | Bool
otherwise = 
    let directArc :: Bool
directArc = t a -> (a, a) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
d (a
v,a
u)
        d' :: t a
d' = if Bool
directArc then (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
removeArc (a
v,a
u) t a
d else t a
d
        ps :: [[a]]
ps = t a -> a -> a -> [[a]]
forall (t :: * -> *) a.
(Mutable t, DirectedGraph t, Adjacency t, Integral a) =>
t a -> a -> a -> [[a]]
maxArcDisjointPaths t a
d' a
v a
u
        cutSize :: Int
cutSize = [[a]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
ps
        kMax' :: Int
kMax' = if Bool
directArc then Int
kMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
kMax
        addSolution :: ([(a, a)], Int) -> ([(a, a)], Int)
addSolution ([(a, a)]
hs, Int
k) =
          if Bool
directArc then
            ((a
v,a
u) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
hs, Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          else
            ([(a, a)]
hs, Int
k)
    in -- D.trace (show (take 10 forbidden, take 10 $ arcs fixed)) $ 
    if Int
cutSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
kMax' then
      Maybe ([(a, a)], Int)
forall a. Maybe a
Nothing
    else
      case [[a]]
ps of
        [] -> t a -> Int -> t a -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices t a
d' Int
kMax' t a
fixed [(a, a)]
forbidden
        ((a
_ : a
w : [a]
_) : [[a]]
_) ->
          let (a
w : [a]
_) = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [a]
forall a. HasCallStack => [a] -> a
head [[a]]
ps
          in
          (([(a, a)], Int) -> ([(a, a)], Int))
-> Maybe ([(a, a)], Int) -> Maybe ([(a, 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, a)], Int) -> ([(a, a)], Int)
addSolution (Maybe ([(a, a)], Int) -> Maybe ([(a, a)], Int))
-> Maybe ([(a, a)], Int) -> Maybe ([(a, a)], Int)
forall a b. (a -> b) -> a -> b
$
            if t a -> (a, a) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
fixed (a
v,a
w) then
              t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d' Int
kMax' t a
fixed ((a
v,a
u) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
forbidden) [(a
w,a
v), (a
w,a
u)]
            else if t a -> a -> a -> Bool
forall {a} {t :: * -> *}.
(Adjacency t, Ord a) =>
t a -> a -> a -> Bool
reachable t a
fixed a
w a
v then
              t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d' Int
kMax' t a
fixed ((a
v, a
u) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
forbidden) [(a
v, a
w)]
            else
              case t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d' Int
kMax' ((a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc (a
v,a
w) t a
fixed) ((a
v,a
u) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
forbidden) [(a
w,a
v), (a
w,a
u) ]  of
                Maybe ([(a, a)], Int)
Nothing -> t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d' Int
kMax' t a
fixed ((a
v, a
u) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
forbidden) [(a
v, a
w)]
                solution :: Maybe ([(a, a)], Int)
solution@(Just ([(a, a)]
hs, Int
k')) -> 
                  (t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d' (Int
k' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) t a
fixed ((a
v, a
u) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
forbidden)) [(a
v, a
w)]
                  Maybe ([(a, a)], Int)
-> Maybe ([(a, a)], Int) -> Maybe ([(a, a)], Int)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                  Maybe ([(a, a)], Int)
solution

separateVertices' :: t a -> Int -> t a -> [(a, a)] -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices' t a
d Int
kMax t a
fixed [(a, a)]
forbidden [(a, a)]
newForbidden = 
  let newRemoved :: [(a, a)]
newRemoved = ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (t a -> (a, a) -> Bool
forall a. t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
d) [(a, a)]
newForbidden
      kNew :: Int
kNew = [(a, a)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, a)]
newRemoved
      d' :: t a
d' = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
removeArc t a
d [(a, a)]
newRemoved
      kMax' :: Int
kMax' = Int
kMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
kNew
  in 
  if Int
kMax' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then
    Maybe ([(a, a)], Int)
forall a. Maybe a
Nothing
  else
    (([(a, a)], Int) -> ([(a, a)], Int))
-> Maybe ([(a, a)], Int) -> Maybe ([(a, 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, a)]
hs, Int
k) -> ([(a, a)]
newRemoved [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a, a)]
hs, Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kNew)) (Maybe ([(a, a)], Int) -> Maybe ([(a, a)], Int))
-> Maybe ([(a, a)], Int) -> Maybe ([(a, a)], Int)
forall a b. (a -> b) -> a -> b
$
      t a -> Int -> t a -> [(a, a)] -> Maybe ([(a, a)], Int)
separateVertices t a
d' Int
kMax' t a
fixed ([(a, a)]
newForbidden [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a, a)]
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 :: t a -> Int -> [[a]] -> t a -> Maybe ([(a, a)], Int)
minimumIComponents t a
d Int
kMax [[a]]
cs t a
fixed
  | [[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, a)], Int)
forall a. Maybe a
Nothing
  | Bool
otherwise = Int -> [[a]] -> Maybe ([(a, a)], Int)
minComponents Int
kMax [[a]]
cs
  where
    minComponents :: Int -> [[a]] -> Maybe ([(a, a)], Int)
minComponents Int
kMax' [] = ([(a, a)], Int) -> Maybe ([(a, 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 -> t a -> Maybe ([(a, a)], Int)
guessArc t a
h Int
kMax' t a
fixed of
          Maybe ([(a, a)], Int)
Nothing -> Maybe ([(a, a)], Int)
forall a. Maybe a
Nothing
          Just ([(a, a)]
xs, Int
k0) -> (([(a, a)], Int) -> ([(a, a)], Int))
-> Maybe ([(a, a)], Int) -> Maybe ([(a, 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, a)]
ys, Int
k') -> ([(a, a)]
xs [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a, a)]
ys, Int
k0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k')) (Maybe ([(a, a)], Int) -> Maybe ([(a, a)], Int))
-> Maybe ([(a, a)], Int) -> Maybe ([(a, a)], Int)
forall a b. (a -> b) -> a -> b
$ Int -> [[a]] -> Maybe ([(a, a)], Int)
minComponents (Int
kMax' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k0) [[a]]
cs'