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