module Data.Graph.Inductive.Query.ArtPoint(
    ap
) where

import Data.Graph.Inductive.Graph


------------------------------------------------------------------------------
-- Tree for storing the DFS numbers and back edges for each node in the graph.
-- Each node in this tree is of the form (v,n,b) where v is the vertex number,
-- n is its DFS number and b is the list of nodes (and their DFS numbers) that
-- lead to back back edges for that vertex v.
------------------------------------------------------------------------------
data DFSTree a = B (a,a,[(a,a)]) [DFSTree a]
     deriving (DFSTree a -> DFSTree a -> Bool
(DFSTree a -> DFSTree a -> Bool)
-> (DFSTree a -> DFSTree a -> Bool) -> Eq (DFSTree a)
forall a. Eq a => DFSTree a -> DFSTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DFSTree a -> DFSTree a -> Bool
$c/= :: forall a. Eq a => DFSTree a -> DFSTree a -> Bool
== :: DFSTree a -> DFSTree a -> Bool
$c== :: forall a. Eq a => DFSTree a -> DFSTree a -> Bool
Eq, Int -> DFSTree a -> ShowS
[DFSTree a] -> ShowS
DFSTree a -> String
(Int -> DFSTree a -> ShowS)
-> (DFSTree a -> String)
-> ([DFSTree a] -> ShowS)
-> Show (DFSTree a)
forall a. Show a => Int -> DFSTree a -> ShowS
forall a. Show a => [DFSTree a] -> ShowS
forall a. Show a => DFSTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DFSTree a] -> ShowS
$cshowList :: forall a. Show a => [DFSTree a] -> ShowS
show :: DFSTree a -> String
$cshow :: forall a. Show a => DFSTree a -> String
showsPrec :: Int -> DFSTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> DFSTree a -> ShowS
Show, ReadPrec [DFSTree a]
ReadPrec (DFSTree a)
Int -> ReadS (DFSTree a)
ReadS [DFSTree a]
(Int -> ReadS (DFSTree a))
-> ReadS [DFSTree a]
-> ReadPrec (DFSTree a)
-> ReadPrec [DFSTree a]
-> Read (DFSTree a)
forall a. Read a => ReadPrec [DFSTree a]
forall a. Read a => ReadPrec (DFSTree a)
forall a. Read a => Int -> ReadS (DFSTree a)
forall a. Read a => ReadS [DFSTree a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DFSTree a]
$creadListPrec :: forall a. Read a => ReadPrec [DFSTree a]
readPrec :: ReadPrec (DFSTree a)
$creadPrec :: forall a. Read a => ReadPrec (DFSTree a)
readList :: ReadS [DFSTree a]
$creadList :: forall a. Read a => ReadS [DFSTree a]
readsPrec :: Int -> ReadS (DFSTree a)
$creadsPrec :: forall a. Read a => Int -> ReadS (DFSTree a)
Read)

