fgl 5.5.0.1 → 5.5.1.0

raw patch · 26 files changed

+271/−463 lines, 26 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog +18/−0
• Data/Graph/Inductive/Basic.hs +10/−10
• Data/Graph/Inductive/Example.hs +0/−1
• Data/Graph/Inductive/Graph.hs +1/−1
• Data/Graph/Inductive/Internal/FiniteMap.hs +0/−212
• Data/Graph/Inductive/Internal/Heap.hs +3/−3
• Data/Graph/Inductive/Internal/RootPath.hs +1/−1
• Data/Graph/Inductive/Internal/Thread.hs +19/−19
• Data/Graph/Inductive/Monad/IOArray.hs +4/−7
• Data/Graph/Inductive/NodeMap.hs +23/−22
• Data/Graph/Inductive/Query.hs +7/−7
• Data/Graph/Inductive/Query/ArtPoint.hs +3/−4
• Data/Graph/Inductive/Query/BCC.hs +2/−21
• Data/Graph/Inductive/Query/BFS.hs +7/−8
• Data/Graph/Inductive/Query/DFS.hs +42/−29
• Data/Graph/Inductive/Query/Dominators.hs +7/−7
• Data/Graph/Inductive/Query/GVD.hs +4/−4
• Data/Graph/Inductive/Query/Indep.hs +4/−5
• Data/Graph/Inductive/Query/MST.hs +7/−8
• Data/Graph/Inductive/Query/MaxFlow.hs +7/−9
• Data/Graph/Inductive/Query/MaxFlow2.hs +13/−23
• Data/Graph/Inductive/Query/Monad.hs +23/−15
• Data/Graph/Inductive/Query/SP.hs +3/−3
• Data/Graph/Inductive/Query/TransClos.hs +0/−1
• Data/Graph/Inductive/Tree.hs +54/−38
• fgl.cabal +9/−5

@@ -1,3 +1,21 @@+5.5.1.0+-------++* Support added for GHC 7.10 by Herbert Valerio Riedel.++* Additional DFS query functions added by Conrad Parker.++* Repository location changed to GitHub.++* Code cleanup:++    - Replaced usage of internal FiniteMap copy with Data.Map and+      Data.Set from the containers library.++    - Remove usage of data type contexts.++    - Use newtypes where applicable.+ 5.5.0.1 ------- 

@@ -12,18 +12,18 @@     hasLoop,isSimple,     -- * Tree Operations     postorder, postorderF, preorder, preorderF-) +) where   import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Internal.Thread (threadMaybe,threadList)+import Data.Graph.Inductive.Internal.Thread (threadList, threadMaybe)  import Data.List (nub) import Data.Tree  -- | Reverse the direction of all edges.-grev :: DynGraph gr => gr a b -> gr a b +grev :: DynGraph gr => gr a b -> gr a b grev = gmap (\(p,v,l,s)->(s,v,l,p))  -- | Make the graph undirected, i.e. for every edge from A to B, there@@ -83,24 +83,24 @@ gfold1 f d b = threadGraph d (\c->gfoldn f d b (f c)) gfoldn f d b = threadList b (gfold1 f d b) --- gfold :: ((Context a b) -> [Node]) -> ((Node,a) -> c -> d) -> +-- gfold :: ((Context a b) -> [Node]) -> ((Node,a) -> c -> d) -> --          (Maybe d -> c -> c) -> c -> [Node] -> Graph a b -> c -- gfold f d b u l g = fst (gfoldn f d b u l g)  -- type Dir a b    = (Context a b) -> [Node]  -- direction of fold -- type Dagg a b c = (Node,a) -> b -> c       -- depth aggregation -- type Bagg a b   = (Maybe a -> b -> b,b)    -- breadth/level aggregation--- +-- -- gfold :: (Dir a b) -> (Dagg a c d) -> (Bagg d c) -> [Node] -> Graph a b -> c -- gfold f d (b,u) l g = fst (gfoldn f d b u l g)  -- | Directed graph fold. gfold :: Graph gr =>   ((Context a b) -> [Node])    -- ^ direction of fold-		    -> ((Context a b) -> c -> d)    -- ^ depth aggregation-		    -> (Maybe d -> c -> c, c)	    -- ^ breadth\/level aggregation-		    -> [Node]-		    -> gr a b-		    -> c+        -> ((Context a b) -> c -> d)    -- ^ depth aggregation+        -> (Maybe d -> c -> c, c)      -- ^ breadth\/level aggregation+        -> [Node]+        -> gr a b+        -> c gfold f d b l g = fst (gfoldn f d b l g)  -- not finished yet ...

@@ -186,4 +186,3 @@                 [(1,4,3),(2,3,3),(2,4,3),(4,2,4),(4,6,2),                  (5,2,5),(5,3,6),(5,7,5),(5,8,6),                  (6,5,3),(6,7,2),(7,8,3),(8,7,3)]-

