VertexCover.hs

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 g = map (itol M.!) $ fromJust $ foldr mplus Nothing $ map (vertexCoverAtMost' gi) [1..]
  where
    (gi, assocs) = linearizeVertices g
    itol = M.fromList assocs

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

vertexCoverAtMost' :: (Mutable t, UndirectedGraph t, Adjacency t) => t Int -> Int -> Maybe [Int]
vertexCoverAtMost' g k
  | k < 0 = Nothing
  | k' < 0 = Nothing
  | numEdges g' == 0 = Just sol'
  | numEdges g' > k * k = Nothing
  | otherwise =
    (fmap (v:) $ vertexCoverAtMost' (removeVertex g' v) (k'-1)) `mplus` 
    (fmap (nv++) $ vertexCoverAtMost' (foldr (flip removeVertex) g' (v:nv)) (k' - (degree g' v)))
    where
      (g', sol', k') = reduce g k
      e' = edges g'
      (v,_) = head e'
      nv = neighbors g' v

reduce g k = reduce' g k [] (vertices g) S.empty

reduce' g k sol [] _ = (g,sol,k)
reduce' g k sol (v:vs) visited
  | v `S.member` visited = reduce' g k sol vs visited
  | d == 1 = reduce' (removeVertex (removeVertex g v) u) (k-1) (u:sol) (un ++ vs)
                     ( (S.insert v $ S.insert u visited) `S.difference`
                       (S.delete v $ S.fromList un))
  | d == 0 = reduce' (removeVertex g v) k sol vs (S.insert v visited)
  | d > k = reduce' (removeVertex g v) (k - 1) (v:sol) (vn ++ vs)
                    ((S.insert v visited) `S.difference` (S.fromList vn))
  | otherwise = reduce' g k sol vs (S.insert v visited)
  where
    d = degree g v
    u = head $ neighbors g v
    un = neighbors g u
    vn = neighbors g v