------------------------------------------------------------------------------
-- Tree for storing the DFS and low numbers for each node in the graph.
-- Each node in this tree is of the form (v,n,l) where v is the vertex number,
-- n is its DFS number and l is its low number.
------------------------------------------------------------------------------
data LOWTree a = Brc (a,a,a) [LOWTree a]
     deriving (LOWTree a -> LOWTree a -> Bool
(LOWTree a -> LOWTree a -> Bool)
-> (LOWTree a -> LOWTree a -> Bool) -> Eq (LOWTree a)
forall a. Eq a => LOWTree a -> LOWTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LOWTree a -> LOWTree a -> Bool
$c/= :: forall a. Eq a => LOWTree a -> LOWTree a -> Bool
== :: LOWTree a -> LOWTree a -> Bool
$c== :: forall a. Eq a => LOWTree a -> LOWTree a -> Bool
Eq, Int -> LOWTree a -> ShowS
[LOWTree a] -> ShowS
LOWTree a -> String
(Int -> LOWTree a -> ShowS)
-> (LOWTree a -> String)
-> ([LOWTree a] -> ShowS)
-> Show (LOWTree a)
forall a. Show a => Int -> LOWTree a -> ShowS
forall a. Show a => [LOWTree a] -> ShowS
forall a. Show a => LOWTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LOWTree a] -> ShowS
$cshowList :: forall a. Show a => [LOWTree a] -> ShowS
show :: LOWTree a -> String
$cshow :: forall a. Show a => LOWTree a -> String
showsPrec :: Int -> LOWTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> LOWTree a -> ShowS
Show, ReadPrec [LOWTree a]
ReadPrec (LOWTree a)
Int -> ReadS (LOWTree a)
ReadS [LOWTree a]
(Int -> ReadS (LOWTree a))
-> ReadS [LOWTree a]
-> ReadPrec (LOWTree a)
-> ReadPrec [LOWTree a]
-> Read (LOWTree a)
forall a. Read a => ReadPrec [LOWTree a]
forall a. Read a => ReadPrec (LOWTree a)
forall a. Read a => Int -> ReadS (LOWTree a)
forall a. Read a => ReadS [LOWTree a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LOWTree a]
$creadListPrec :: forall a. Read a => ReadPrec [LOWTree a]
readPrec :: ReadPrec (LOWTree a)
$creadPrec :: forall a. Read a => ReadPrec (LOWTree a)
readList :: ReadS [LOWTree a]
$creadList :: forall a. Read a => ReadS [LOWTree a]
readsPrec :: Int -> ReadS (LOWTree a)
$creadsPrec :: forall a. Read a => Int -> ReadS (LOWTree a)
Read)

------------------------------------------------------------------------------
-- Finds the back edges for a given node.
------------------------------------------------------------------------------
getBackEdges :: Node -> [[(Node,Int)]] -> [(Node,Int)]
getBackEdges :: Int -> [[(Int, Int)]] -> [(Int, Int)]
getBackEdges Int
_ [] = []
getBackEdges Int
v [[(Int, Int)]]
ls   = ([(Int, Int)] -> (Int, Int)) -> [[(Int, Int)]] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Int)] -> (Int, Int)
forall a. [a] -> a
head (([(Int, Int)] -> Bool) -> [[(Int, Int)]] -> [[(Int, Int)]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int, Int) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Int
v,Int
0)) ([[(Int, Int)]] -> [[(Int, Int)]]
forall a. [a] -> [a]
tail [[(Int, Int)]]
ls))

------------------------------------------------------------------------------
-- Builds a DFS tree for a given graph. Each element (v,n,b) in the tree
-- contains: the node number v, the DFS number n, and a list of backedges b.
------------------------------------------------------------------------------
dfsTree :: (Graph gr) => Int -> Node -> [Node] -> [[(Node,Int)]] ->
                       gr a b -> ([DFSTree Int],gr a b,Int)
dfsTree :: Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
dfsTree Int
n Int
_ []      [[(Int, Int)]]
_ gr a b
g             = ([],gr a b
g,Int
n)
dfsTree Int
n Int
_ [Int]
_       [[(Int, Int)]]
_ gr a b
g | gr a b -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
isEmpty gr a b
g = ([],gr a b
g,Int
n)
dfsTree Int
n Int
u (Int
v:[Int]
vs) [[(Int, Int)]]
ls gr a b
g = case Int -> gr a b -> Decomp gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Int -> gr a b -> Decomp gr a b
match Int
v gr a b
g of
                            (Maybe (Context a b)
Nothing, gr a b
g1) -> Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
forall (gr :: * -> * -> *) a b.
Graph gr =>
Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
dfsTree Int
n Int
u [Int]
vs [[(Int, Int)]]
ls gr a b
g1
                            (Just Context a b
c , gr a b
g1) -> ((Int, Int, [(Int, Int)]) -> [DFSTree Int] -> DFSTree Int
forall a. (a, a, [(a, a)]) -> [DFSTree a] -> DFSTree a
B (Int
v,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,[(Int, Int)]
bck) [DFSTree Int]
tsDFSTree Int -> [DFSTree Int] -> [DFSTree Int]
forall a. a -> [a] -> [a]
:[DFSTree Int]
ts', gr a b
g3, Int
k)
                             where  bck :: [(Int, Int)]