@@ -246,6 +246,7 @@ -- | Insert a 'LNode' into the 'Graph'. insNode :: DynGraph gr => LNode a -> gr a b -> gr a b insNode (v,l) = (([],v,l,[])&)+{-# NOINLINE [0] insNode #-}  -- | Insert a 'LEdge' into the 'Graph'. insEdge :: DynGraph gr => LEdge b -> gr a b -> gr a b@@ -478,4 +479,3 @@ -- | Pretty-print the graph to stdout. prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO () prettyPrint = putStr . prettify-

@@ -1,212 +0,0 @@--- | Simple Finite Maps.--- This implementation provides several useful methods that Data.FiniteMap--- does not.--module Data.Graph.Inductive.Internal.FiniteMap(-    -- * Type-    FiniteMap(..),-    -- * Operations-    emptyFM,addToFM,delFromFM,-    updFM,-    accumFM,-    splitFM,-    isEmptyFM,sizeFM,lookupFM,elemFM,-    rangeFM,-    minFM,maxFM,predFM,succFM,-    splitMinFM,-    fmToList-) where--import Data.Maybe (isJust)--data FiniteMap a b =-    Empty | Node Int (FiniteMap a b) (a,b) (FiniteMap a b)-    deriving (Eq)--instance Functor (FiniteMap a) where-  fmap _ Empty = Empty-  fmap f (Node h l (i,x) r) = Node h (fmap f l) (i, f x) (fmap f r)--------------------------------------------------------------------------- UTILITIES---------------------------------------------------------------------------- pretty printing----showsMap :: (Show a,Show b,Ord a) => FiniteMap a b -> ShowS-showsMap Empty            = id-showsMap (Node _ l (i,x) r) = showsMap l . (' ':) .-                              shows i . ("->"++) . shows x . showsMap r--instance (Show a,Show b,Ord a) => Show (FiniteMap a b) where-  showsPrec _ m = showsMap m----- other----splitMax :: Ord a => FiniteMap a b -> (FiniteMap a b,(a,b))-splitMax (Node _ l x Empty) = (l,x)-splitMax (Node _ l x r)     = (avlBalance l x m,y) where (m,y) = splitMax r-splitMax Empty        = error "splitMax on empty FiniteMap"--merge :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b-merge l Empty = l-merge Empty r = r-merge l r     = avlBalance l' x r where (l',x) = splitMax l---------------------------------------------------------------------------- MAIN FUNCTIONS-------------------------------------------------------------------------emptyFM :: Ord a => FiniteMap a b-emptyFM  = Empty--addToFM :: Ord a => FiniteMap a b -> a -> b -> FiniteMap a b-addToFM Empty            i x              =  node Empty (i,x) Empty-addToFM (Node h l (j,y) r) i x-    | i<j        =  avlBalance (addToFM l i x) (j,y) r-    | i>j        =  avlBalance l (j,y) (addToFM r i x)-    | otherwise  =  Node h l (j,x) r---- | applies function to stored entry-updFM :: Ord a => FiniteMap a b -> a -> (b -> b) -> FiniteMap a b-updFM Empty              _ _              =  Empty-updFM (Node h l (j,x) r) i f-           | i<j        =  let l' = updFM l i f in l' `seq` Node h l' (j,x) r-           | i>j        =  let r' = updFM r i f in r' `seq` Node h l (j,x) r'-           | otherwise  =  Node h l (j,f x) r---- | defines or aggregates entries-accumFM :: Ord a => FiniteMap a b -> a -> (b -> b -> b) -> b -> FiniteMap a b-accumFM Empty              i _ x              =  node Empty (i,x) Empty-accumFM (Node h l (j,y) r) i f x-    | i<j        =  avlBalance (accumFM l i f x) (j,y) r-    | i>j        =  avlBalance l (j,y) (accumFM r i f x)-    | otherwise  =  Node h l (j,f x y) r--delFromFM :: Ord a => FiniteMap a b -> a -> FiniteMap a b-delFromFM Empty              _              =  Empty-delFromFM (Node _ l (j,x) r) i-    | i<j        =  avlBalance (delFromFM l i) (j,x) r-    | i>j        =  avlBalance l (j,x) (delFromFM r i)-    | otherwise  =  merge l r--isEmptyFM :: FiniteMap a b -> Bool-isEmptyFM Empty = True-isEmptyFM _     = False--sizeFM :: Ord a => FiniteMap a b -> Int-sizeFM Empty          = 0-sizeFM (Node _ l _ r) = sizeFM l + 1 + sizeFM r--lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b-lookupFM Empty _ = Nothing-lookupFM (Node _ l (j,x) r) i | i<j        =  lookupFM l i-                              | i>j        =  lookupFM r i-                              | otherwise  =  Just x---- | applies lookup to an interval-rangeFM :: Ord a => FiniteMap a b -> a -> a -> [b]-rangeFM m i j = rangeFMa m i j []----rangeFMa Empty _ _ a = a-rangeFMa (Node _ l (k,x) r) i j a-    | k<i       = rangeFMa r i j a-    | k>j       = rangeFMa l i j a-    | otherwise = rangeFMa l i j (x:rangeFMa r i j a)--minFM :: Ord a => FiniteMap a b -> Maybe (a,b)-minFM Empty              = Nothing-minFM (Node _ Empty x _) = Just x-minFM (Node _ l     _ _) = minFM l--maxFM :: Ord a => FiniteMap a b -> Maybe (a,b)-maxFM Empty              = Nothing-maxFM (Node _ _ x Empty) = Just x-maxFM (Node _ _ _ r)     = maxFM r--predFM :: Ord a => FiniteMap a b -> a -> Maybe (a,b)-predFM m i = predFM' m i Nothing----predFM' Empty              _ p              =  p-predFM' (Node _ l (j,x) r) i p | i<j        =  predFM' l i p-                               | i>j        =  predFM' r i (Just (j,x))-                               | isJust ml  =  ml-                               | otherwise  =  p-                                 where ml = maxFM l--succFM :: Ord a => FiniteMap a b -> a -> Maybe (a,b)-succFM m i = succFM' m i Nothing----succFM' Empty              _ p              =  p-succFM' (Node _ l (j,x) r) i p | i<j        =  succFM' l i (Just (j,x))-                               | i>j        =  succFM' r i p-                               | isJust mr  =  mr-                               | otherwise  =  p-                                 where mr = minFM r--elemFM :: Ord a => FiniteMap a b -> a -> Bool-elemFM m i = case lookupFM m i of {Nothing -> False; _ -> True}---- | combines delFrom and lookup-splitFM :: Ord a => FiniteMap a b -> a -> Maybe (FiniteMap a b,(a,b))-splitFM Empty              _ =  Nothing-splitFM (Node _ l (j,x) r) i =-        if i<j then-           case splitFM l i of-                Just (l',y) -> Just (avlBalance l' (j,x) r,y)-                Nothing     -> Nothing  else-        if i>j then-           case splitFM r i of-                Just (r',y) -> Just (avlBalance l (j,x) r',y)-                Nothing     -> Nothing-        else {- i==j -}        Just (merge l r,(j,x))---- | combines splitFM and minFM-splitMinFM :: Ord a => FiniteMap a b -> Maybe (FiniteMap a b,(a,b))-splitMinFM Empty              =  Nothing-splitMinFM (Node _ Empty x r) = Just (r,x)-splitMinFM (Node _ l x r)     = Just (avlBalance l' x r,y)-                                where Just (l',y) = splitMinFM l--fmToList :: Ord a => FiniteMap a b -> [(a,b)]-fmToList m = scan m []-             where scan Empty xs = xs-                   scan (Node _ l x r) xs = scan l (x:(scan r xs))--------------------------------------------------------------------------- AVL tree helper functions-------------------------------------------------------------------------height :: Ord a => FiniteMap a b -> Int-height Empty          = 0-height (Node h _ _ _) = h--node :: Ord a => FiniteMap a b -> (a,b) -> FiniteMap a b -> FiniteMap a b-node l val r = Node h l val r-    where h=1+(height l `max` height r)--avlBalance :: Ord a => FiniteMap a b -> (a,b) -> FiniteMap a b -> FiniteMap a b-avlBalance l (i,x) r-    | (hr + 1 < hl) && (bias l < 0) = rotr (node (rotl l) (i,x) r)-    | (hr + 1 < hl)                 = rotr (node l (i,x) r)-    | (hl + 1 < hr) && (0 < bias r) = rotl (node l (i,x) (rotr r))-    | (hl + 1 < hr)                 = rotl (node l (i,x) r)-    | otherwise                     = node l (i,x) r-    where hl=height l; hr=height r--bias :: Ord a => FiniteMap a b -> Int-bias (Node _ l _ r) = height l - height r-bias Empty      = 0--rotr :: Ord a => FiniteMap a b -> FiniteMap a b-rotr Empty            = Empty-rotr (Node _ (Node _ l1 v1 r1) v2 r2) = node l1 v1 (node r1 v2 r2)-rotr (Node _ Empty _ _)          = error "rotr on invalid FiniteMap"--rotl :: Ord a => FiniteMap a b -> FiniteMap a b-rotl Empty            = Empty-rotl (Node _ l1 v1 (Node _ l2 v2 r2)) = node (node l1 v1 l2) v2 r2-rotl (Node _ _ _ Empty)          = error "rotl on invalid FiniteMap"

@@ -9,14 +9,14 @@ ) where  -data Ord a => Heap a b = Empty | Node a b [Heap a b]+data Heap a b = Empty | Node a b [Heap a b]      deriving Eq  showsHeap :: (Show a,Ord a,Show b) => Heap a b -> ShowS showsHeap Empty             = id showsHeap (Node key val []) = shows key . (": "++) . shows val showsHeap (Node key val hs) = shows key . (": "++) . shows val .  (' ':) . shows hs-                + instance (Show a,Ord a,Show b) => Show (Heap a b) where   showsPrec _ d = showsHeap d @@ -49,7 +49,7 @@ isEmpty :: Ord a => Heap a b -> Bool isEmpty Empty = True isEmpty _     = False-          + findMin :: Ord a => Heap a b -> (a, b) findMin Empty      = error "Heap.findMin: empty heap" findMin (Node key val _) = (key, val)

