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
  { forall a. Guess a -> Set a
aSet :: S.Set a
  , forall a. Guess a -> Set a
bSet :: S.Set a
  , forall a. Guess a -> Int
numberOfVertices :: Int
  , forall a. Guess a -> Set a
aCandidates :: S.Set a
  , forall a. Guess a -> Set a
bCandidates :: S.Set a
  }

vertexWellLinkedPair :: t a -> Int -> Maybe (Set a, Set a)
vertexWellLinkedPair t a
d Int
k = 
  let remapV :: a -> a
remapV a
v = (a
v a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
3
--       | v `mod` 2 == 0 = v `div` 2
--       | otherwise = (v - 1) `div` 2
      dSplit :: t a
dSplit = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc
                     ((a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t a -> t a
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t a
d) ([a] -> t a) -> [a] -> t a
forall a b. (a -> b) -> a -> b
$ 
                                      [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
v, a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
2]
                                             | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
                                             ]
                     ) ([(a, a)] -> t a) -> [(a, a)] -> t a
forall a b. (a -> b) -> a -> b
$
                     [(a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
2, a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
u) | (a
v, a
u) <- t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d] 
                     [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [[(a, a)]] -> [(a, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
v, a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1), (a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
2)]
                               | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d]
  in ((Set a, Set a) -> (Set a, Set a))
-> Maybe (Set a, Set a) -> Maybe (Set a, Set a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Set a
a,Set a
b) -> ((a -> a) -> Set a -> Set a
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map a -> a
forall {a}. Integral a => a -> a
remapV Set a
a , (a -> a) -> Set a -> Set a
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map a -> a
forall {a}. Integral a => a -> a
remapV Set a
b)) (Maybe (Set a, Set a) -> Maybe (Set a, Set a))
-> Maybe (Set a, Set a) -> Maybe (Set a, Set a)
forall a b. (a -> b) -> a -> b
$ 
          t a -> Int -> Guess a -> Maybe (Set a, Set a)
forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t, Integral a, Eq a,
 Ord a) =>
t a -> Int -> Guess a -> Maybe (Set a, Set a)
edgeWellLinkedPair' t a
dSplit Int
k
            Guess
            { aSet :: Set a
aSet = Set a
forall a. Set a
S.empty
            , bSet :: Set a
bSet = Set a
forall a. Set a
S.empty
            , aCandidates :: Set a
aCandidates = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
v -> a
3 a -> a -> a
forall a. Num a => a -> a -> a
* a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
            , bCandidates :: Set a
bCandidates = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
v -> a
3 a -> a -> a
forall a. Num a => a -> a -> a
* a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
            , numberOfVertices :: Int
numberOfVertices = Int
0
            }
          

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

restrictBCandidates :: t a -> a -> Guess a -> Guess a
restrictBCandidates t a
d a
a Guess a
guess = 
  let reachA :: [a]
reachA = t a -> a -> [a]
forall {t :: * -> *} {a}. (Adjacency t, Ord a) => t a -> a -> [a]
reach t a
d a
a
  in Guess a
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 :: forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t, Num a, Ord a, Eq a) =>
t a -> a -> Guess a -> Guess a
restrictACandidates t a
d a
b Guess a
guess = 
  let revReachB :: [a]
revReachB = t a -> a -> [a]
forall {t :: * -> *} {a}. (Adjacency t, Ord a) => t a -> a -> [a]
reverseReach t a
d a
b
  in Guess a
guess
      { aCandidates = (aCandidates guess) `S.intersection` (S.fromList revReachB)
      }