bck        = Int -> [[(Int, Int)]] -> [(Int, Int)]
getBackEdges Int
v [[(Int, Int)]]
ls
                                    ([DFSTree Int]
ts, gr a b
g2,Int
m) = Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
forall (gr :: * -> * -> *) a b.
Graph gr =>
Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
dfsTree (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
v [Int]
sc [[(Int, Int)]]
ls' gr a b
g1
                                    ([DFSTree Int]
ts',gr a b
g3,Int
k) = Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
forall (gr :: * -> * -> *) a b.
Graph gr =>
Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
dfsTree Int
m Int
v [Int]
vs [[(Int, Int)]]
ls gr a b
g2
                                    ls' :: [[(Int, Int)]]
ls'        = ((Int
v,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
sc')[(Int, Int)] -> [[(Int, Int)]] -> [[(Int, Int)]]
forall a. a -> [a] -> [a]
:[[(Int, Int)]]
ls
                                    sc' :: [(Int, Int)]
sc'        = (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x->(Int
x,Int
0)) [Int]
sc
                                    sc :: [Int]
sc         = Context a b -> [Int]
forall a b. Context a b -> [Int]
suc' Context a b
c

------------------------------------------------------------------------------
-- Finds the minimum between a dfs number and a list of back edges' dfs
-- numbers.
------------------------------------------------------------------------------
minbckEdge :: Int -> [(Node,Int)] -> Int
minbckEdge :: Int -> [(Int, Int)] -> Int
minbckEdge Int
n [] = Int
n
minbckEdge Int
n [(Int, Int)]
bs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd [(Int, Int)]
bs))

------------------------------------------------------------------------------
-- Returns the low number for a node in a subtree.
------------------------------------------------------------------------------
getLow :: LOWTree Int -> Int
getLow :: LOWTree Int -> Int
getLow (Brc (Int
_,Int
_,Int
l) [LOWTree Int]
_) = Int
l

------------------------------------------------------------------------------
-- Builds a low tree from a DFS tree. Each element (v,n,low) in the tree
-- contains: the node number v, the DFS number n, and the low number low.
------------------------------------------------------------------------------
lowTree :: DFSTree Int -> LOWTree Int
lowTree :: DFSTree Int -> LOWTree Int
lowTree (B (Int
v,Int
n,[]  ) [] ) = (Int, Int, Int) -> [LOWTree Int] -> LOWTree Int
forall a. (a, a, a) -> [LOWTree a] -> LOWTree a
Brc (Int
v,Int
n,Int
n) []
lowTree (B (Int
v,Int
n,[(Int, Int)]
bcks) [] ) = (Int, Int, Int) -> [LOWTree Int] -> LOWTree Int
forall a. (a, a, a) -> [LOWTree a] -> LOWTree a
Brc (Int
v,Int
n,Int -> [(Int, Int)] -> Int
minbckEdge Int
n [(Int, Int)]
bcks) []
lowTree (B (Int
v,Int
n,[(Int, Int)]
bcks) [DFSTree Int]
trs) = (Int, Int, Int) -> [LOWTree Int] -> LOWTree Int
forall a. (a, a, a) -> [LOWTree a] -> LOWTree a
Brc (Int
v,Int
n,Int
lowv) [LOWTree Int]
ts
                             where lowv :: Int
lowv     = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> [(Int, Int)] -> Int
minbckEdge Int
n [(Int, Int)]
bcks) Int
lowChild
                                   lowChild :: Int