@@ -39,7 +39,7 @@                                 | otherwise = findP v ps  getPath :: Node -> RTree -> Path-getPath v = reverse . first (\(w:_)->w==v) +getPath v = reverse . first (\(w:_)->w==v)  getLPath :: Node -> LRTree a -> LPath a getLPath v = LP . reverse . findP v

@@ -20,22 +20,22 @@ {- class Thread t a b where   split :: a -> t -> (b,t)-  -  ++ instance Thread (Graph a b) Node (MContext a b) where   split = match-  + instance D.Discrete a => Thread (D.Diet a) a a where   split x s = (x,D.delete x s) -}  {-    Make clear different notions:-   +    "thread" = data structure + split operation    ...      = threadable data structure    ...      = split operation-   + -}  @@ -50,13 +50,13 @@  {- --  (1) simple collect in a list--- +-- foldT1' ys []     d = ys foldT1' ys (x:xs) d = foldT1' (y:ys) xs d'  where (y,d') = split x d foldT1 xs d = foldT1' [] xs d  --  (2) combine by a function--- +-- foldT2' f ys []     d = ys foldT2' f ys (x:xs) d = foldT2' f (f y ys) xs d'  where (y,d') = split x d foldT2 f u xs d = foldT2' f u xs d@@ -75,21 +75,21 @@ type Collect r c  = (r -> c -> c,c)  --  (3) abstract from split--- +-- threadList' :: (Collect r c) -> (Split t i r) -> [i] -> t -> (c,t)-threadList' (_,c) _ []	       t = (c,t)+threadList' (_,c) _ []         t = (c,t) threadList' (f,c) split (i:is) t = threadList' (f,f r c) split is t'                                    where (r,t') = split i t -{-  +{-    Note: threadList' works top-down (or, from left),          whereas dfs,gfold,... have been defined bottom-up (or from right).- +    ==> therefore, we define a correpsonding operator for folding        bottom-up/from right. -} threadList :: (Collect r c) -> (Split t i r) -> [i] -> t -> (c,t)-threadList (_,c) _ []     t	= (c,t)+threadList (_,c) _ []     t  = (c,t) threadList (f,c) split (i:is) t = (f r c',t'')                                   where (r,t')   = split i t                                         (c',t'') = threadList (f,c) split is t'@@ -100,13 +100,13 @@ --     threading with "continuation" c, and ignore Nothing-values, ie, --     stop threading and return current data structure. ----- threadMaybe' :: (r -> b) -> (Split t i r) -> (e -> f -> (Maybe i,t)) +-- threadMaybe' :: (r -> b) -> (Split t i r) -> (e -> f -> (Maybe i,t)) --                 -> e -> f -> (Maybe b,t)  type SplitM t i r = Split t i (Maybe r)  threadMaybe' :: (r->a)->Split t i r->Split t j (Maybe i)->Split t j (Maybe a)-threadMaybe' f cont split j t = +threadMaybe' f cont split j t =       case mi of Just i  -> (Just (f r),t'') where (r,t'') = cont i t'                  Nothing -> (Nothing,t')       where (mi,t') = split j t@@ -117,7 +117,7 @@ --                -> e -> f -> (Maybe c,d) -- threadMaybe :: (i->r->a)->Split t i r->Split t j (Maybe i)->Split t j (Maybe a) threadMaybe :: (i -> r -> a) -> Split t i r -> SplitM t j i -> SplitM t j a-threadMaybe f cont split j t = +threadMaybe f cont split j t =       case mi of Just i  -> (Just (f i r),t'') where (r,t'') = cont i t'                  Nothing -> (Nothing,t')       where (mi,t') = split j t@@ -125,7 +125,7 @@  -- (C) compose splits in parallel (is a kind of generalized zip) ----- splitPar :: (a -> b -> (c,d)) -> (e -> f -> (g,h)) +-- splitPar :: (a -> b -> (c,d)) -> (e -> f -> (g,h)) --             -> (a,e) -> (b,f) -> ((c,g),(d,h)) splitPar :: Split t i r -> Split u j s -> Split (t,u) (i,j) (r,s) splitPar split split' (i,j) (t,u) = ((r,s),(t',u'))@@ -135,15 +135,15 @@ splitParM :: SplitM t i r -> Split u j s -> SplitM (t,u) (i,j) (r,s) splitParM splitm split (i,j) (t,u) =           case mr of Just r  -> (Just (r,s),(t',u'))-                     Nothing -> (Nothing,(t',u))   -- ignore 2nd split +                     Nothing -> (Nothing,(t',u))   -- ignore 2nd split           where (mr,t') = splitm i t                 (s,u')  = split j u   -- (D) merge a thread with/into a computation ---{- +{-    Example: assign consecutive numbers to the nodes of a tree- +    Input: type d, thread (t,split), fold operation on d -}

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}  -- (c) 2002 by Martin Erwig [see file COPYRIGHT] -- | Static IOArray-based Graphs@@ -24,7 +24,7 @@ -- GRAPH REPRESENTATION ---------------------------------------------------------------------- -data SGr a b = SGr (GraphRep a b)+newtype SGr a b = SGr (GraphRep a b)  type GraphRep a b = (Int,Array Node (Context' a b),IOArray Node Bool) type Context' a b = Maybe (Adj b,a,Adj b)@@ -82,9 +82,9 @@                 vs'  = map fst vs                 n    = length vs                 addSuc (Just (p,l',s)) (l,w) = Just (p,l',(l,w):s)-		addSuc Nothing _ = error "mkGraphM (SGr): addSuc Nothing"+                addSuc Nothing _ = error "mkGraphM (SGr): addSuc Nothing"                 addPre (Just (p,l',s)) (l,w) = Just ((l,w):p,l',s)-		addPre Nothing _ = error "mkGraphM (SGr): addPre Nothing"+                addPre Nothing _ = error "mkGraphM (SGr): addPre Nothing"   labNodesM g = do (SGr (_,a,m)) <- g                    let getLNode vs (_,Nothing)      = return vs                        getLNode vs (v,Just (_,l,_)) =@@ -109,6 +109,3 @@ -- representing deleted marks removeDel :: IOArray Node Bool -> Adj b -> IO (Adj b) removeDel m = filterM (\(_,v)->do {b<-readArray m v;return (not b)})---

@@ -24,21 +24,22 @@     insMapEdgesM, delMapNodesM, delMapEdgesM ) where -import Prelude hiding (map)-import qualified Prelude as P (map)-import Control.Monad.State-import Data.Graph.Inductive.Graph---import Data.Graph.Inductive.Tree-import Data.Graph.Inductive.Internal.FiniteMap+import           Control.Monad.State+import           Data.Graph.Inductive.Graph+import           Prelude                    hiding (map)+import qualified Prelude                    as P (map) -data (Ord a) => NodeMap a =-    NodeMap { map :: FiniteMap a Node,-	      key :: Int }+import           Data.Map (Map)+import qualified Data.Map as M++data NodeMap a =+    NodeMap { map :: Map a Node,+              key :: Int }     deriving Show  -- | Create a new, empty mapping. new :: (Ord a) => NodeMap a-new = NodeMap { map = emptyFM, key = 0 }+new = NodeMap { map = M.empty, key = 0 }  -- LNode = (Node, a) @@ -46,19 +47,19 @@ fromGraph :: (Ord a, Graph g) => g a b -> NodeMap a fromGraph g =     let ns = labNodes g-	aux (n, a) (m', k') = (addToFM m' a n, max n k')-	(m, k) = foldr aux (emptyFM, 0) ns+        aux (n, a) (m', k') = (M.insert a n m', max n k')+        (m, k) = foldr aux (M.empty, 0) ns     in NodeMap { map = m, key = k+1 }  -- | Generate a labelled node from the given label.  Will return the same node -- for the same label. mkNode :: (Ord a) => NodeMap a -> a -> (LNode a, NodeMap a) mkNode m@(NodeMap mp k) a =-    case lookupFM mp a of-	Just i	-> ((i, a), m)-	Nothing	->-	    let m' = NodeMap { map = addToFM mp a k, key = k+1 }-	    in ((k, a), m')+    case M.lookup a mp of+        Just i        -> ((i, a), m)+        Nothing        ->+            let m' = NodeMap { map = M.insert a k mp, key = k+1 }+            in ((k, a), m')  -- | Generate a labelled node and throw away the modified 'NodeMap'. mkNode_ :: (Ord a) => NodeMap a -> a -> LNode a@@ -67,8 +68,8 @@ -- | Generate a 'LEdge' from the node labels. mkEdge :: (Ord a) => NodeMap a -> (a, a, b) -> Maybe (LEdge b) mkEdge (NodeMap m _) (a1, a2, b) =-    do n1 <- lookupFM m a1-       n2 <- lookupFM m a2+    do n1 <- M.lookup a1 m+       n2 <- M.lookup a2 m        return (n1, n2, b)  -- | Generates a list of 'LEdge's.@@ -83,7 +84,7 @@ map' _ a [] = ([], a) map' f a (b:bs) =     let (c, a') = f a b-	(cs, a'') = map' f a' bs+        (cs, a'') = map' f a' bs     in (c:cs, a'')  -- | Construct a list of nodes and throw away the modified 'NodeMap'.@@ -138,13 +139,13 @@ delMapEdges :: (Ord a, DynGraph g) => NodeMap a -> [(a, a)] -> g a b -> g a b delMapEdges m ns g =     let Just ns' =  mkEdges m $ P.map (\(a, b) -> (a, b, ())) ns-	ns'' = P.map (\(a, b, _) -> (a, b)) ns'+        ns'' = P.map (\(a, b, _) -> (a, b)) ns'     in delEdges ns'' g  mkMapGraph :: (Ord a, DynGraph g) => [a] -> [(a, a, b)] -> (g a b, NodeMap a) mkMapGraph ns es =     let (ns', m') = mkNodes new ns-	Just es' = mkEdges m' es+        Just es' = mkEdges m' es     in (mkGraph ns' es', m')  -- | Graph construction monad; handles passing both the 'NodeMap' and the

@@ -14,16 +14,16 @@     module Data.Graph.Inductive.Query.Monad, ) where -import Data.Graph.Inductive.Query.DFS+import Data.Graph.Inductive.Query.ArtPoint+import Data.Graph.Inductive.Query.BCC import Data.Graph.Inductive.Query.BFS-import Data.Graph.Inductive.Query.SP+import Data.Graph.Inductive.Query.DFS+import Data.Graph.Inductive.Query.Dominators import Data.Graph.Inductive.Query.GVD-import Data.Graph.Inductive.Query.MST import Data.Graph.Inductive.Query.Indep import Data.Graph.Inductive.Query.MaxFlow import Data.Graph.Inductive.Query.MaxFlow2-import Data.Graph.Inductive.Query.ArtPoint-import Data.Graph.Inductive.Query.BCC-import Data.Graph.Inductive.Query.Dominators-import Data.Graph.Inductive.Query.TransClos import Data.Graph.Inductive.Query.Monad+import Data.Graph.Inductive.Query.MST+import Data.Graph.Inductive.Query.SP+import Data.Graph.Inductive.Query.TransClos

@@ -33,7 +33,7 @@ -- 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)]] -> +dfsTree :: Graph gr => Int -> Node -> [Node] -> [[(Node,Int)]] ->                        gr a b -> ([DFSTree Int],gr a b,Int) dfsTree n _ []      _ g             = ([],g,n) dfsTree n _ _       _ g | isEmpty g = ([],g,n)@@ -66,8 +66,8 @@ -- contains: the node number v, the DFS number n, and the low number low. ------------------------------------------------------------------------------ lowTree :: DFSTree Int -> LOWTree Int-lowTree (B (v,n,[]  ) [] ) = Brc (v,n,n) [] -lowTree (B (v,n,bcks) [] ) = Brc (v,n,minbckEdge n bcks) [] +lowTree (B (v,n,[]  ) [] ) = Brc (v,n,n) []+lowTree (B (v,n,bcks) [] ) = Brc (v,n,minbckEdge n bcks) [] lowTree (B (v,n,bcks) trs) = Brc (v,n,lowv) ts                              where lowv     = min (minbckEdge n bcks) lowChild                                    lowChild = minimum (map getLow ts)@@ -119,4 +119,3 @@ -} ap :: Graph gr => gr a b -> [Node] ap g = artpoints g v where ((_,v,_,_),_) = matchAny g-

