module HGraph.Undirected.Solvers.VertexCover
        ( minimumVertexCover
        , vertexCoverAtMost
        )
where

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

minimumVertexCover :: (Mutable t, UndirectedGraph t, Adjacency t) => t a -> [a]
minimumVertexCover :: t a -> [a]
minimumVertexCover t a
g = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int a
itol Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.!) ([Int] -> [a]) -> [Int] -> [a]
forall a b. (a -> b) -> a -> b
$ Maybe [Int] -> [Int]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Int] -> [Int]) -> Maybe [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Maybe [Int] -> Maybe [Int] -> Maybe [Int])
-> Maybe [Int] -> [Maybe [Int]] -> Maybe [Int]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe [Int] -> Maybe [Int] -> Maybe [Int]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe [Int]
forall a. Maybe a
Nothing ([Maybe [Int]] -> Maybe [Int]) -> [Maybe [Int]] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe [Int]) -> [Int] -> [Maybe [Int]]
forall a b. (a -> b) -> [a] -> [b]
map (t Int -> Int -> Maybe [Int]
forall (t :: * -> *).
(Mutable t, UndirectedGraph t, Adjacency t) =>
t Int -> Int -> Maybe [Int]
vertexCoverAtMost' t Int
gi) [Int
1..]
  where
    (t Int
gi, [(Int, a)]
assocs) = t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
UndirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t a
g
    itol :: Map Int a
itol = [(Int, a)] -> Map Int a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, a)]
assocs

vertexCoverAtMost :: (Mutable t, UndirectedGraph t, Adjacency t) => t a -> Int -> Maybe [a]
vertexCoverAtMost :: t a -> Int -> Maybe [a]
vertexCoverAtMost t a
g Int
k = ([Int] -> [a]) -> Maybe [Int] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int a
itol Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.!)) (Maybe [Int] -> Maybe [a]) -> Maybe [Int] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ t Int -> Int -> Maybe [Int]
forall (t :: * -> *).
(Mutable t, UndirectedGraph t, Adjacency t) =>
t Int -> Int -> Maybe [Int]
vertexCoverAtMost' t Int
gi Int
k
  where
    (t Int
gi, [(Int, a)]
assocs) = t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
UndirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t a
g
    itol :: Map Int a
itol = [(Int, a)] -> Map Int a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, a)]
assocs

vertexCoverAtMost' :: (Mutable t, UndirectedGraph t, Adjacency t) => t Int -> Int -> Maybe [Int]
vertexCoverAtMost' :: t Int -> Int -> Maybe [Int]
vertexCoverAtMost' t Int
g Int
k
  | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe [Int]
forall a. Maybe a
Nothing
  | Int
k' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe [Int]
forall a. Maybe a
Nothing
  | t Int -> Integer
forall (t :: * -> *) b a.
(UndirectedGraph t, Integral b) =>
t a -> b
numEdges t Int
g' Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
sol'
  | t Int -> Int
forall (t :: * -> *) b a.
(UndirectedGraph t, Integral b) =>
t a -> b
numEdges t Int
g' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k = Maybe [Int]
forall a. Maybe a
Nothing
  | Bool
