-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT]
-- | Minimum-Spanning-Tree Algorithms

module Data.Graph.Inductive.Query.MST (
    msTreeAt,msTree,
    -- * Path in MST
    msPath,
    -- * Types used
    LRTree
) where

import           Data.Graph.Inductive.Graph
import qualified Data.Graph.Inductive.Internal.Heap     as H
import           Data.Graph.Inductive.Internal.RootPath


newEdges :: LPath b -> Context a b -> [H.Heap b (LPath b)]
newEdges :: LPath b -> Context a b -> [Heap b (LPath b)]
newEdges (LP [LNode b]
p) (Adj b
_,Node
_,a
_,Adj b
s) = ((b, Node) -> Heap b (LPath b)) -> Adj b -> [Heap b (LPath b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(b
l,Node
v)->b -> LPath b -> Heap b (LPath b)
forall a b. a -> b -> Heap a b
H.unit b
l ([LNode b] -> LPath b
forall a. [LNode a] -> LPath a
LP ((Node
v,b
l)LNode b -> [LNode b] -> [LNode b]
forall a. a -> [a] -> [a]
:[LNode b]
p))) Adj b
s

prim :: (Graph gr,Real b) => H.Heap b (LPath b) -> gr a b -> LRTree b
prim :: Heap b (LPath b) -> gr a b -> LRTree b
prim Heap b (LPath b)
h gr a b
g | Heap b (LPath b) -> Bool
forall a b. Heap a b -> Bool
H.isEmpty Heap b (LPath b)
h Bool -> Bool -> Bool
|| gr a b -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
isEmpty gr a b
g = []
prim Heap b (LPath b)
h gr a b
g =
    case Node -> gr a b -> Decomp gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
v gr a b
g of
         (Just Context a b
c,gr a b
g')  -> LPath b
pLPath b -> LRTree b -> LRTree b
forall a. a -> [a] -> [a]
:Heap b (LPath b) -> gr a b -> LRTree b
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Heap b (LPath b) -> gr a b -> LRTree b
prim ([Heap b (LPath b)] -> Heap b (LPath b)
forall a b. Ord a => [Heap a b] -> Heap a b
H.mergeAll (Heap b (LPath b)
h'Heap b (LPath b) -> [Heap b (LPath b)] -> [Heap b (LPath b)]
forall a. a -> [a] -> [a]
:LPath b -> Context a b -> [Heap b (LPath b)]
forall b a. LPath b -> Context a b -> [Heap b (LPath b)]
newEdges LPath b
p Context a b
c)) gr a b
g'
         (Maybe (Context a b)
Nothing,gr a b
g') -> Heap b (LPath b) -> gr a b -> LRTree b
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Heap b (LPath b) -> gr a b -> LRTree b
prim Heap b (LPath b)
h' gr a b
g'
    where (b
_,p :: LPath b
p@(LP ((Node
v,b
_):[LNode b]
_)),Heap b (LPath b)
h') = Heap b (LPath b) -> (b, LPath b, Heap b (LPath b))
forall a b. Ord a => Heap a b -> (a, b, Heap a b)
H.splitMin Heap b (LPath b)
h

msTreeAt :: (Graph gr,Real b) => Node -> gr a b -> LRTree b
msTreeAt :: Node -> gr a b -> LRTree b
msTreeAt Node
v = Heap b (LPath b) -> gr a b -> LRTree b
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Heap b (LPath b) -> gr a b -> LRTree b
prim (b -> LPath b -> Heap b (LPath b)
forall a b. a -> b -> Heap a b
H.unit b
0 ([LNode b] -> LPath b
forall a. [LNode a] -> LPath a
LP [(Node
v,b
0)]))

msTree :: (Graph gr,Real b) => gr a b -> LRTree b
msTree :: gr a b -> LRTree b
msTree gr a b
g = Node -> gr a b -> LRTree b
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Node -> gr a b -> LRTree b
msTreeAt Node
v gr a b
g where ((Adj b
_,Node
v,a
_,Adj b
_),gr a b
_) = gr a b -> ((Adj b, Node, a, Adj b), gr a b)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> GDecomp gr a b
matchAny gr a b
g

msPath :: LRTree b -> Node -> Node -> Path
msPath :: LRTree b -> Node -> Node -> Path
msPath LRTree b
t Node
a Node
b = Path -> Path -> Path
joinPaths (Node -> LRTree b -> Path
forall a. Node -> LRTree a -> Path
getLPathNodes Node
a LRTree b
t) (Node -> LRTree b -> Path
forall a. Node -> LRTree a -> Path
getLPathNodes Node
b LRTree b
t)

joinPaths :: Path -> Path -> Path
joinPaths :: Path -> Path -> Path
joinPaths Path
p = Node -> Path -> Path -> Path
joinAt (Path -> Node
forall a. [a] -> a
head Path
p) Path
p

joinAt :: Node -> Path -> Path -> Path
joinAt :: Node -> Path -> Path -> Path
joinAt Node
_ (Node
v:Path
vs) (Node
w:Path
ws) | Node
vNode -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==Node
w = Node -> Path -> Path -> Path
joinAt Node
v Path
vs Path
ws
joinAt Node
x Path
p      Path
q             = Path -> Path
forall a. [a] -> [a]
reverse Path
pPath -> Path -> Path
forall a. [a] -> [a] -> [a]
++(Node
xNode -> Path -> Path
forall a. a -> [a] -> [a]
:Path
q)