@@ -4,8 +4,8 @@   import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Query.DFS import Data.Graph.Inductive.Query.ArtPoint+import Data.Graph.Inductive.Query.DFS   ------------------------------------------------------------------------------@@ -43,7 +43,7 @@ splitGraphs :: DynGraph gr => [gr a b] -> [Node] -> [gr a b] splitGraphs gs []     = gs splitGraphs [] _      = error "splitGraphs: empty graph list"-splitGraphs gs (v:vs) = splitGraphs (gs''++gs''') vs +splitGraphs gs (v:vs) = splitGraphs (gs''++gs''') vs                         where gs'' = embedContexts c gs'                               gs' = gComponents g'                               ((Just c,g'), gs''') = findGraph v gs@@ -55,22 +55,3 @@ -} bcc :: DynGraph gr => gr a b -> [gr a b] bcc g = splitGraphs [g] (ap g)---------                                                ----------

@@ -54,7 +54,7 @@ leveln _          g | isEmpty g = [] leveln ((v,j):vs) g = case match v g of                         (Just c,g')  -> (v,j):leveln (vs++suci c (j+1)) g'-                        (Nothing,g') -> leveln vs g'  +                        (Nothing,g') -> leveln vs g'   -- bfe (breadth first edges)@@ -62,7 +62,7 @@ -- bfenInternal :: Graph gr => Queue Edge -> gr a b -> [Edge] bfenInternal q g | queueEmpty q || isEmpty g = []-                 | otherwise                 = +                 | otherwise                 =       case match v g of         (Just c, g')  -> (u,v):bfenInternal (queuePutList (outU c) q') g'         (Nothing, g') -> bfenInternal q' g'@@ -83,16 +83,16 @@ -- bft :: Node -> gr a b -> IT.InTree Node -- bft v g = IT.build $ map swap $ bfe v g --           where swap (x,y) = (y,x)--- +-- -- sp (shortest path wrt to number of edges) -- -- sp :: Node -> Node -> gr a b -> [Node] -- sp s t g = reverse $ IT.rootPath (bft s g) t  --- faster shortest paths +-- faster shortest paths -- here: with root path trees--- +-- bft :: Graph gr => Node -> gr a b -> RTree bft v = bf (queuePut [v] mkQueue) @@ -110,10 +110,10 @@  -- lesp is a version of esp that returns labeled paths -- Note that the label of the first node in a returned path is meaningless;--- all other nodes are paired with the label of their incoming edge. +-- all other nodes are paired with the label of their incoming edge. -- lbft :: Graph gr => Node -> gr a b -> LRTree b-lbft v g = case (out g v) of +lbft v g = case (out g v) of              []         -> [LP []]              (v',_,l):_ -> lbf (queuePut (LP [(v',l)]) mkQueue) g @@ -128,4 +128,3 @@  lesp :: Graph gr => Node -> Node -> gr a b -> LPath b lesp s t = getLPath t . lbft s-

@@ -1,5 +1,5 @@ -- (c) 2000 - 2005 by Martin Erwig [see file COPYRIGHT]--- | Depth-First Search  +-- | Depth-First Search  module Data.Graph.Inductive.Query.DFS(     CFun,@@ -8,17 +8,19 @@     xdfsWith,xdfWith,xdffWith,     -- * Undirected DFS     udfs,udfs',udff,udff',+    udffWith,udffWith',     -- * Reverse DFS     rdff,rdff',rdfs,rdfs',+    rdffWith,rdffWith',     -- * Applications of DFS\/DFF     topsort,topsort',scc,reachable,     -- * Applications of UDFS\/UDFF     components,noComponents,isConnected ) where -import Data.Tree-import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Basic+import Data.Graph.Inductive.Graph+import Data.Tree  ---------------------------------------------------------------------- -- DFS AND FRIENDS@@ -35,7 +37,7 @@               |   structure    direction  |   "s"   "f"    ------------------------   + optional With + optional '-      "x"     | xdfs  xdff   +      "x"     | xdfs  xdff       " "     |  dfs   dff       "u"     | udfs  udff       "r"     | rdfs  rdff@@ -43,23 +45,23 @@    Direction Parameter   --------------------   x : parameterized by a function that specifies which nodes +   x : parameterized by a function that specifies which nodes        to be visited next    " ": the "normal case: just follow successors- +    u : undirected, ie, follow predecesors and successors-   +    r : reverse, ie, follow predecesors     Structure Parameter   --------------------   s : result is a list of +   s : result is a list of         (a) objects computed from visited contexts  ("With"-version)         (b) nodes                                   (normal version) -   f : result is a tree/forest of +   f : result is a tree/forest of         (a) objects computed from visited contexts  ("With"-version)         (b) nodes                                   (normal version) @@ -68,12 +70,12 @@    With : objects to be put into list/tree are given by a function           on contexts, default for non-"With" versions: nodes -   '    : parameter node list is given implicitly by the nodes of the +   '    : parameter node list is given implicitly by the nodes of the           graph to be traversed, default for non-"'" versions: nodes           must be provided explicitly  -  Defined are only the following 18 most important function versions:+  Defined are only the following 22 most frabjuous function versions:      xdfsWith      dfsWith,dfsWith',dfs,dfs'@@ -81,11 +83,11 @@      rdfs,rdfs'     xdffWith      dffWith,dffWith',dff,dff'-     udff,udff'-     rdff,rdff'-    +     udffWith,udffWith',udff,udff'+     rdffWith,rdffWith',rdff,rdff'+   Others can be added quite easily if needed.-  + -}  -- fixNodes fixes the nodes of the graph as a parameter@@ -95,9 +97,9 @@   -- generalized depth-first search---  (could also be simply defined as applying preorderF to the +--  (could also be simply defined as applying preorderF to the --   result of xdffWith)---   +-- type CFun a b c = Context a b -> c  xdfsWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> [c]@@ -105,7 +107,7 @@ xdfsWith _ _ _      g | isEmpty g = [] xdfsWith d f (v:vs) g = case match v g of                          (Just c,g')  -> f c:xdfsWith d f (d c++vs) g'-                         (Nothing,g') -> xdfsWith d f vs g'  +                         (Nothing,g') -> xdfsWith d f vs g'   -- dfs@@ -126,7 +128,7 @@ -- undirected dfs, ie, ignore edge directions -- udfs :: Graph gr => [Node] -> gr a b -> [Node]-udfs = xdfsWith neighbors' node'  +udfs = xdfsWith neighbors' node'  udfs' :: Graph gr => gr a b -> [Node] udfs' = fixNodes udfs@@ -135,22 +137,22 @@ -- reverse dfs, ie, follow predecessors -- rdfs :: Graph gr => [Node] -> gr a b -> [Node]-rdfs = xdfsWith pre' node'  +rdfs = xdfsWith pre' node'  rdfs' :: Graph gr => gr a b -> [Node] rdfs' = fixNodes rdfs   -- generalized depth-first forest--- +-- xdfWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> ([Tree c],gr a b) xdfWith _ _ []     g             = ([],g) xdfWith _ _ _      g | isEmpty g = ([],g) xdfWith d f (v:vs) g = case match v g of-                        (Nothing,g1) -> xdfWith d f vs g1 -                        (Just c,g1)  -> (Node (f c) ts:ts',g3) +                        (Nothing,g1) -> xdfWith d f vs g1+                        (Just c,g1)  -> (Node (f c) ts:ts',g3)                                  where (ts,g2)  = xdfWith d f (d c) g1-                                       (ts',g3) = xdfWith d f vs g2 +                                       (ts',g3) = xdfWith d f vs g2  xdffWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> [Tree c] xdffWith d f vs g = fst (xdfWith d f vs g)@@ -173,20 +175,32 @@  -- undirected dff --+udffWith :: Graph gr => CFun a b c -> [Node] -> gr a b -> [Tree c]+udffWith = xdffWith neighbors'++udffWith' :: Graph gr => CFun a b c -> gr a b -> [Tree c]+udffWith' f = fixNodes (udffWith f)+ udff :: Graph gr => [Node] -> gr a b -> [Tree Node]-udff = xdffWith neighbors' node'+udff = udffWith node'  udff' :: Graph gr => gr a b -> [Tree Node]-udff' = fixNodes udff+udff' = udffWith' node'   -- reverse dff, ie, following predecessors --+rdffWith :: Graph gr => CFun a b c -> [Node] -> gr a b -> [Tree c]+rdffWith = xdffWith pre'++rdffWith' :: Graph gr => CFun a b c -> gr a b -> [Tree c]+rdffWith' f = fixNodes (rdffWith f)+ rdff :: Graph gr => [Node] -> gr a b -> [Tree Node]-rdff = xdffWith pre' node'+rdff = rdffWith node'  rdff' :: Graph gr => gr a b -> [Tree Node]-rdff' = fixNodes rdff+rdff' = rdffWith' node'   ----------------------------------------------------------------------@@ -220,4 +234,3 @@  reachable :: Graph gr => Node -> gr a b -> [Node] reachable v g = preorderF (dff [v] g)-

@@ -12,13 +12,13 @@     iDom ) where -import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Query.DFS-import Data.Tree (Tree(..))-import qualified Data.Tree as T-import Data.Array-import Data.IntMap (IntMap)-import qualified Data.IntMap as I+import           Data.Array+import           Data.Graph.Inductive.Graph+import           Data.Graph.Inductive.Query.DFS+import           Data.IntMap                    (IntMap)+import qualified Data.IntMap                    as I+import           Data.Tree                      (Tree (..))+import qualified Data.Tree                      as T  -- | return immediate dominators for each node of a graph, given a root iDom :: Graph gr => gr a b -> Node -> [(Node,Node)]

@@ -1,5 +1,5 @@ -- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT]--- | Graph Voronoi Diagram +-- | Graph Voronoi Diagram  module Data.Graph.Inductive.Query.GVD (     Voronoi,@@ -9,15 +9,15 @@ --    vdO,nnO,nsO ) where +import Data.List  (nub) import Data.Maybe (listToMaybe)-import Data.List (nub)  import qualified Data.Graph.Inductive.Internal.Heap as H +import Data.Graph.Inductive.Basic import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Query.SP (dijkstra) import Data.Graph.Inductive.Internal.RootPath-import Data.Graph.Inductive.Basic+import Data.Graph.Inductive.Query.SP          (dijkstra)  type Voronoi a = LRTree a 

@@ -15,10 +15,9 @@ indep :: DynGraph gr => gr a b -> [Node] indep g | isEmpty g = [] indep g = if length i1>length i2 then i1 else i2-          where vs          = nodes g -                m           = maximum (map (deg g) vs) -                v           = first (\v'->deg g v'==m) vs -                (Just c,g') = match v g +          where vs          = nodes g+                m           = maximum (map (deg g) vs)+                v           = first (\v'->deg g v'==m) vs+                (Just c,g') = match v g                 i1          = indep g'                 i2          = v:indep (delNodes (neighbors' c) g')-

@@ -1,5 +1,5 @@ -- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT]--- | Minimum-Spanning-Tree Algorithms +-- | Minimum-Spanning-Tree Algorithms  module Data.Graph.Inductive.Query.MST (     msTreeAt,msTree,@@ -7,9 +7,9 @@     msPath ) where -import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Internal.RootPath-import qualified Data.Graph.Inductive.Internal.Heap as H+import           Data.Graph.Inductive.Graph+import qualified Data.Graph.Inductive.Internal.Heap     as H+import           Data.Graph.Inductive.Internal.RootPath   newEdges :: Ord b => LPath b -> Context a b -> [H.Heap b (LPath b)]@@ -20,7 +20,7 @@ prim h g =     case match v g of          (Just c,g')  -> p:prim (H.mergeAll (h':newEdges p c)) g'-         (Nothing,g') -> prim h' g'  +         (Nothing,g') -> prim h' g'     where (_,p@(LP ((v,_):_)),h') = H.splitMin h  msTreeAt :: (Graph gr,Real b) => Node -> gr a b -> LRTree b@@ -31,11 +31,10 @@  msPath :: Real b => LRTree b -> Node -> Node -> Path msPath t a b = joinPaths (getLPathNodes a t) (getLPathNodes b t)-            -joinPaths :: Path -> Path -> Path ++joinPaths :: Path -> Path -> Path joinPaths p q = joinAt (head p) p q  joinAt :: Node -> Path -> Path -> Path joinAt _ (v:vs) (w:ws) | v==w = joinAt v vs ws joinAt x p      q             = reverse p++(x:q)-

@@ -2,7 +2,7 @@ -- We are given a flow network G=(V,E) with source s and sink t where each -- edge (u,v) in E has a nonnegative capacity c(u,v)>=0, and we wish to -- find a flow of maximum value from s to t.--- +-- -- A flow in G=(V,E) is a real-valued function f:VxV->R that satisfies: -- -- @@@ -51,11 +51,11 @@ --                            i         (i,0,i) -- label of every edge from a---->b to a------->b -- @--- +-- -- where label (x,y,z)=(Max Capacity, Current flow, Residual capacity) augmentGraph :: (DynGraph gr,Num b,Ord b) => gr a b -> gr a (b,b,b) augmentGraph g = emap (\i->(i,0,i)) (insEdges (getRevEdges (edges g)) g)-                                                + -- | Given a successor or predecessor list for node u and given node v, find -- the label corresponding to edge (u,v) and update the flow and residual -- capacity of that edge's label. Then return the updated list.@@ -70,7 +70,7 @@ -- predecessor list, then update the corresponding edges (u,v) and (v,u) on -- those lists by using the minimum residual capacity of the path. updateFlow :: (DynGraph gr,Num b,Ord b) => Path -> b -> gr a (b,b,b) -> gr a (b,b,b)-updateFlow []	     _ g = g+updateFlow []       _ g = g updateFlow [_]       _ g = g updateFlow (u:v:vs) cf g = case match u g of                              (Nothing,g')        -> g'@@ -117,11 +117,9 @@  ------------------------------------------------------------------------------ -- Some test cases: clr595 is from the CLR textbook, page 595. The value of--- the maximum flow for s=1 and t=6 (23) coincides with the example but the --- flow itself is slightly different since the textbook does not compute the --- shortest augmenting path from s to t, but just any path. However remember +-- the maximum flow for s=1 and t=6 (23) coincides with the example but the+-- flow itself is slightly different since the textbook does not compute the+-- shortest augmenting path from s to t, but just any path. However remember -- that for a given flow graph the maximum flow is not unique. -- (gr595 is defined in GraphData.hs) --------------------------------------------------------------------------------

@@ -10,11 +10,12 @@ import Data.Maybe  import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.PatriciaTree-import Data.Graph.Inductive.Internal.FiniteMap import Data.Graph.Inductive.Internal.Queue-import Data.Graph.Inductive.Query.BFS (bft)+import Data.Graph.Inductive.PatriciaTree+import Data.Graph.Inductive.Query.BFS      (bft) +import           Data.Set (Set)+import qualified Data.Set as S  ------------------------------------------------------------------------------ -- Data types@@ -118,7 +119,7 @@  -- ekFusedStep :: EKStepFunc ekFusedStep g s t = case maybePath of-        Just _	  ->+        Just _          ->             Just ((insEdges (integrateDelta es delta) newg), delta)         Nothing   -> Nothing     where maybePath     = augPathFused g s t@@ -158,7 +159,7 @@                 Just (l, newg) ->                     ((v, u, l, Backward):tailedges, newerg)                     where (tailedges, newerg) = extractPath newg (v:ws)-		Nothing	       -> error "extractPath: revExtract == Nothing"+                Nothing               -> error "extractPath: revExtract == Nothing"     where fwdExtract = extractEdge g u v (\(c,f)->(c>f))           revExtract = extractEdge g v u (\(_,f)->(f>0)) @@ -190,7 +191,7 @@  integrateDelta :: [DirEdge (Double,Double)] -> Double     -> [LEdge (Double, Double)]-integrateDelta []	  _ = []+integrateDelta []          _ = [] integrateDelta (e:es) delta = case e of     (u, v, (c, f), Forward) ->         (u, v, (c, f+delta)) : (integrateDelta es delta)@@ -222,25 +223,15 @@ -- Alternative implementation: Process list of edges to extract path instead -- of operating on graph structure --- EXTRACT fglEdmondsList.txt-setFromList :: Ord a => [a] -> FiniteMap a ()-setFromList [] = emptyFM-setFromList (x:xs) = addToFM (setFromList xs) x ()--setContains :: Ord a => FiniteMap a () -> a -> Bool-setContains m i = case (lookupFM m i) of-    Nothing -> False-    Just () -> True--extractPathList :: [LEdge (Double, Double)] -> FiniteMap (Node,Node) ()+extractPathList :: [LEdge (Double, Double)] -> Set (Node,Node)     -> ([DirEdge (Double, Double)], [LEdge (Double, Double)]) extractPathList []                 _ = ([], []) extractPathList (edge@(u,v,l@(c,f)):es) set-    | (c>f) && (setContains set (u,v)) =-        let (pathrest, notrest)=extractPathList es (delFromFM set (u,v))+    | (c>f) && (S.member (u,v) set) =+        let (pathrest, notrest)=extractPathList es (S.delete (u,v) set)             in ((u,v,l,Forward):pathrest, notrest)-    | (f>0) && (setContains set (v,u)) =-        let (pathrest, notrest)=extractPathList es (delFromFM set (u,v))+    | (f>0) && (S.member (v,u) set) =+        let (pathrest, notrest)=extractPathList es (S.delete (u,v) set)             in ((u,v,l,Backward):pathrest, notrest)     | otherwise                        =         let (pathrest, notrest)=extractPathList es set in@@ -253,11 +244,10 @@     where newEdges      = (integrateDelta es delta) ++ otheredges           maybePath     = augPathFused g s t           (es, otheredges) = extractPathList (labEdges g)-              (setFromList (zip justPath (tail justPath)))+              (S.fromList (zip justPath (tail justPath)))           delta         = minimum $ getPathDeltas es           justPath      = pathFromDirPath (fromJust maybePath)  ekList :: Network -> Node -> Node -> (Network, Double) ekList = ekWith ekStepList -- ENDEXTRACT-

@@ -1,3 +1,5 @@+{-# LANGUAGE MultiParamTypeClasses #-}+ -- (c) 2002 by Martin Erwig [see file COPYRIGHT] -- | Monadic Graph Algorithms @@ -22,12 +24,13 @@  -- Why all this? ----- graph monad ensures single-threaded access +-- graph monad ensures single-threaded access --  ==> we can safely use imperative updates in the graph implementation -- +import Control.Applicative (Applicative (..))+import Control.Monad       (ap, liftM) import Data.Tree---import Control.Monad (liftM)  import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Monad@@ -51,7 +54,7 @@ -- monadic graph transformer monad ---------------------------------------------------------------------- -data GT m g a = MGT (m g -> m (a,g))+newtype GT m g a = MGT (m g -> m (a,g))  apply :: GT m g a -> m g -> m (a,g) apply (MGT f) mg = f mg@@ -68,23 +71,29 @@ runGT :: Monad m => GT m g a -> m g -> m a runGT gt mg = do {(x,_) <- apply gt mg; return x} +instance Monad m => Functor (GT m g) where+    fmap  = liftM +instance Monad m => Applicative (GT m g) where+    pure  = return+    (<*>) = ap+ instance Monad m => Monad (GT m g) where   return x = MGT (\mg->do {g<-mg; return (x,g)})   f >>= h  = MGT (\mg->do {(x,g)<-apply f mg; apply' (h x) g})  condMGT' :: Monad m => (s -> Bool) -> GT m s a -> GT m s a -> GT m s a condMGT' p f g = MGT (\mg->do {h<-mg; if p h then apply f mg else apply g mg})- + recMGT' :: Monad m => (s -> Bool) -> GT m s a -> (a -> b -> b) -> b -> GT m s b-recMGT' p mg f u = condMGT' p (return u) +recMGT' p mg f u = condMGT' p (return u)                             (do {x<-mg;y<-recMGT' p mg f u;return (f x y)})  condMGT :: Monad m => (m s -> m Bool) -> GT m s a -> GT m s a -> GT m s a condMGT p f g = MGT (\mg->do {b<-p mg; if b then apply f mg else apply g mg})  recMGT :: Monad m => (m s -> m Bool) -> GT m s a -> (a -> b -> b) -> b -> GT m s b-recMGT p mg f u = condMGT p (return u) +recMGT p mg f u = condMGT p (return u)                           (do {x<-mg;y<-recMGT p mg f u;return (f x y)})  @@ -94,7 +103,7 @@   -- some monadic graph accessing functions--- +-- getNode :: GraphM m gr => GT m (gr a b) Node getNode = MGT (\mg->do {((_,v,_,_),g) <- matchAnyM mg; return (v,g)}) @@ -103,7 +112,7 @@  -- some functions defined by using the do-notation explicitly -- Note: most of these can be expressed as an instance of graphRec--- +-- getNodes' :: (Graph gr,GraphM m gr) => GT m (gr a b) [Node] getNodes' = condMGT' isEmpty (return [])                              (do v  <- getNode@@ -132,19 +141,19 @@ -- some derived graph recursion operators ---------------------------------------------------------------------- --- +-- -- graphRec :: GraphMonad a b c -> (c -> d -> d) -> d -> GraphMonad a b d--- graphRec f g u = cond isEmpty (return u) +-- graphRec f g u = cond isEmpty (return u) --                               (do x <- f --                                   y <- graphRec f g u --                                   return (g x y))  -- | encapsulates a simple recursion schema on graphs-graphRec :: GraphM m gr => GT m (gr a b) c -> +graphRec :: GraphM m gr => GT m (gr a b) c ->                            (c -> d -> d) -> d -> GT m (gr a b) d graphRec = recMGT isEmptyM -graphRec' :: (Graph gr,GraphM m gr) => GT m (gr a b) c -> +graphRec' :: (Graph gr,GraphM m gr) => GT m (gr a b) c ->                            (c -> d -> d) -> d -> GT m (gr a b) d graphRec' = recMGT' isEmpty @@ -158,7 +167,7 @@ ----------------------------------------------------------------------  -- instances of graphRec--- +-- graphNodesM0 :: GraphM m gr => GT m (gr a b) [Node] graphNodesM0 = graphRec getNode (:) [] @@ -209,7 +218,7 @@ dffM vs = MGT (\mg->           do g<-mg              b<-isEmptyM mg-             if b||null vs then return ([],g) else +             if b||null vs then return ([],g) else                 let (v:vs') = vs in                 do (mc,g1) <- matchM v mg                    case mc of@@ -224,4 +233,3 @@  graphDff' :: GraphM m gr => m (gr a b) -> m [Tree Node] graphDff' mg = do {vs <- nodesM mg; runGT (dffM vs) mg}-

@@ -13,15 +13,15 @@ expand :: Real b => b -> LPath b -> Context a b -> [H.Heap b (LPath b)] expand d (LP p) (_,_,_,s) = map (\(l,v)->H.unit (l+d) (LP ((v,l+d):p))) s --- | Implementation of Dijkstra's shortest path algorithm  +-- | Implementation of Dijkstra's shortest path algorithm dijkstra :: (Graph gr, Real b) => H.Heap b (LPath b) -> gr a b -> LRTree b dijkstra h g | H.isEmpty h || isEmpty g = [] dijkstra h g =     case match v g of          (Just c,g')  -> p:dijkstra (H.mergeAll (h':expand d p c)) g'-         (Nothing,g') -> dijkstra h' g'  +         (Nothing,g') -> dijkstra h' g'     where (_,p@(LP ((v,d):_)),h') = H.splitMin h-        + spTree :: (Graph gr, Real b) => Node -> gr a b -> LRTree b spTree v = dijkstra (H.unit 0 (LP [(v,0)])) 

@@ -18,4 +18,3 @@ trc :: DynGraph gr => gr a b -> gr a () trc g = insEdges (getNewEdges ln g) (insNodes ln empty)         where ln = labNodes g-                    

@@ -7,18 +7,21 @@ module Data.Graph.Inductive.Tree (Gr,UGr) where  import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Internal.FiniteMap -import Data.List  (foldl', sort)-import Data.Maybe (fromJust)+import           Control.Applicative (liftA2)+import           Control.Arrow       (first)+import           Data.List           (foldl', sort)+import           Data.Map            (Map)+import qualified Data.Map            as M+import           Data.Maybe          (fromMaybe)  ---------------------------------------------------------------------- -- GRAPH REPRESENTATION ---------------------------------------------------------------------- -data Gr a b = Gr (GraphRep a b)+newtype Gr a b = Gr (GraphRep a b) -type GraphRep a b = FiniteMap Node (Context' a b)+type GraphRep a b = Map Node (Context' a b) type Context' a b = (Adj b,a,Adj b)  type UGr = Gr () ()@@ -49,58 +52,71 @@ -- Graph -- instance Graph Gr where-  empty           = Gr emptyFM-  isEmpty (Gr g)  = case g of {Empty -> True; _ -> False}-  match           = matchGr-  mkGraph vs es   = (insEdges' . insNodes vs) empty+  empty             = Gr M.empty+  isEmpty (Gr g)    = M.null g+  match v gr@(Gr g) = maybe (Nothing, gr)+                            (first Just . uncurry (cleanSplit v))+                      . (\(m,g') -> fmap (flip (,) g') m)+                      $ M.updateLookupWithKey (const (const Nothing)) v g+  mkGraph vs es     = (insEdges' . insNodes vs) empty         where           insEdges' g = foldl' (flip insEdge) g es -  labNodes (Gr g) = map (\(v,(_,l,_))->(v,l)) (fmToList g)+  labNodes (Gr g)   = map (\(v,(_,l,_))->(v,l)) (M.toList g)   -- more efficient versions of derived class members   ---  matchAny (Gr Empty)                = error "Match Exception, Empty Graph"-  matchAny g@(Gr (Node _ _ (v,_) _)) = (c,g') where (Just c,g') = matchGr v g-  noNodes   (Gr g) = sizeFM g-  nodeRange (Gr Empty) = (0,0)-  nodeRange (Gr g)     = (ix (minFM g),ix (maxFM g)) where ix = fst.fromJust-  labEdges  (Gr g) = concatMap (\(v,(_,_,s))->map (\(l,w)->(v,w,l)) s) (fmToList g)-+  matchAny (Gr g)   = maybe (error "Match Exception, Empty Graph")+                            (uncurry (uncurry cleanSplit))+                            (M.minViewWithKey g)+  noNodes   (Gr g)  = M.size g+  nodeRange (Gr g)  = fromMaybe (0,0)+                      $ liftA2 (,) (ix (M.minViewWithKey g))+                                   (ix (M.maxViewWithKey g))+    where+      ix            = fmap (fst . fst)+  labEdges  (Gr g)  = concatMap (\(v,(_,_,s))->map (\(l,w)->(v,w,l)) s) (M.toList g) -matchGr v (Gr g) =-      case splitFM g v of-           Nothing -> (Nothing,Gr g)-           Just (g',(_,(p,l,s))) -> (Just (p',v,l,s),Gr g2)-                where s'   = filter ((/=v).snd) s-                      p'   = filter ((/=v).snd) p-                      g1   = updAdj g' s' (clearPred v)-                      g2   = updAdj g1 p' (clearSucc v)+-- After a Node (with its corresponding Context') are split out of a+-- GraphRep, clean up the remainders.+cleanSplit :: Node -> Context' a b -> GraphRep a b+              -> (Context a b, Gr a b)+cleanSplit v (p,l,s) g = (c, Gr g')+  where+    -- Note: loops are kept only in successor list+    c = (p', v, l, s)+    p' = rmLoops p+    s' = rmLoops s+    rmLoops = filter ((/=v) . snd) +    g' = updAdj s' (clearPred v) . updAdj p' (clearSucc v) $ g  -- DynGraph -- instance DynGraph Gr where-  (p,v,l,s) & (Gr g) | elemFM g v = error ("Node Exception, Node: "++show v)-                     | otherwise  = Gr g3-      where g1 = addToFM g v (p,l,s)-            g2 = updAdj g1 p (addSucc v)-            g3 = updAdj g2 s (addPred v)-+  (p,v,l,s) & (Gr g) = Gr+                       . updAdj p (addSucc v)+                       . updAdj s (addPred v)+                       $ M.alter addCntxt v g+    where+      addCntxt = maybe (Just cntxt')+                       (const (error ("Node Exception, Node: "++show v)))+      cntxt' = (p,l,s)  ---------------------------------------------------------------------- -- UTILITIES ---------------------------------------------------------------------- +addSucc :: Node -> b -> Context' a b -> Context' a b addSucc v l (p,l',s) = (p,l',(l,v):s)++addPred :: Node -> b -> Context' a b -> Context' a b addPred v l (p,l',s) = ((l,v):p,l',s) +clearSucc :: Node -> b -> Context' a b -> Context' a b clearSucc v _ (p,l,s) = (p,l,filter ((/=v).snd) s)-clearPred v _ (p,l,s) = (filter ((/=v).snd) p,l,s) -updAdj :: GraphRep a b -> Adj b -> (b -> Context' a b -> Context' a b) -> GraphRep a b-updAdj g []         _              = g-updAdj g ((l,v):vs) f | elemFM g v = updAdj (updFM g v (f l)) vs f-                      | otherwise  = error ("Edge Exception, Node: "++show v)--+clearPred :: Node -> b -> Context' a b -> Context' a b+clearPred v _ (p,l,s) = (filter ((/=v).snd) p,l,s) +updAdj :: Adj b -> (b -> Context' a b -> Context' a b) -> GraphRep a b -> GraphRep a b+updAdj adj f g = foldl' (\g' (l,v) -> M.adjust (f l) v g') g adj

@@ -1,24 +1,28 @@ name:          fgl-version:       5.5.0.1+version:       5.5.1.0 license:       BSD3 license-file:  LICENSE author:        Martin Erwig, Ivan Lazar Miljenovic maintainer:    Ivan.Miljenovic@gmail.com-homepage:      http://web.engr.oregonstate.edu/~erwig/fgl/haskell category:      Data Structures, Graphs synopsis:      Martin Erwig's Functional Graph Library++description:   {+An inductive representation of manipulating graph data structures.+.+Original website can be found at <http://web.engr.oregonstate.edu/~erwig/fgl/haskell>.+} cabal-version: >= 1.6 build-type:    Simple extra-source-files:                ChangeLog  source-repository head-    type:         darcs-    location:     http://code.haskell.org/FGL/fgl-5+    type:         git+    location:     git://github.com/haskell/fgl.git  library {     exposed-modules:-        Data.Graph.Inductive.Internal.FiniteMap,         Data.Graph.Inductive.Internal.Heap,         Data.Graph.Inductive.Internal.Queue,         Data.Graph.Inductive.Internal.RootPath,