otherwise =
    (([Int] -> [Int]) -> Maybe [Int] -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) (Maybe [Int] -> Maybe [Int]) -> Maybe [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ t Int -> Int -> Maybe [Int]
forall (t :: * -> *).
(Mutable t, UndirectedGraph t, Adjacency t) =>
t Int -> Int -> Maybe [Int]
vertexCoverAtMost' (t Int -> Int -> t Int
forall (t :: * -> *) a. Mutable t => t a -> a -> t a
removeVertex t Int
g' Int
v) (Int
k'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Maybe [Int] -> Maybe [Int] -> Maybe [Int]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` 
    (([Int] -> [Int]) -> Maybe [Int] -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Int]
nv[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++) (Maybe [Int] -> Maybe [Int]) -> Maybe [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ t Int -> Int -> Maybe [Int]
forall (t :: * -> *).
(Mutable t, UndirectedGraph t, Adjacency t) =>
t Int -> Int -> Maybe [Int]
vertexCoverAtMost' ((Int -> t Int -> t Int) -> t Int -> [Int] -> t Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((t Int -> Int -> t Int) -> Int -> t Int -> t Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip t Int -> Int -> t Int
forall (t :: * -> *) a. Mutable t => t a -> a -> t a
removeVertex) t Int
g' (Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
nv)) (Int
k' Int -> Int -> Int
forall a. Num a => a -> a -> a
- (t Int -> Int -> Int
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
degree t Int
g' Int
v)))
    where
      (t Int
g', [Int]
sol', Int
k') = t Int -> Int -> (t Int, [Int], Int)
forall (t :: * -> *) a a.
(Adjacency t, Integral a, Mutable t, Ord a) =>
t a -> a -> (t a, [a], a)
reduce t Int
g Int
k
      e' :: [(Int, Int)]
e' = t Int -> [(Int, Int)]
forall (t :: * -> *) a. UndirectedGraph t => t a -> [(a, a)]
edges t Int
g'
      (Int
v,Int
_) = [(Int, Int)] -> (Int, Int)
forall a. [a] -> a
head [(Int, Int)]
e'
      nv :: [Int]
nv = t Int -> Int -> [Int]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
neighbors t Int
g' Int
v

reduce :: t a -> a -> (t a, [a], a)
reduce t a
g a
k = t a -> a -> [a] -> [a] -> Set a -> (t a, [a], a)
forall (t :: * -> *) a a.
(Adjacency t, Integral a, Mutable t, Ord a) =>
t a -> a -> [a] -> [a] -> Set a -> (t a, [a], a)
reduce' t a
g a
k [] (t a -> [a]
forall (t :: * -> *) a. UndirectedGraph t => t a -> [a]
vertices t a
g) Set a
forall a. Set a
S.empty

reduce' :: t a -> a -> [a] -> [a] -> Set a -> (t a, [a], a)
reduce' t a
g a
k [a]
sol [] Set a
_ = (t a
g,[a]
sol,a
k)
reduce' t a
g a
k [a]
sol (a
v:[a]
vs) Set a
visited
  | a
v a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
visited = t a -> a -> [a] -> [a] -> Set a -> (t a, [a], a)
reduce' t a
g a
k [a]
sol [a]
vs Set a
visited
  | a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = t a -> a -> [a] -> [a] -> Set a -> (t a, [a], a)
reduce' (t a -> a -> t a
forall (t :: * -> *) a. Mutable t => t a -> a -> t a
removeVertex (t a -> a -> t a
forall (t :: * -> *) a. Mutable t => t a -> a -> t a
removeVertex t a
g a
v) a
u) (a
ka -> a -> a
forall a. Num a => a -> a -> a
-a
1) (a
ua -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
sol) ([a]
un [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
vs)
                     ( (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
v (Set a -> Set a) -> Set a -> Set a
forall a b. (a -> b) -> a -> b
$ a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
u Set a
visited) Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.difference`
                       (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
v (Set a -> Set a) -> Set a -> Set a
forall a b. (a -> b) -> a -> b
$ [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
un))
  | a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = t a -> a -> [a] -> [a] -> Set a -> (t a, [a], a)
reduce' (t a -> a -> t a
forall (t :: * -> *) a. Mutable t => t a -> a -> t a
removeVertex t a
g a
v) a
k [a]
sol [a]
vs (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
v Set a
visited)
  | a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
k = t a -> a -> [a] -> [a] -> Set a -> (t a, [a], a)
reduce' (t a -> a -> t a
forall (t :: * -> *) a. Mutable t => t a -> a -> t a
removeVertex t a
g a
v) (a
k a -> a -> a
forall a. Num a => a -> a -> a
- a
1) (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
sol) ([a]
vn [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
vs)
                    ((a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
v Set a
visited) Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
vn))
  | Bool
otherwise = t a -> a -> [a] -> [a] -> Set a -> (t a, [a], a)
reduce' t a
g a
k [a]
sol [a]
vs (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
v Set a
visited)
  where
    d :: a
d = t a -> a -> a
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
degree t a
g a
v
    u :: a
u = [a] -> a
forall a. [a] -> a
head ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
neighbors t a
g a
v
    un :: [a]
un = t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
neighbors t a
g a
u
    vn :: [a]
vn = t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
neighbors t a
g a
v