lowChild = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((LOWTree Int -> Int) -> [LOWTree Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map LOWTree Int -> Int
getLow [LOWTree Int]
ts)
                                   ts :: [LOWTree Int]
ts       = (DFSTree Int -> LOWTree Int) -> [DFSTree Int] -> [LOWTree Int]
forall a b. (a -> b) -> [a] -> [b]
map DFSTree Int -> LOWTree Int
lowTree [DFSTree Int]
trs

------------------------------------------------------------------------------
-- Builds a low tree for a given graph. Each element (v,n,low) in the tree
-- contains: the node number v, the DFS number n, and the low number low.
------------------------------------------------------------------------------
getLowTree :: (Graph gr) => gr a b -> Node -> LOWTree Int
getLowTree :: gr a b -> Int -> LOWTree Int
getLowTree gr a b
g Int
v = DFSTree Int -> LOWTree Int
lowTree ([DFSTree Int] -> DFSTree Int
forall a. [a] -> a
head [DFSTree Int]
dfsf)
                  where ([DFSTree Int]
dfsf, gr a b
_, Int
_) = Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
forall (gr :: * -> * -> *) a b.
Graph gr =>
Int
-> Int
-> [Int]
-> [[(Int, Int)]]
-> gr a b
-> ([DFSTree Int], gr a b, Int)
dfsTree Int
0 Int
0 [Int
v] [] gr a b
g

------------------------------------------------------------------------------
-- Tests if a node in a subtree is an articulation point. An non-root node v
-- is an articulation point iff there exists at least one child w of v such
-- that lowNumber(w) >= dfsNumber(v). The root node is an articulation point
-- iff it has two or more children.
------------------------------------------------------------------------------
isap :: LOWTree Int -> Bool
isap :: LOWTree Int -> Bool
isap (Brc (Int
_,Int
_,Int
_) []) = Bool
False
isap (Brc (Int
_,Int
1,Int
_) [LOWTree Int]
ts) = [LOWTree Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LOWTree Int]
ts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
isap (Brc (Int
_,Int
n,Int
_) [LOWTree Int]
ts) = Bool -> Bool
not ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ch)
                        where ch :: [Int]
ch = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter ( Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
n) ((LOWTree Int -> Int) -> [LOWTree Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map LOWTree Int -> Int
getLow [LOWTree Int]
ts)

------------------------------------------------------------------------------
-- Finds the articulation points by traversing the low tree.
------------------------------------------------------------------------------
arp :: LOWTree Int -> [Node]
arp :: LOWTree Int -> [Int]
arp (Brc (Int
v,Int
1,Int
_) [LOWTree Int]
ts) | [LOWTree Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LOWTree Int]
ts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1         = Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:(LOWTree Int -> [Int]) -> [LOWTree Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LOWTree Int -> [Int]
arp [LOWTree Int]
ts
                     | Bool
otherwise             =   (LOWTree Int -> [Int]) -> [LOWTree Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LOWTree Int -> [Int]
arp [LOWTree Int]
ts
arp (Brc (Int
v,Int
n,Int
l) [LOWTree Int]
ts) | LOWTree Int -> Bool
isap ((Int, Int, Int) -> [LOWTree Int] -> LOWTree Int
forall a. (a, a, a) -> [LOWTree a] -> LOWTree a
Brc (Int
v,Int
n,Int
l) [LOWTree Int]
ts) = Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:(LOWTree Int -> [Int]) -> [LOWTree Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LOWTree Int -> [Int]
arp [LOWTree Int]
ts
                     | Bool
otherwise             =   (LOWTree Int -> [Int]) -> [LOWTree Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LOWTree Int -> [Int]
arp [LOWTree Int]
ts

------------------------------------------------------------------------------
-- Finds the articulation points of a graph starting at a given node.
------------------------------------------------------------------------------
artpoints :: (Graph gr) => gr a b -> Node -> [Node]
artpoints :: gr a b -> Int -> [Int]
artpoints gr a b
g Int
v = LOWTree Int -> [Int]
arp (gr a b -> Int -> LOWTree Int
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> LOWTree Int
getLowTree gr a b
g Int
v)

{-|
   Finds the articulation points for a connected undirected graph,
   by using the low numbers criteria:

   a) The root node is an articulation point iff it has two or more children.

   b) An non-root node v is an articulation point iff there exists at least
      one child w of v such that lowNumber(w) >= dfsNumber(v).
-}
ap :: (Graph gr) => gr a b -> [Node]
ap :: gr a b -> [Int]
ap gr a b
g = gr a b -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
artpoints gr a b
g Int
v where ((Adj b
_,Int
v,a
_,Adj b
_),gr a b
_) = gr a b -> ((Adj b, Int, a, Adj b), gr a b)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> GDecomp gr a b
matchAny gr a b
g