Karger's MinCut realization

Graph.hs

{-# LANGUAGE UnicodeSyntax #-}
module Graph where

import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import System.Random (randomRIO)

import qualified Data.IntMap as IntMap

type Graph = IntMap.IntMap [Int]

toGraph ∷ [(Int,[Int])] → Graph
toGraph = IntMap.fromList

edgesNumber ∷ Graph → Int
edgesNumber = (`div` 2) . sum . map length . IntMap.elems

size ∷ Graph → Int
size = length . IntMap.keys

randomEdge ∷ Graph → IO (Int, Int)
randomEdge adjacencyMap = do
  v1 ← rndFrom . IntMap.keys $ adjacencyMap
  v2 ← rndFrom $ adjacencyMap IntMap.! v1
  return (v1,v2)
    where rndFrom λ = (λ !!) . subtract 1 <$> randomRIO (1, length λ)

move ∷ Int → Int → Graph → Graph
move v1 v2 α = IntMap.delete v2 . IntMap.adjust (++ (α IntMap.! v2)) v1 $ α

-- | Remove loops and rename v1 to v2
correct ∷ Int → Int → Graph → Graph
correct v1 v2 = IntMap.mapWithKey (\ε → filter (/= ε) . rename)
  where rename = map (\x -> if x == v2 then v1 else x)

mergeVertices ∷ Graph → IO Graph
mergeVertices graph = do
  (v1,v2) ← randomEdge graph
  return . correct v1 v2 $ move v1 v2 graph

untilToM ∷ Monad μ ⇒ (a → Bool) → (a → μ a) → a → μ a
untilToM predicate function value = do
  result ← mresult
  if predicate result
    then mresult
    else untilToM predicate function result
  where mresult = function value

minCut ∷ Graph → IO Int
minCut γ = minimum <$> replicateM times minCut_
  where times = round . (* fromIntegral n) . log $ fromIntegral n
        n = size γ
        minCut_ = edgesNumber <$> untilToM ((<= 2) . size) mergeVertices γ