hgraph-1.10.0.0: src/HGraph/Directed/Connectivity/OneWayWellLinkedness/Internal.hs

module HGraph.Directed.Connectivity.OneWayWellLinkedness.Internal where

import HGraph.Directed
import HGraph.Directed.Connectivity.Flow
import HGraph.Directed.Connectivity.Basic
import HGraph.Utils
import qualified Data.Set as S
import qualified Data.Map as M

import Control.Monad

data Guess a = Guess
  { aSet :: S.Set a
  , bSet :: S.Set a
  , numberOfVertices :: Int
  , aCandidates :: S.Set a
  , bCandidates :: S.Set a
  }

vertexWellLinkedPair d k = 
  let remapV v = (v - 1) `div` 3
--       | v `mod` 2 == 0 = v `div` 2
--       | otherwise = (v - 1) `div` 2
      dSplit = foldr addArc
                     (foldr addVertex (empty d) $ 
                                      concat [[3*v, 3*v + 1, 3*v + 2]
                                             | v <- vertices d
                                             ]
                     ) $
                     [(3*v + 2, 3*u) | (v, u) <- arcs d] 
                     ++ concat [ [(3*v, 3*v + 1), (3*v + 1, 3*v + 2)]
                               | v <- vertices d]
  in fmap (\(a,b) -> (S.map remapV a , S.map remapV b)) $ 
          edgeWellLinkedPair' dSplit k
            Guess
            { aSet = S.empty
            , bSet = S.empty
            , aCandidates = S.fromList $ map (\v -> 3 * v + 1) $ vertices d
            , bCandidates = S.fromList $ map (\v -> 3 * v + 1) $ vertices d
            , numberOfVertices = 0
            }
          

edgeWellLinkedPair d k = 
  edgeWellLinkedPair' d k
    Guess
    { aSet = S.empty
    , bSet = S.empty
    , aCandidates = S.fromList $ vertices d
    , bCandidates = S.fromList $ vertices d
    , numberOfVertices = 0
    }
edgeWellLinkedPair' :: (DirectedGraph t, Adjacency t, Mutable t, Integral a, Eq a, Ord a) => t a -> Int -> Guess a -> Maybe (S.Set a, S.Set a)
edgeWellLinkedPair' d k guess
  | numberOfVertices guess == k = Just (aSet guess, bSet guess)
  | otherwise = addAVertex d k guess

addAVertex :: (DirectedGraph t, Adjacency t, Mutable t, Integral a, Ord a, Eq a) => t a -> Int -> Guess a -> Maybe (S.Set a, S.Set a)
addAVertex d k guess
  | S.null $ aCandidates guess = Nothing
  | otherwise = 
     guessOne (\a guess' -> 
                let cuttableSets = 
                      [ (a',b')
                      | k' <- [1.. (numberOfVertices guess')]
                      , a'' <- choose (k' - 1) $ S.toList $ aSet guess'
                      , let a' = a : a''
                      , b' <- choose k' $ S.toList $ bSet guess'
                      , let s = numVertices d
                      , let t = s + 1
                      , let d' = foldr addArc (foldr addVertex d [s,t]) $ 
                                              [(s, a) | a <- a']
                                              ++ [(b, t) | b <- b']
                      , maxFlowValue d' s t /= k'
                      ]
                in if null cuttableSets then
                      addBVertex d k $
                        restrictBCandidates d a $
                                     guess'{ aSet = S.insert a (aSet guess')
                                           , aCandidates = S.delete a (aCandidates guess')
                                           , bCandidates = S.delete a (bCandidates guess')
                                           }
                   else
                      Nothing
              )
              (\a guess' -> guess'{aCandidates = S.delete a (aCandidates guess')})
              guess
              $ S.toList $ aCandidates guess

addBVertex :: (DirectedGraph t, Adjacency t, Mutable t, Integral a, Ord a, Eq a) => t a -> Int -> Guess a -> Maybe (S.Set a, S.Set a)
addBVertex d k guess
  | S.null $ bCandidates guess = Nothing
  | otherwise = 
     guessOne
      (\b guess' -> 
            let cuttableSets = 
                  [ (a',b')
                  | k' <- [0.. (numberOfVertices guess')]
                  , b'' <- choose (k') $ S.toList $ bSet guess'
                  , let b' = b : b''
                  , a' <- choose (k' + 1) $ S.toList $ aSet guess'
                  , let s = numVertices d
                  , let t = s + 1
                  , let d' = foldr addArc (foldr addVertex d [s,t]) $ 
                                          [(s, va) | va <- a']
                                          ++ [(vb, t) | vb <- b']
                  , maxFlowValue d' s t /= (k' + 1)
                  ]
            in if null cuttableSets then
                  edgeWellLinkedPair' d k $ restrictACandidates d b $ 
                                     guess'{ bSet = S.insert b $ bSet guess'
                                           , bCandidates = S.delete b $ bCandidates guess'
                                           , aCandidates = S.delete b $ aCandidates guess'
                                           , numberOfVertices = 1 + numberOfVertices guess'
                                           }
               else
                  Nothing
      )
      (\b guess' -> guess'{bCandidates = S.delete b (bCandidates guess')}
      )
      guess
      $ S.toList $ bCandidates guess

restrictBCandidates d a guess = 
  let reachA = reach d a
  in guess
      { bCandidates = (bCandidates guess) `S.intersection` (S.fromList reachA)
      }

restrictACandidates :: (DirectedGraph t, Adjacency t, Mutable t, Num a, Ord a, Eq a) => t a -> a -> Guess a -> Guess a
restrictACandidates d b guess = 
  let revReachB = reverseReach d b
  in guess
      { aCandidates = (aCandidates guess) `S.intersection` (S.fromList revReachB)
      }