hgraph 1.2.0.0 → 1.2.0.1
raw patch · 5 files changed
+202/−10 lines, 5 filessetup-changed
Files
- Setup.hs +2/−0
- hgraph.cabal +3/−1
- src/HGraph/Directed/Connectivity.hs +7/−9
- src/HGraph/Directed/Connectivity/Flow.hs +86/−0
- src/HGraph/Directed/Connectivity/IntegralLinkage.hs +104/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
hgraph.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hgraph-version: 1.2.0.0+version: 1.2.0.1 synopsis: Tools for working on (di)graphs. -- description: license: GPL-3@@ -21,6 +21,8 @@ HGraph.Directed.Output HGraph.Directed.PathAnonymity HGraph.Directed.Subgraph+ HGraph.Directed.Connectivity.IntegralLinkage+ HGraph.Directed.Connectivity.Flow HGraph.Undirected, HGraph.Undirected.AdjacencyMap HGraph.Undirected.Solvers.VertexCover HGraph.Undirected.Solvers.Treedepth
src/HGraph/Directed/Connectivity.hs view
@@ -3,7 +3,6 @@ , allPaths , allLinkages , allMaximalPaths- , extendLinkage , LinkageInstance(..) , module F , module IL@@ -16,7 +15,6 @@ import HGraph.Directed.Connectivity.IntegralLinkage as IL import qualified Data.Map as M import qualified Data.Set as S-import Control.Monad --data LinkageInstance a = -- LinkageInstance@@ -66,7 +64,7 @@ reachable d s t = t `elem` (metaBfs d s (\_ -> []) id) -allPaths d s t = allPaths' S.empty s+allPaths d s0 t = allPaths' S.empty s0 where allPaths' visited s | s == t = [[t]]@@ -85,13 +83,13 @@ Just si = fmap fst $ find ((==s) . snd) itova Just ti = fmap fst $ find ((==t) . snd) itova iToV = M.fromList itova- allLinkages' si visited- | all (==ti) si = return $ map (:[]) si+ allLinkages' sj visited+ | all (==ti) sj = return $ map (:[]) sj | otherwise = do- (step, visited') <- linkageSteps di visited si ti- fmap (zipWith (:) si) $ allLinkages' step visited'+ (step, visited') <- linkageSteps di visited sj ti+ fmap (zipWith (:) sj) $ allLinkages' step visited' -linkageSteps d visited [] t = return ([], visited)+linkageSteps _ visited [] _ = return ([], visited) linkageSteps d visited (v:vs) t = do u <- if v == t then return v else filter (\u -> not $ S.member u visited) $ outneighbors d v fmap (\(ws, visited') -> (u:ws, visited')) $ linkageSteps d (if u /= t then S.insert u visited else visited) vs t@@ -134,5 +132,5 @@ p0 = head p choose 0 _ = [[]]-choose k [] = []+choose _ [] = [] choose k (x:xs) = map (x:) (choose (k - 1) xs) ++ choose k xs
+ src/HGraph/Directed/Connectivity/Flow.hs view
@@ -0,0 +1,86 @@+module HGraph.Directed.Connectivity.Flow+ ( maxFlow+ , maxDisjointPaths+ , minCut+ , minCutI+ )+where++import Data.List+import HGraph.Directed+import qualified Data.Map as M+import qualified Data.Set as S+import Control.Monad++maxFlow :: (Ord a, Adjacency t, DirectedGraph t) => t a -> a -> a -> M.Map (a, a) Bool+maxFlow d s t = maxFlow' $ foldr (\a -> M.insert a False) M.empty (arcs d)+ where+ maxFlow' flow + | null p = flow+ | otherwise = maxFlow' flow'+ where+ p = shortestPathResidual d s t flow+ flow' = foldr (M.adjust not) flow $ zip p (tail p)++shortestPathResidual d s t flow = path (S.singleton s) M.empty+ where+ path active preds+ | t `M.member` preds = reverse $ makePath preds t+ | S.null active = []+ | otherwise = path (S.fromList $ M.keys newPred) (preds `M.union` newPred)+ where+ newPred = M.fromList $ [ (u,v)+ | v <- S.toList active+ , u <- outneighbors d v+ , (not $ flow M.! (v,u)) && (not $ u `M.member` preds)+ ]+ +++ [ (u,v)+ | v <- S.toList active+ , u <- inneighbors d v+ , flow M.! (u, v) && (not $ u `M.member` preds)+ ]+ makePath preds v+ | v == s = [v]+ | otherwise = v : makePath preds (preds M.! v)++maxDisjointPaths :: (Mutable t, DirectedGraph t, Adjacency t, Integral a) => t a -> a -> a -> [[a]]+maxDisjointPaths d s t = [s : makePath v | v <- outneighbors d s, (2*v + 1) `M.member` succs]+ where+ d' = foldr addVertex (empty d) (concat [[2*v, 2*v+1] | v <- vertices d])+ d'' = foldr addArc d' ([(2*v, 2*v + 1) | v <- vertices d] ++ [(2*v+1, 2*u) | (v,u) <- arcs d])+ succs = M.fromList $ M.keys $ M.filter (id) $ maxFlow d'' (2*s+1) (2*t)+ makePath v+ | v == t = [t]+ | otherwise = v : makePath ((succs M.! (2*v + 1)) `div` 2)++minCut :: (Mutable t, DirectedGraph t, Adjacency t, Eq a) => t a -> a -> a -> [a]+minCut d s t = map (iToV M.!) $ minCutI di si ti+ where+ (di, itova) = linearizeVertices d+ iToV = M.fromList itova+ Just si = fmap fst $ find ((==s) . snd) itova+ Just ti = fmap fst $ find ((==t) . snd) itova++minCutI :: (Mutable t, DirectedGraph t, Adjacency t, Integral a) => t a -> a -> a -> [a]+minCutI d s t = [u `div` 2 | v <- S.toList $ reach, u <- outneighbors d'' v, not $ u `S.member` reach]+ where+ d' = foldr addVertex (empty d) (concat [[2*v, 2*v+1] | v <- vertices d])+ d'' = foldr addArc d' ([(2*v, 2*v + 1) | v <- vertices d] ++ [(2*v+1, 2*u) | (v,u) <- arcs d])+ flow = M.filter (id) $ maxFlow d'' (2*s+1) (2*t)+ reach = bfs (S.singleton (2*s+1)) (S.singleton (2*s+1))+ bfs active reached+ | S.null active = reached+ | otherwise = bfs new (S.union reached new)+ where+ new = S.fromList $ [ u+ | v <- S.toList active+ , u <- outneighbors d'' v+ , (not $ (v,u) `M.member` flow) && (not $ u `S.member` reached)+ ]+ +++ [ u+ | v <- S.toList active+ , u <- inneighbors d'' v+ , (u,v) `M.member` flow && (not $ u `S.member` reached)+ ]
+ src/HGraph/Directed/Connectivity/IntegralLinkage.hs view
@@ -0,0 +1,104 @@+module HGraph.Directed.Connectivity.IntegralLinkage+ ( extendLinkage+ , linkage+ , linkageI+ , LinkageInstance(..)+ )+where++import HGraph.Directed.Connectivity.Flow+import HGraph.Utils+import HGraph.Directed+import qualified Data.Map as M+import Data.Maybe++data LinkageInstance a = + LinkageInstance+ { liTerminalPairs :: M.Map Int (a,a)+ , liLinkage :: M.Map a Int+ , liPath :: M.Map Int [a]+ }++extendLinkage d inst = + case extendLinkage' $ M.keys $ liTerminalPairs inst of+ Nothing -> Nothing+ Just [] -> Just inst+ Just ext ->+ let link' = M.union (foldr (\(v,i) -> + M.insert v i)+ M.empty ext)+ (liLinkage inst)+ st' = M.union (M.fromList $ [ (i, (v, t))+ | (v,i) <- ext+ , let (s,t) = (liTerminalPairs inst) M.! i+ , v `elem` (outneighbors d s)+ ] +++ [ (i, (s, v))+ | (v,i) <- ext+ , let (s,t) = (liTerminalPairs inst) M.! i+ , v `elem` (inneighbors d t)+ ]+ )+ (liTerminalPairs inst)+ in extendLinkage d inst{liTerminalPairs = st', liLinkage = link'}+ where+ extendLinkage' [] = Just []+ extendLinkage' (i:is)+ | s == t = extendLinkage' is+ | null cut = Nothing+ | not $ null $ drop 1 cut = extendLinkage' is+ | maybe True (i/=) (cv `M.lookup` (liLinkage inst)) = Just [(cv,i)]+ where+ (s,t) = (liTerminalPairs inst) M.! i+ d' = foldr removeVertex d+ [ v+ | v <- vertices d+ , maybe False (i ==) (v `M.lookup` (liLinkage inst))+ ]+ cut = minCutI d' s t+ cv = head cut++-- | Finds an integral linkaged connecting the given terminal pairs, if one exists.+linkage :: (DirectedGraph t, Adjacency t, Mutable t, Eq a) => t a -> [(a,a)] -> Maybe [((a,a), [a])]+linkage d st = fmap (map convertResult) $ linkageI di sti+ where+ (di, itova) = linearizeVertices d+ sti = [ (si, ti)+ | (s,t) <- st+ , let si = fst $ head $ filter (\(_, v) -> v == s) itova+ , let ti = fst $ head $ filter (\(_, v) -> v == t) itova+ ]+ iToV = M.fromList itova+ convertResult ((v,u), ps) = ((iToV M.! v, iToV M.! u), map (iToV M.!) ps )++-- | Special case of `linkage` where vertices are of type `Int`.+-- | Faster than calling `linkage` if vertices of the digraph are already of type `Int`.+linkageI :: (DirectedGraph t, Adjacency t, Mutable t, Integral a, Ord a, Eq a) => t a -> [(a,a)] -> Maybe [((a,a), [a])]+linkageI d st = linkage' inst0+ where+ sti = zip [0..] st+ terminalPairs0 = M.fromList sti+ inst0 = LinkageInstance+ { liLinkage = M.fromList $ + concatMap (\(i, (s,t)) -> [(s, i), (t, i)]) sti+ , liTerminalPairs = terminalPairs0+ , liPath = M.empty+ }+ -- linkage' :: (Eq a, Ord a, Num a) => LinkageInstance a -> Maybe [((a,a), [a])]+ linkage' inst+ | M.null $ liTerminalPairs inst = Just [ (terminalPairs0 M.! t, reverse ps) | (t, ps) <- M.assocs $ liPath inst]+ | otherwise = + let (i, (s,t)) = head $ M.assocs $ liTerminalPairs inst+ tries = do+ v <- filter (\u -> not $ isJust $ M.lookup u $ liLinkage inst) $ inneighbors d t+ let inst' = extendLinkage d $ inst+ { liTerminalPairs = M.insert i (s,v) (liTerminalPairs inst)+ , liPath = M.insertWith (++) i [v] $ liPath inst+ , liLinkage = M.insert v i $ liLinkage inst+ }+ case fmap linkage' inst' of+ Just (Just r) -> return r+ Nothing -> []+ in mhead tries+ +