diff --git a/benchmarks/ArcDeletionAcyclic.hs b/benchmarks/ArcDeletionAcyclic.hs new file mode 100644 --- /dev/null +++ b/benchmarks/ArcDeletionAcyclic.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import HGraph.Directed.Generator +import HGraph.Directed.AdjacencyMap as AM +import qualified HGraph.Directed.EditDistance.Acyclic.ArcDeletion as HittingSet +import Data.List +import System.Random +import Control.Monad +import Control.Monad.Trans.State +import System.Clock + +runBench !(g,name) = do + start <- getTime ProcessCPUTime + let (_, !k) = HittingSet.minimumI g + !nVerts = numVertices g + !nEdges = numArcs g + end <- k `seq` getTime ProcessCPUTime + let delta = (toNanoSecs $ diffTimeSpec end start) `div` 10^6 + return $ ( intercalate "," + [ show name + , show nVerts + , show nEdges + , show delta + , show k + ] , + delta) + +generateRandomInstances n = do + gen <- newStdGen + return $ (evalState + ( fmap concat $ replicateM n $ forM [4..15] $ \i -> do + d <- randomDigraph (AM.emptyDigraph :: AM.Digraph Int) i (min ((i * (i - 1)) `div` 4) (6*i)) + numArcs d `seq` return (d, intercalate ";" [show $ numVertices d, show $ numArcs d]) + ) gen) + +main = do + randomInstances <- generateRandomInstances 10 + putStrLn "instance, vertices, edges, time (ms), solution" + results <- mapM + (\i -> do + result <- runBench i + putStrLn $ fst result + return result + ) + randomInstances + let times = map snd results + let totalTime = sum times + return () diff --git a/benchmarks/PackingCycles.hs b/benchmarks/PackingCycles.hs new file mode 100644 --- /dev/null +++ b/benchmarks/PackingCycles.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import HGraph.Directed.Generator +import HGraph.Directed.AdjacencyMap as AM +import qualified HGraph.Directed.Packing.Cycles as Packing +import Data.List +import System.Random +import Control.Monad +import Control.Monad.Trans.State +import System.Clock + +runBench !(g,name) = do + start <- getTime ProcessCPUTime + let (packing, !k) = Packing.maximumI g + !nVerts = numVertices g + !nEdges = numArcs g + end <- k `seq` getTime ProcessCPUTime + let delta = (toNanoSecs $ diffTimeSpec end start) `div` 10^6 + return $ ( intercalate "," + [ show name + , show nVerts + , show nEdges + , show delta + , show k + ] , + delta) + +generateRandomInstances n = do + gen <- newStdGen + return $ (evalState + ( fmap concat $ replicateM n $ forM [4..15] $ \i -> do + d <- randomDigraph (AM.emptyDigraph :: AM.Digraph Int) i (min ((i * (i - 1)) `div` 2) (6*i)) + numArcs d `seq` return (d, intercalate ";" [show $ numVertices d, show $ numArcs d]) + ) gen) + +main = do + randomInstances <- generateRandomInstances 10 + putStrLn "instance, vertices, edges, time (ms), solution" + results <- mapM + (\i -> do + result <- runBench i + putStrLn $ fst result + return result + ) + randomInstances + let times = map snd results + let totalTime = sum times + return () + -- results <- mapM runBench randomInstances + -- let times = map snd results + -- let totalTime = sum times + -- putStrLn $ intercalate "\n" $ "instance, vertices, edges, time (ms), solution" : map fst results diff --git a/hgraph.cabal b/hgraph.cabal --- a/hgraph.cabal +++ b/hgraph.cabal @@ -2,9 +2,12 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hgraph -version: 1.2.0.1 +version: 1.10.0.0 synopsis: Tools for working on (di)graphs. --- description: +description: A collection of tools for generating and working on directed and undirected graphs. + Algorithms are written using typeclasses in order to be data-structure independent. + + It is also possible to easily import and export graphs using the Graphviz syntax. license: GPL-3 license-file: LICENSE author: Marcelo Garlet Milani @@ -16,14 +19,30 @@ cabal-version: >=1.10 library - exposed-modules: HGraph.Directed, HGraph.Directed.AdjacencyMap HGraph.Directed.Connectivity + exposed-modules: HGraph.Directed + HGraph.Directed.AdjacencyMap + HGraph.Directed.Connectivity + HGraph.Directed.Connectivity.Basic + HGraph.Directed.Connectivity.Flow + HGraph.Directed.Connectivity.IntegralLinkage + HGraph.Directed.Connectivity.OneWayWellLinkedness + HGraph.Directed.Connectivity.OneWayWellLinkedness.Internal + HGraph.Directed.EditDistance.Acyclic.ArcDeletion + HGraph.Directed.EditDistance.Acyclic.ArcDeletion.Internal + HGraph.Directed.EditDistance.Acyclic.VertexDeletion + HGraph.Directed.EditDistance.Acyclic.VertexDeletion.Internal + HGraph.Directed.Generator + HGraph.Directed.Generator.Hereditary + HGraph.Directed.Generator.Hereditary.Internal HGraph.Directed.Load HGraph.Directed.Output HGraph.Directed.PathAnonymity + HGraph.Directed.Packing.Cycles + HGraph.Directed.Packing.Cycles.Internal + HGraph.Directed.TopologicalMinor HGraph.Directed.Subgraph - HGraph.Directed.Connectivity.IntegralLinkage - HGraph.Directed.Connectivity.Flow - HGraph.Undirected, HGraph.Undirected.AdjacencyMap + HGraph.Undirected + HGraph.Undirected.AdjacencyMap HGraph.Undirected.Solvers.VertexCover HGraph.Undirected.Solvers.Treedepth HGraph.Undirected.Solvers.IndependentSet @@ -32,9 +51,19 @@ HGraph.Undirected.Load HGraph.Undirected.Layout.SpringModel HGraph.Undirected.Output - other-modules: HGraph.Utils + HGraph.Utils + HGraph.Parallel + other-modules: HGraph.Debugging default-extensions: TypeSynonymInstances, DoAndIfThenElse, GADTs - build-depends: base >=4.11 && <5, containers >= 0.5, happy-dot >= 0.1, transformers >= 0.5, mtl, random, linear >= 1.21, array >= 0.5 + build-depends: base >=4.11 && <5, + array >= 0.5 && < 1.0, + containers >= 0.6.7 && < 1.0, + happy-dot >= 1.0.0 && < 2.0, + linear >= 1.21 && < 2.0, + mtl >= 2.3.1 && < 3.0, + random >= 1.2.1 && < 2.0, + say >= 0.1.0 && < 1.0, + transformers >= 0.6.1 && < 1.0 hs-source-dirs: src default-language: Haskell2010 @@ -75,6 +104,13 @@ build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph default-language: Haskell2010 +test-suite test-directed-adjacency-map + main-is: AdjacencyMap.hs + hs-source-dirs: tests/Digraph + type: exitcode-stdio-1.0 + build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph + default-language: Haskell2010 + test-suite test-vertex-cover main-is: TestVertexCover.hs hs-source-dirs: tests/Graph @@ -100,6 +136,7 @@ main-is: Connectivity.hs hs-source-dirs: tests/Digraph type: exitcode-stdio-1.0 + other-modules: TestUtils build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph default-language: Haskell2010 @@ -117,9 +154,53 @@ build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph default-language: Haskell2010 +test-suite test-topological-minor + main-is: TopologicalMinor.hs + hs-source-dirs: tests/Digraph + type: exitcode-stdio-1.0 + build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph + default-language: Haskell2010 + +test-suite test-edit-distance-acyclic + main-is: EditDistance-Acyclic.hs + hs-source-dirs: tests/Digraph + type: exitcode-stdio-1.0 + other-modules: TestUtils + build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph + default-language: Haskell2010 + +Benchmark benchmark-arc-deletion-acyclic + main-is: ArcDeletionAcyclic.hs + hs-source-dirs: benchmarks + type: exitcode-stdio-1.0 + build-depends: base >=4.11 && <5, containers >= 0.5, transformers >= 0.5, clock >= 0.7, hgraph, random + default-language: Haskell2010 + test-suite test-load main-is: Load.hs hs-source-dirs: tests/Digraph type: exitcode-stdio-1.0 build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph + default-language: Haskell2010 + +test-suite test-digraph-generator + main-is: Generator.hs + hs-source-dirs: tests/Digraph + type: exitcode-stdio-1.0 + build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph + default-language: Haskell2010 + +test-suite test-packing-cycles + main-is: Packing-Cycles.hs + hs-source-dirs: tests/Digraph + type: exitcode-stdio-1.0 + other-modules: TestUtils + build-depends: base >=4.11 && <5, transformers >= 0.5, containers >= 0.5.9, HUnit >= 1.6, hgraph + default-language: Haskell2010 + +Benchmark benchmark-packing-cycles + main-is: PackingCycles.hs + hs-source-dirs: benchmarks + type: exitcode-stdio-1.0 + build-depends: base >=4.11 && <5, containers >= 0.5, transformers >= 0.5, clock >= 0.7, hgraph, random default-language: Haskell2010 diff --git a/src/HGraph/Debugging.hs b/src/HGraph/Debugging.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Debugging.hs @@ -0,0 +1,17 @@ +module HGraph.Debugging + ( module HGraph.Debugging + , sayString + , sayErrString + ) +where + +import Say +import Control.Exception +import Control.Concurrent.MVar + +hasLocked :: String -> IO a -> IO a +hasLocked msg action = + action `catches` + [ Handler $ \exc@BlockedIndefinitelyOnMVar -> sayString ("[MVar]: " ++ msg) >> throwIO exc + , Handler $ \exc@BlockedIndefinitelyOnSTM -> sayString ("[STM]: " ++ msg) >> throwIO exc + ] diff --git a/src/HGraph/Directed.hs b/src/HGraph/Directed.hs --- a/src/HGraph/Directed.hs +++ b/src/HGraph/Directed.hs @@ -4,11 +4,23 @@ ( DirectedGraph(..) , Adjacency(..) , Mutable(..) + , subgraphAround + , renameVertices + , topologicalOrdering + , inducedSubgraph + , lineDigraphI + , transitiveClosure + , isIsomorphicTo + , isIsomorphicToI + , splitVertices + , union ) where import qualified Data.Map as M import qualified Data.Set as S +import HGraph.Utils +import Data.Maybe class DirectedGraph t where empty :: t a -> t a @@ -28,6 +40,10 @@ outdegree d v = fromIntegral $ length $ outneighbors d v indegree :: Integral b => t a -> a -> b indegree d v = fromIntegral $ length $ inneighbors d v + incomingArcs :: t a -> a -> [(a,a)] + incomingArcs d v = [(x,v) | x <- inneighbors d v] + outgoingArcs :: t a -> a -> [(a,a)] + outgoingArcs d v = [(v,x) | x <- outneighbors d v] arcExists :: t a -> (a,a) -> Bool metaBfs :: Ord a => t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a] metaBfs d v inFilter outFilter = @@ -50,3 +66,108 @@ addArc :: (a,a) -> t a -> t a removeArc :: (a,a) -> t a -> t a +renameVertices :: (DirectedGraph t, Mutable t, Ord a) => M.Map a b -> t b -> t a -> t b +renameVertices relabel emptyD d = + foldr addArc (foldr addVertex emptyD $ map (relabel M.!) $ vertices d) + [(relabel M.! v, relabel M.! u) | (v,u) <- arcs d] + +subgraphAround :: (DirectedGraph t, Adjacency t, Mutable t) => Int -> t a -> a -> t a +subgraphAround radius d v = around radius (addVertex v $ empty d) [v] + where + around _ h [] = h + around 0 h _ = h + around r h us = around (r - 1) (foldr addArc (foldr addVertex h ws) as) ws + where + ws = [w | u <- us, w <- inneighbors d u ++ outneighbors d u, not $ isVertex h w] + as = [(u,w) | u <- us, w <- outneighbors d u] ++ + [(w,u) | u <- us, w <- inneighbors d u] + +topologicalOrdering d = + ordering' d $ S.fromList sources + where + sources = filter (\v -> indegree d v == 0) $ vertices d + ordering' d sources + | numVertices d == 0 = Just [] + | S.null sources = Nothing + | otherwise = + let d' = (foldr removeVertex d $ S.toList sources) + in fmap ((S.toList sources) ++) $ ordering' d' $ S.fromList $ concatMap (\v -> filter (\u -> indegree d' u == 0) $ outneighbors d v) sources + +inducedSubgraph d vs = + foldr addArc (foldr addVertex (empty d) $ S.toList vs) [ (v,u) | (v,u) <- arcs d, v `S.member` vs && u `S.member` vs ] + +transitiveClosure d = + foldr addArc (foldr addVertex (empty d) $ vertices d) $ concat + [ map (\u -> (v,u)) $ filter (/=v) $ metaBfs d v (\_ -> []) id + | v <- vertices d + ] + +-- | Find an isomorphism from `d0` to `d1`, if it exists. +isIsomorphicTo d0 d1 = isIsomorphicToI d0i d1i + where + (d0i, _) = linearizeVertices d0 + (d1i, _) = linearizeVertices d1 + +isIsomorphicToI d0 d1 = isJust $findIso (vertices d0) M.empty candidates0 + where + candidates0 = M.fromList + [ (v, S.fromList us) + | v <- vertices d0 + , let ov = outdegree d0 v + , let iv = indegree d0 v + , let us = filter (\u -> outdegree d1 u == ov && indegree d1 u == iv) $ vertices d1 + ] + findIso [] phi _ = Just phi + findIso (v:vs) phi candidates = mhead $ map fromJust $ filter isJust $ do + u <- S.toList $ candidates M.! v + let phi' = M.insert v u phi + let candidates' = M.map (S.delete u) $ M.delete v $ + foldr (uncurry $ M.insertWith (\n o -> S.intersection n o) ) + candidates $ + [ (w, S.fromList $ outneighbors d1 u) + | w <- outneighbors d0 v + ] ++ + [ (w, S.fromList $ inneighbors d1 u) + | w <- inneighbors d0 v + ] + if null $ M.filter S.null candidates' then + return $ findIso vs phi' candidates' + else + [] + +union d0 d1 = foldr addArc (foldr addVertex d0 $ vertices d1) $ arcs d1 + +-- | Split each vertex `v` of the digraph into two vertices `v_in` and `v_out`. +-- All incoming arcs of `v` become incoming arcs of `v_in`, all +-- outgoing arcs from `v` become outgoing arcs from `v_out` and there is an arc `(v_in, v_out)`. +-- +-- This operation is useful when obtaining a vertex variant of arc-based algorithms like maximum flow. +splitVertices d = d'' + 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]) + + +-- | The line digraph of a digraph `d` is the digraph `(V', A')`, where `V'` is the set of arcs of `d` +-- there is an arc (a,b) if the head of `b` in `d` is the same as the tail of `a` in `d`. +lineDigraphI :: (DirectedGraph t, Adjacency t, Mutable t) => t Int -> (t Int, [(Int, (Int, Int))]) +lineDigraphI d = + let outNeighborhoods = enumerateOutArcs 0 (vertices d) + enumerateOutArcs _ [] = M.empty + enumerateOutArcs i (v:vs) = + let rest = enumerateOutArcs (i + (outdegree d v)) vs + in M.insert v (zip [i..] (outneighbors d v)) rest + vs = [i | us <- map snd $ M.assocs outNeighborhoods, i <- map fst us] + in + ( + foldr addArc (foldr addVertex (empty d) vs) + [ (i, j) + | (v, us) <- M.assocs outNeighborhoods + , (i, u) <- us + , (j, w) <- outNeighborhoods M.! u + ] + , [ (i, (v,u)) + | (v, us) <- M.assocs outNeighborhoods + , (i, u) <- us + ] + ) diff --git a/src/HGraph/Directed/Connectivity.hs b/src/HGraph/Directed/Connectivity.hs --- a/src/HGraph/Directed/Connectivity.hs +++ b/src/HGraph/Directed/Connectivity.hs @@ -1,136 +1,11 @@ module HGraph.Directed.Connectivity - ( reachable - , allPaths - , allLinkages - , allMaximalPaths - , LinkageInstance(..) + ( LinkageInstance(..) , module F , module IL + , module B ) where -import Data.List -import HGraph.Directed +import HGraph.Directed.Connectivity.Basic as B import HGraph.Directed.Connectivity.Flow as F import HGraph.Directed.Connectivity.IntegralLinkage as IL -import qualified Data.Map as M -import qualified Data.Set as S - ---data LinkageInstance a = --- LinkageInstance --- { liTerminalPairs :: M.Map Int (a,a) --- , liCapacities :: M.Map a Int --- , liLinkage :: M.Map a (S.Set Int) --- } - ---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.insertWith S.union v (S.singleton 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 --- | not $ i `S.member` ((liLinkage inst) M.! cv) = Just [(cv,i)] --- where --- (s,t) = (liTerminalPairs inst) M.! i --- d' = foldr removeVertex d --- [ v --- | (v,w) <- M.assocs $ liCapacities inst --- , (not $ i `elem` (liLinkage inst) M.! v) && w == (S.size $ (liLinkage inst) M.! v) --- ] --- cut = minCutI d' s t --- cv = head cut - -reachable d s t = t `elem` (metaBfs d s (\_ -> []) id) - -allPaths d s0 t = allPaths' S.empty s0 - where - allPaths' visited s - | s == t = [[t]] - | otherwise = do - v <- filter (\u -> not $ u `S.member` visited) $ outneighbors d s - fmap (s:) $ allPaths' (S.insert v visited) v - -allLinkages - :: (DirectedGraph t1, Adjacency t1, Eq b, Eq t2, Num t2) - => t1 b -> t2 -> b -> b -> [[[b]]] -allLinkages d k s t = do - s0 <- choose k (outneighbors di si) - fmap (map ((s :) . map (iToV M.!))) $ allLinkages' s0 (S.fromList $ si : s0) - where - (di, itova) = linearizeVertices d - Just si = fmap fst $ find ((==s) . snd) itova - Just ti = fmap fst $ find ((==t) . snd) itova - iToV = M.fromList itova - allLinkages' sj visited - | all (==ti) sj = return $ map (:[]) sj - | otherwise = do - (step, visited') <- linkageSteps di visited sj ti - fmap (zipWith (:) sj) $ allLinkages' step 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 - --- | All maximal paths on a digraph, represented as a list of vertices. --- | Cycles are also considered as maximal paths and their corresponding lists contain the initial vertex twice. -allMaximalPaths d = map (map (iToV M.!)) $ allMaximalPaths' (vertices di) S.empty - where - (di, itova) = linearizeVertices d - iToV = M.fromList itova - allMaximalPaths' [] _ = [] - allMaximalPaths' (v:vs) blocked = vPaths ++ allMaximalPaths' vs (S.insert v blocked) - where - vPaths = concatMap inExtensions $ uniPaths True outneighbors blocked v - uniPaths canClose neighborF visited u - | null nu && (null $ filter (`S.member` blocked) $ neighborF di u) = [[u]] - | null nu && null vCycle = [] - | null nu = [[u, v]] - | otherwise = map (u:) $ vCycle ++ concatMap (uniPaths canClose neighborF (S.insert u visited)) nu - where - nu = filter (not . (`S.member` visited)) $ neighborF di u - vCycle - | not canClose = [] - | v `elem` (neighborF di u) = [[v]] - | otherwise = [] - inExtensions p - | p0 == pn && (not $ null $ drop 1 p) = [p] -- p is already a cycle - | otherwise = map combine $ uniPaths canClose inneighbors (foldr S.insert blocked p) v - where - canClose = null $ drop 1 p -- allow closing backwards cycles - combine q - | null q = [] - | arcExists di (pn, q0) = pn : q' ++ p - | null q' = p - | otherwise = q' ++ p - where - q' = reverse $ tail q - q0 = last q - pn = last p - p0 = head p - -choose 0 _ = [[]] -choose _ [] = [] -choose k (x:xs) = map (x:) (choose (k - 1) xs) ++ choose k xs diff --git a/src/HGraph/Directed/Connectivity/Basic.hs b/src/HGraph/Directed/Connectivity/Basic.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/Connectivity/Basic.hs @@ -0,0 +1,101 @@ +module HGraph.Directed.Connectivity.Basic + ( reach + , reverseReach + , reachable + , allPaths + , allLinkages + , allMaximalPaths + , strongComponents + ) +where + +import Data.List +import HGraph.Directed +import HGraph.Utils +import qualified Data.Map as M +import qualified Data.Set as S + +-- | Vertices that `s` can reach. +reach d s = metaBfs d s (\_ -> []) id +reverseReach d s = metaBfs d s id (\_ -> []) + +-- | Vertices which can reach `s`. +reverseReach d s = metaBfs d s id (\_ -> []) + +reachable d s t = t `elem` (reach d s) + +allPaths d s0 t = allPaths' S.empty s0 + where + allPaths' visited s + | s == t = [[t]] + | otherwise = do + v <- filter (\u -> not $ u `S.member` visited) $ outneighbors d s + fmap (s:) $ allPaths' (S.insert v visited) v + +allLinkages + :: (DirectedGraph t1, Adjacency t1, Eq b, Eq t2, Num t2) + => t1 b -> t2 -> b -> b -> [[[b]]] +allLinkages d k s t = do + s0 <- choose k (outneighbors di si) + fmap (map ((s :) . map (iToV M.!))) $ allLinkages' s0 (S.fromList $ si : s0) + where + (di, itova) = linearizeVertices d + Just si = fmap fst $ find ((==s) . snd) itova + Just ti = fmap fst $ find ((==t) . snd) itova + iToV = M.fromList itova + allLinkages' sj visited + | all (==ti) sj = return $ map (:[]) sj + | otherwise = do + (step, visited') <- linkageSteps di visited sj ti + fmap (zipWith (:) sj) $ allLinkages' step 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 + +-- | All maximal paths on a digraph, represented as a list of vertices. +-- | Cycles are also considered as maximal paths and their corresponding lists contain the initial vertex twice. +allMaximalPaths d = map (map (iToV M.!)) $ allMaximalPaths' (vertices di) S.empty + where + (di, itova) = linearizeVertices d + iToV = M.fromList itova + allMaximalPaths' [] _ = [] + allMaximalPaths' (v:vs) blocked = vPaths ++ allMaximalPaths' vs (S.insert v blocked) + where + vPaths = concatMap inExtensions $ uniPaths True outneighbors blocked v + uniPaths canClose neighborF visited u + | null nu && (null $ filter (`S.member` blocked) $ neighborF di u) = [[u]] + | null nu && null vCycle = [] + | null nu = [[u, v]] + | otherwise = map (u:) $ vCycle ++ concatMap (uniPaths canClose neighborF (S.insert u visited)) nu + where + nu = filter (not . (`S.member` visited)) $ neighborF di u + vCycle + | not canClose = [] + | v `elem` (neighborF di u) = [[v]] + | otherwise = [] + inExtensions p + | p0 == pn && (not $ null $ drop 1 p) = [p] -- p is already a cycle + | otherwise = map combine $ uniPaths canClose inneighbors (foldr S.insert blocked p) v + where + canClose = null $ drop 1 p -- allow closing backwards cycles + combine q + | null q = [] + | arcExists di (pn, q0) = pn : q' ++ p + | null q' = p + | otherwise = q' ++ p + where + q' = reverse $ tail q + q0 = last q + pn = last p + p0 = head p + +-- | All strongly connected components of a digraph, in an arbitrary order. +strongComponents d + | numVertices d == 0 = [] + | otherwise = + let v = head $ vertices d + component = (S.toList $ (S.fromList $ v : reach d v) `S.intersection` (S.fromList $ v : reverseReach d v)) + d' = foldr removeVertex d $ component + in component : strongComponents d' diff --git a/src/HGraph/Directed/Connectivity/Flow.hs b/src/HGraph/Directed/Connectivity/Flow.hs --- a/src/HGraph/Directed/Connectivity/Flow.hs +++ b/src/HGraph/Directed/Connectivity/Flow.hs @@ -1,16 +1,25 @@ module HGraph.Directed.Connectivity.Flow - ( maxFlow + ( isWellLinkedTo , maxDisjointPaths + , maxArcDisjointPaths + , maxFlow + , maxFlowValue , minCut , minCutI + , separableSets + , separableSetsI + , cuttableSubsetI + , findWellLinkedSetI ) where import Data.List import HGraph.Directed +import HGraph.Directed.Connectivity.Basic +import HGraph.Utils import qualified Data.Map as M import qualified Data.Set as S -import Control.Monad +import Data.Maybe 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) @@ -22,6 +31,8 @@ p = shortestPathResidual d s t flow flow' = foldr (M.adjust not) flow $ zip p (tail p) +maxFlowValue d s t = M.size $ M.filterWithKey (\k f -> f && (snd k == t)) $ maxFlow d s t + shortestPathResidual d s t flow = path (S.singleton s) M.empty where path active preds @@ -30,20 +41,29 @@ | 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) - ] + | v <- S.toList active + , u <- outneighbors d v + , (not $ flow M.! (v,u)) && (not $ u `M.member` preds) && u /= s + ] + ++ + [ (u,v) + | v <- S.toList active + , u <- inneighbors d v + , flow M.! (u, v) && (not $ u `M.member` preds && u /= s) + ] makePath preds v | v == s = [v] | otherwise = v : makePath preds (preds M.! v) + +maxArcDisjointPaths :: (Mutable t, DirectedGraph t, Adjacency t, Integral a) => t a -> a -> a -> [[a]] +maxArcDisjointPaths d s t = [s : makePath v | v <- outneighbors d s, v == t || v `M.member` succs] + where + succs = M.fromList $ M.keys $ M.filter (id) $ maxFlow d s t + makePath v + | v == t = [t] + | otherwise = v : makePath (succs 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 @@ -63,24 +83,97 @@ 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] +minCutI d s t = [u `div` 2 | v <- S.toList $ reachS, u <- outneighbors d'' v, not $ u `S.member` reachS] 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)) + reachS = 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) - ] + | 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) + ] + +-- | Is the vertex set `A` well-linked to the vertex set `B`? +-- That is, is there, for every subset `A'` of `A`, some subset `B'` of `B` of the same size such that +-- there is a linkage from `A'` to `B'` containing as many paths as there are vertices in `A'`? +isWellLinkedTo d va vb = isNothing $ separableSets d va vb + +-- | Search for a subset `A'` of `va` and a subset `B'` of `vb` of the same size +-- such that no linkage from `A'` to `B'` connecting all vertices in both sets exist. +separableSets d va vb = separableSetsI di vai vbi k + where + (di, itova) = linearizeVertices d + vToI = M.fromList $ map (\(i,v) -> (v,i)) itova + vai = [ vToI M.! v | v <- va] + vbi = [ vToI M.! v | v <- vb] + k = length vai + +separableSetsI di va vb k = + let splitD = splitVertices di + va' = map (2*) va + vb' = map (\v -> 2*v + 1) vb + vbSet = S.fromList vb' + in fmap (\(a,b) -> + ( map (\v -> v `div` 2) a + , map (\v -> (v - 1) `div` 2) b + ) + ) $ + cuttableSubsetI splitD va' vb' k + +cuttableSubsetI di va vb k = + let vbSet = S.fromList vb + in mhead $ + [ ([a], [S.elemAt 0 nonReachB]) + | a <- va + , let reachA = reach di a + , let nonReachB = foldr + (\u vbSet' -> + if u `S.member` vbSet' then + S.delete u vbSet' + else + vbSet') + vbSet + reachA + , not $ S.null nonReachB + ] + ++ + [ (a', b') + | k' <- [k,k - 1..1] + , a' <- choose k' va + , let s = numVertices di + , let t = s + 1 + , let d1 = foldr addArc (addVertex s di) + [(s, a) | a <- a'] + , let b0 = S.toList $ (S.fromList vb) + `S.intersection` + ( (S.fromList $ reach d1 s) + `S.difference` + (S.fromList a')) + , b' <- choose k' b0 + , let d' = foldr addArc d1 + [(b, t) | b <- b'] + , maxFlowValue d' s t /= k' + ] + +findWellLinkedSetI d k = + let dSplit = splitVertices d + in + mhead [ (va, vb) + | va <- choose k (vertices d) + , let reachA = S.toList $ (foldr1 S.intersection $ map (\v -> S.fromList $ reach d v) va) `S.difference` (S.fromList va) + , vb <- choose k reachA + , isNothing $ cuttableSubsetI dSplit (map (2*) va) (map (\v -> 2*v + 1) vb) k + ] + diff --git a/src/HGraph/Directed/Connectivity/IntegralLinkage.hs b/src/HGraph/Directed/Connectivity/IntegralLinkage.hs --- a/src/HGraph/Directed/Connectivity/IntegralLinkage.hs +++ b/src/HGraph/Directed/Connectivity/IntegralLinkage.hs @@ -10,6 +10,7 @@ import HGraph.Utils import HGraph.Directed import qualified Data.Map as M +import qualified Data.Set as S import Data.Maybe data LinkageInstance a = @@ -18,6 +19,7 @@ , liLinkage :: M.Map a Int , liPath :: M.Map Int [a] } + deriving (Eq, Show) extendLinkage d inst = case extendLinkage' $ M.keys $ liTerminalPairs inst of @@ -28,32 +30,36 @@ 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)) + st' = M.union (M.fromList [ (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'} + path' = M.unionWith (++) (M.fromList $ + [ (i, [t,v]) + | (v,i) <- ext + , let (_,t) = (liTerminalPairs inst) M.! i + , v `elem` (inneighbors d t) + ] + ) + (liPath inst) + in extendLinkage d inst{liTerminalPairs = st', liLinkage = link', liPath = path'} 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)] + | isNothing (cv `M.lookup` (liLinkage inst)) = Just [(cv,i)] + | otherwise = extendLinkage' is where (s,t) = (liTerminalPairs inst) M.! i d' = foldr removeVertex d [ v | v <- vertices d - , maybe False (i ==) (v `M.lookup` (liLinkage inst)) + , v /= s && v /= t && maybe False (i /=) (v `M.lookup` (liLinkage inst)) ] cut = minCutI d' s t cv = head cut @@ -74,7 +80,7 @@ -- | 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 +linkageI d st = linkage' inst0 S.empty where sti = zip [0..] st terminalPairs0 = M.fromList sti @@ -85,20 +91,28 @@ , liPath = M.empty } -- linkage' :: (Eq a, Ord a, Num a) => LinkageInstance a -> Maybe [((a,a), [a])] - linkage' inst + linkage' inst blocked | 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 + v <- filter (\u -> (not $ u `S.member` blocked) && (maybe True (== i) $ 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 + case fmap (\i' -> linkage' i' (S.insert v blocked)) inst' of Just (Just r) -> return r - Nothing -> [] - in mhead tries + _ -> [] + in + if arcExists d (s,t) then + linkage' inst + { liTerminalPairs = M.delete i $ liTerminalPairs inst + , liPath = M.insertWith (++) i [s] $ liPath inst + } + blocked + else + mhead tries diff --git a/src/HGraph/Directed/Connectivity/OneWayWellLinkedness.hs b/src/HGraph/Directed/Connectivity/OneWayWellLinkedness.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/Connectivity/OneWayWellLinkedness.hs @@ -0,0 +1,9 @@ +module HGraph.Directed.Connectivity.OneWayWellLinkedness + ( edgeWellLinkedPair + , edgeWellLinkedPair' + , vertexWellLinkedPair + , Guess(..) + ) +where + +import HGraph.Directed.Connectivity.OneWayWellLinkedness.Internal diff --git a/src/HGraph/Directed/Connectivity/OneWayWellLinkedness/Internal.hs b/src/HGraph/Directed/Connectivity/OneWayWellLinkedness/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/Connectivity/OneWayWellLinkedness/Internal.hs @@ -0,0 +1,136 @@ +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 + { aSet :: S.Set a + , bSet :: S.Set a + , numberOfVertices :: Int + , aCandidates :: S.Set a + , bCandidates :: S.Set a + } + +vertexWellLinkedPair d k = + let remapV v = (v - 1) `div` 3 +-- | v `mod` 2 == 0 = v `div` 2 +-- | otherwise = (v - 1) `div` 2 + dSplit = foldr addArc + (foldr addVertex (empty d) $ + concat [[3*v, 3*v + 1, 3*v + 2] + | v <- vertices d + ] + ) $ + [(3*v + 2, 3*u) | (v, u) <- arcs d] + ++ concat [ [(3*v, 3*v + 1), (3*v + 1, 3*v + 2)] + | v <- vertices d] + in fmap (\(a,b) -> (S.map remapV a , S.map remapV b)) $ + edgeWellLinkedPair' dSplit k + Guess + { aSet = S.empty + , bSet = S.empty + , aCandidates = S.fromList $ map (\v -> 3 * v + 1) $ vertices d + , bCandidates = S.fromList $ map (\v -> 3 * v + 1) $ vertices d + , numberOfVertices = 0 + } + + +edgeWellLinkedPair d k = + edgeWellLinkedPair' d k + Guess + { aSet = S.empty + , bSet = S.empty + , aCandidates = S.fromList $ vertices d + , bCandidates = S.fromList $ vertices d + , numberOfVertices = 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' d k guess + | numberOfVertices guess == k = Just (aSet guess, bSet guess) + | otherwise = addAVertex d k 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 d k guess + | S.null $ aCandidates guess = Nothing + | otherwise = + guessOne (\a guess' -> + let cuttableSets = + [ (a',b') + | k' <- [1.. (numberOfVertices guess')] + , a'' <- choose (k' - 1) $ S.toList $ aSet guess' + , let a' = a : a'' + , b' <- choose k' $ S.toList $ bSet guess' + , let s = numVertices d + , let t = s + 1 + , let d' = foldr addArc (foldr addVertex d [s,t]) $ + [(s, a) | a <- a'] + ++ [(b, t) | b <- b'] + , maxFlowValue d' s t /= k' + ] + in if null cuttableSets then + addBVertex d k $ + restrictBCandidates d a $ + guess'{ aSet = S.insert a (aSet guess') + , aCandidates = S.delete a (aCandidates guess') + , bCandidates = S.delete a (bCandidates guess') + } + else + Nothing + ) + (\a guess' -> guess'{aCandidates = S.delete a (aCandidates guess')}) + guess + $ S.toList $ aCandidates 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 d k guess + | S.null $ bCandidates guess = Nothing + | otherwise = + guessOne + (\b guess' -> + let cuttableSets = + [ (a',b') + | k' <- [0.. (numberOfVertices guess')] + , b'' <- choose (k') $ S.toList $ bSet guess' + , let b' = b : b'' + , a' <- choose (k' + 1) $ S.toList $ aSet guess' + , let s = numVertices d + , let t = s + 1 + , let d' = foldr addArc (foldr addVertex d [s,t]) $ + [(s, va) | va <- a'] + ++ [(vb, t) | vb <- b'] + , maxFlowValue d' s t /= (k' + 1) + ] + in if null cuttableSets then + edgeWellLinkedPair' d k $ restrictACandidates d b $ + guess'{ bSet = S.insert b $ bSet guess' + , bCandidates = S.delete b $ bCandidates guess' + , aCandidates = S.delete b $ aCandidates guess' + , numberOfVertices = 1 + numberOfVertices guess' + } + else + Nothing + ) + (\b guess' -> guess'{bCandidates = S.delete b (bCandidates guess')} + ) + guess + $ S.toList $ bCandidates guess + +restrictBCandidates d a guess = + let reachA = reach d a + in 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 d b guess = + let revReachB = reverseReach d b + in guess + { aCandidates = (aCandidates guess) `S.intersection` (S.fromList revReachB) + } + diff --git a/src/HGraph/Directed/EditDistance/Acyclic/ArcDeletion.hs b/src/HGraph/Directed/EditDistance/Acyclic/ArcDeletion.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/EditDistance/Acyclic/ArcDeletion.hs @@ -0,0 +1,9 @@ +module HGraph.Directed.EditDistance.Acyclic.ArcDeletion + ( minimum + , minimumI + ) +where + +import Prelude hiding (minimum) + +import HGraph.Directed.EditDistance.Acyclic.ArcDeletion.Internal diff --git a/src/HGraph/Directed/EditDistance/Acyclic/ArcDeletion/Internal.hs b/src/HGraph/Directed/EditDistance/Acyclic/ArcDeletion/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/EditDistance/Acyclic/ArcDeletion/Internal.hs @@ -0,0 +1,154 @@ +module HGraph.Directed.EditDistance.Acyclic.ArcDeletion.Internal where + +import Prelude hiding (minimum) + +import HGraph.Directed +import HGraph.Directed.Connectivity.Basic +import HGraph.Directed.Connectivity.Flow + +import Control.Monad +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Map as M + +import qualified Debug.Trace as D (trace) + +minimum :: (DirectedGraph t, Adjacency t, Mutable t) + => t a -> ([(a,a)], Int) +minimum d = + let (di, iToL) = linearizeVertices d + iToLM = M.fromList iToL + (xs, k) = minimumI di + in ( map (\(v,u) -> (iToLM M.! v, iToLM M.! u)) xs, k) + +minimumI :: (DirectedGraph t, Adjacency t, Mutable t) + => t Int -> ([(Int, Int)], Int) +minimumI d + | numArcs d == 0 = ([], 0) + | otherwise = + let loops = [(v,v) | v <- vertices d, arcExists d (v,v)] + d' = foldr removeArc d loops + in foldr + (\c (x, l) -> + let h = inducedSubgraph d' $ S.fromList c + (x', l') = fromJust $ guessArc h (numArcs h - 1) (foldr addVertex (empty d) (vertices d)) + in (x ++ x', l + l')) (loops, length loops) $ + strongComponents d' + +guessArc d kMax fixed = + case filter (\e -> not $ arcExists fixed e) $ arcs d of + [] -> Just ([], 0) + e@(v,u) : _ -> + let fixed' = addArc e fixed + forced = filter (\(x,y) -> reachable fixed' y x) $ arcs d + dKeep = foldr removeArc d forced + csKeep = strongComponents dKeep + kForced = length forced + dRemove = removeArc e d + -- csRemove = strongComponents dRemove + in + if kMax <= 0 then + Nothing + else if kForced > kMax then + separateVertices' d kMax fixed [] [e] + -- minimumIComponents dRemove (kMax - 1) csRemove fixed + else if reachable fixed u v then + separateVertices' d kMax (addArc (u,v) fixed) [] [e] + else + case minimumIComponents dKeep (kMax - kForced) csKeep fixed' of + Nothing -> separateVertices' d kMax fixed [] [e] -- minimumIComponents dRemove (kMax - 1) csRemove fixed + keep@(Just (es, kKeep)) -> + case separateVertices' d (min kMax (kKeep - 1)) fixed [] [e] of + Nothing -> Just (forced ++ es, kKeep + kForced) + solution -> solution + +separateVertices d kMax fixed [] = + let cs = strongComponents d + in minimumIComponents d kMax cs fixed +separateVertices d kMax fixed ((v,u) : forbidden) + | arcExists fixed (v,u) = Nothing + | otherwise = + let directArc = arcExists d (v,u) + d' = if directArc then removeArc (v,u) d else d + ps = maxArcDisjointPaths d' v u + cutSize = length ps + kMax' = if directArc then kMax - 1 else kMax + addSolution (hs, k) = + if directArc then + ((v,u) : hs, k + 1) + else + (hs, k) + in -- D.trace (show (take 10 forbidden, take 10 $ arcs fixed)) $ + if cutSize > kMax' then + Nothing + else + case ps of + [] -> separateVertices d' kMax' fixed forbidden + ((_ : w : _) : _) -> + let (w : _) = drop 1 $ head ps + in + fmap addSolution $ + if arcExists fixed (v,w) then + separateVertices' d' kMax' fixed ((v,u) : forbidden) [(w,v), (w,u)] + else if reachable fixed w v then + separateVertices' d' kMax' fixed ((v, u) : forbidden) [(v, w)] + else + case separateVertices' d' kMax' (addArc (v,w) fixed) ((v,u) : forbidden) [(w,v), (w,u) ] of + Nothing -> separateVertices' d' kMax' fixed ((v, u) : forbidden) [(v, w)] + solution@(Just (hs, k')) -> + (separateVertices' d' (k' - 1) fixed ((v, u) : forbidden)) [(v, w)] + `mplus` + solution + +separateVertices' d kMax fixed forbidden newForbidden = + let newRemoved = filter (arcExists d) newForbidden + kNew = length newRemoved + d' = foldr removeArc d newRemoved + kMax' = kMax - kNew + in + if kMax' < 0 then + Nothing + else + fmap (\(hs, k) -> (newRemoved ++ hs, k + kNew)) $ + separateVertices d' kMax' fixed (newForbidden ++ forbidden) + +--minimumI' d kMax fixed +-- | numArcs d <= 1 = Just ([], 0) +-- | kMax <= 0 = Nothing +-- | otherwise = +-- let forced = filter (\(v,u) -> reachable fixed u v) $ arcs d +-- d' = foldr removeArc d forced +-- kForced = length forced +-- candidates = [ (e, d'', cs) | e <- arcs d' +-- , let d'' = removeArc e d' +-- , let cs = strongComponents d'' +-- , not $ arcExists fixed e +-- -- , any (\c -> null $ drop 1 c) cs +-- ] +-- bestChoice solution _ [] _ = solution +-- bestChoice solution kMax' ((e, d'', cs) : xs) fixed' = +-- case minimumIComponents d'' +-- (if isNothing solution then kMax' - 1 else kMax' - 2) +-- cs +-- fixed +-- of +-- Nothing -> bestChoice solution kMax' xs (addArc e fixed) +-- (Just (es, k)) -> bestChoice (Just (e : es, k + 1)) (k + 1) xs (addArc e fixed) +-- in +-- if kForced > kMax then +-- Nothing +-- else +-- bestChoice Nothing (kMax - kForced) candidates fixed + +minimumIComponents d kMax cs fixed + | length (filter (\c -> not $ null $ drop 1 c) cs) > kMax = Nothing + | otherwise = minComponents kMax cs + where + minComponents kMax' [] = Just ([], 0) + minComponents kMax' (c':cs') = + let h = inducedSubgraph d $ S.fromList c' + in case guessArc h kMax' fixed of + Nothing -> Nothing + Just (xs, k0) -> fmap (\(ys, k') -> (xs ++ ys, k0 + k')) $ minComponents (kMax' - k0) cs' + + diff --git a/src/HGraph/Directed/EditDistance/Acyclic/VertexDeletion.hs b/src/HGraph/Directed/EditDistance/Acyclic/VertexDeletion.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/EditDistance/Acyclic/VertexDeletion.hs @@ -0,0 +1,9 @@ +module HGraph.Directed.EditDistance.Acyclic.VertexDeletion + ( minimum + , minimumI + ) +where + +import Prelude hiding (minimum) + +import HGraph.Directed.EditDistance.Acyclic.VertexDeletion.Internal diff --git a/src/HGraph/Directed/EditDistance/Acyclic/VertexDeletion/Internal.hs b/src/HGraph/Directed/EditDistance/Acyclic/VertexDeletion/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/EditDistance/Acyclic/VertexDeletion/Internal.hs @@ -0,0 +1,64 @@ +module HGraph.Directed.EditDistance.Acyclic.VertexDeletion.Internal where + +import Prelude hiding (minimum) + +import HGraph.Directed +import HGraph.Directed.Connectivity.Basic + +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Map as M + +minimum :: (DirectedGraph t, Adjacency t, Mutable t) + => t a -> ([a], Int) +minimum d = + let (di, iToL) = linearizeVertices d + iToLM = M.fromList iToL + (xs, k) = minimumI di + in ( map (\v -> iToLM M.! v) xs, k) + +minimumI :: (DirectedGraph t, Adjacency t, Mutable t) + => t Int -> ([Int], Int) +minimumI d + | numVertices d == 0 = ([], 0) + | otherwise = + let loops = [v | v <- vertices d, arcExists d (v,v)] + d' = foldr removeVertex d loops + in foldr + (\c (x, l) -> + let h = inducedSubgraph d' $ S.fromList c + (x', l') = fromJust $ minimumI' h (numVertices h - 1) + in (x ++ x', l + l')) (loops, length loops) $ + strongComponents d' + +minimumI' d kMax + | numVertices d <= 1 = Just ([], 0) + | kMax <= 0 = Nothing + | otherwise = + let candidates = [ (v, d', cs) | v <- vertices d + , let d' = removeVertex v d + , let cs = strongComponents d' + -- , any (\c -> null $ drop 1 c) cs + ] + bestChoice solution _ [] = solution + bestChoice solution kMax' ((v, d', cs) : xs) = + case minimumIComponents d' + (if isNothing solution then kMax' - 1 else kMax' - 2) + cs + of + Nothing -> bestChoice solution kMax' xs + (Just (vs, k)) -> bestChoice (Just (v : vs, k + 1)) (k + 1) xs + in bestChoice Nothing kMax candidates + +minimumIComponents d kMax cs + | length (filter (\c -> not $ null $ drop 1 c) cs) > kMax = Nothing + | otherwise = minComponents kMax cs + where + minComponents kMax' [] = Just ([], 0) + minComponents kMax' (c':cs') = + let h = inducedSubgraph d $ S.fromList c' + in case minimumI' h kMax' of + Nothing -> Nothing + Just (xs, k0) -> fmap (\(ys, k') -> (xs ++ ys, k0 + k')) $ minComponents (kMax' - k0) cs' + + diff --git a/src/HGraph/Directed/Generator.hs b/src/HGraph/Directed/Generator.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/Generator.hs @@ -0,0 +1,100 @@ +module HGraph.Directed.Generator + ( bidirectedCycle + , randomAcyclicDigraph + , randomDigraph + , oneWayGrid + ) +where + +import Control.Monad.State +import Data.List +import HGraph.Directed +import HGraph.Utils +import qualified Data.Set as S +import qualified HGraph.Undirected.AdjacencyMap as U +import qualified HGraph.Undirected as U +import qualified HGraph.Undirected.Generator as U +import System.Random + +-- | A cycle where vertices are connected in both directions +bidirectedCycle d0 n = + foldr addArc (foldr addVertex d0 [0..n-1]) $ + (zip ((n-1) : [0..n-2]) (0 : [1..n-1])) + ++ (zip (0:[n-1,n-2..1]) ((n-1):[n-2,n-3..0])) + +-- |Generate a random weakly-connected acyclic digraph with `n` vertices and `m` + `n` - 1 arcs. +randomAcyclicDigraph d0 n m' = do + utree <- U.randomTree U.emptyGraph n + let m = max (n - 1) (min m' (n * (n - 1) `div` 2)) + dtree = acyclicOrientation d0 utree + if (m + n - 1) > (n * (n - 1)) `div` 4 then do + d' <- removeRandomArcs (foldr addArc (foldr addVertex (empty d0) $ vertices dtree) + [ (v,u) + | v <- vertices dtree + , u <- vertices dtree + , v < u && (not $ arcExists dtree (v,u)) + ] + ) + (m - n + 1) + return $ foldr addArc d' $ arcs dtree + else + addRandomArcsAcyclic dtree m + +-- An acyclic grid where columns only go down and rows only go left. +oneWayGrid d0 w h = + foldr addArc (foldr addVertex (empty d0) ([0..w * h - 1])) $ + [ (v, v + 1) + | r <- [0..h-1] + , c <- [0..w-2] + , let v = r*w + c + ] + ++ + [ (v, v + w) + | r <- [0..h-2] + , c <- [0..w-1] + , let v = r*w + c + ] + +acyclicOrientation d0 g = foldr addArc (foldr addVertex (empty d0) $ U.vertices g) $ + [ if u < v then (u,v) else (v,u) + | (u,v) <- U.edges g + ] + +randomDigraph g0 n m + | m > (n * (n - 1)) = randomDigraph g0 n (n * (n - 1)) + | m > (n * (n - 1)) `div` 2 = do -- dense graph + let g1 = foldr addArc (foldr addVertex (empty g0) [1..n]) [(v,u) | v <- [1..n], u <- [1..n], v /= u] + removeRandomArcs g1 m + | otherwise = do -- sparse graph + let g1 = foldr addVertex (empty g0) [0..n-1] + addRandomArcs g1 m + +addRandomArcs g m + | numArcs g == m = return g + | otherwise = do + v <- randomN 0 (numVertices g - 1) + u <- randomN 0 (numVertices g - 1) + if u /= v then + addRandomArcs (addArc (v,u) g) m + else + addRandomArcs g m + +addRandomArcsAcyclic g m + | numArcs g == m = return g + | otherwise = do + v <- randomN 0 (numVertices g - 2) + u <- randomN (v + 1) (numVertices g - 1) + if v < u then + addRandomArcsAcyclic (addArc (v,u) g) m + else + addRandomArcsAcyclic g m + +removeRandomArcs g m + | numArcs g == m = return g + | otherwise = do + v <- randomN 0 (numVertices g - 1) + u <- randomN 0 (numVertices g - 1) + if u /= v && arcExists g (v,u) then + removeRandomArcs (removeArc (v,u) g) m + else + removeRandomArcs g m diff --git a/src/HGraph/Directed/Generator/Hereditary.hs b/src/HGraph/Directed/Generator/Hereditary.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/Generator/Hereditary.hs @@ -0,0 +1,9 @@ +module HGraph.Directed.Generator.Hereditary + ( enumerateParallel + , enumerateParallel' + , random + , exhaust + ) +where + +import HGraph.Directed.Generator.Hereditary.Internal diff --git a/src/HGraph/Directed/Generator/Hereditary/Internal.hs b/src/HGraph/Directed/Generator/Hereditary/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/Generator/Hereditary/Internal.hs @@ -0,0 +1,108 @@ +{-# Language CPP #-} + +module HGraph.Directed.Generator.Hereditary.Internal where + +import HGraph.Directed as D +import HGraph.Parallel +import HGraph.Debugging + +import Data.List +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Set as S +import System.IO (hPutStrLn, stderr) +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad + +data Fingerprint = Fingerprint + { degreeSequence :: [(Int, Int)] + } deriving (Eq, Ord) + +enumerateParallel fGrow dStart vs = do + newDigraph <- newEmptyMVar + digraphCount <- newMVar $ length dStart + candidateCount <- newMVar 0 + mCandidate <- newEmptyMVar + mDistinctDigraphs <- newMVar $ foldr + (\(dFingerprint, d) m -> M.insertWith (\(n0, ds0) (n1, ds1) -> (n0 + n1, ds0 ++ ds1)) + dFingerprint (1, [d]) m) + M.empty $ + map (\d -> (fingerprint d, d)) + dStart + forkIO $ mapM_ (\d -> hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar newDigraph $ Just (d, vs)) dStart + let insertDigraph d = do + distinct <- readMVar mDistinctDigraphs + let dFingerprint = fingerprint d + mCandidates = M.lookup dFingerprint distinct + case mCandidates of + Just (n, candidates) -> + if and $ map (not . (D.isIsomorphicToI d)) candidates then do + modifyMVar_ mDistinctDigraphs $ insertNewDigraph d dFingerprint n candidates + return True + else + return False + Nothing -> do + modifyMVar_ mDistinctDigraphs $ insertNewDigraph d dFingerprint 0 [] + return True + + generateDigraph <- processJobList + (\(d, gen0, vs') -> do + isNew <- if gen0 then + return True + else + insertDigraph d + if isNew then + case vs' of + [] -> return ( [] + , if gen0 then [] else [(d, True)]) + (v : vs'') -> do + let ds = fGrow d v + return (map (\d' -> (d', False, vs'')) ds + , if gen0 then [] else [(d, False)]) + else + return ([], []) + ) + (map (\d -> (d, True, vs)) dStart) + return generateDigraph + +enumerateParallel' fGrow dStart vs = do + generate <- enumerateParallel fGrow dStart vs + return (fmap (fmap fst) generate) + +exhaust generator = + let loop = do + g <- generator + case g of + Just g' -> do + gs <- loop + return $ g' : gs + Nothing -> + return [] + in loop + +random fChoices fCheck dStart vs = return $ head dStart + +insertNewDigraph d + dFingerprint + checkedCandidates + candidates + knownDigraphs = + do + case M.lookup dFingerprint knownDigraphs of + Just (n', candidates') -> do + if and $ map (not . (isIsomorphicToI d)) $ take (n' - checkedCandidates) candidates' then + addToDatabase n' candidates' + else + return knownDigraphs + Nothing -> addToDatabase checkedCandidates candidates + where + addToDatabase n' candidates' = do + return $ M.insert dFingerprint (n' + 1, d : candidates') knownDigraphs + +fingerprint d = + Fingerprint + { degreeSequence = sort $ map (\v -> (D.indegree d v, D.outdegree d v)) $ D.vertices d + } + diff --git a/src/HGraph/Directed/Packing/Cycles.hs b/src/HGraph/Directed/Packing/Cycles.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/Packing/Cycles.hs @@ -0,0 +1,9 @@ +module HGraph.Directed.Packing.Cycles + ( arcMaximumI + , maximum + , maximumI + ) +where + +import Prelude hiding (maximum) +import HGraph.Directed.Packing.Cycles.Internal diff --git a/src/HGraph/Directed/Packing/Cycles/Internal.hs b/src/HGraph/Directed/Packing/Cycles/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/Packing/Cycles/Internal.hs @@ -0,0 +1,122 @@ +module HGraph.Directed.Packing.Cycles.Internal where + +import HGraph.Directed +import HGraph.Directed.Connectivity + +import Prelude hiding (maximum) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe + +-- | A packing of pairwise arc-disjoint cycles of maximum size. +arcMaximumI d = + let (ld, iToA) = lineDigraphI d + iToA' = M.fromList iToA + (packing', k) = maximumI ld + in (map (map fst . map (iToA' M.!)) packing', k) + +-- | Computes a packing of pairwise disjoint cycles of maximum size. +maximum :: (DirectedGraph t, Mutable t, Adjacency t) => t a -> ([[a]], Int) +maximum d = + let (di, iToL) = linearizeVertices d + (cs, k) = maximumI di + labels = M.fromList iToL + in (map (map (labels M.!)) cs, k) + +-- | Computes a packing of pairwise disjoint cycles of maximum size. +-- Vertices of the input digraph must be labeled with integers from `0` to `n - 1`. +maximumI :: (DirectedGraph t, Mutable t, Adjacency t) => t Int -> ([[Int]], Int) +maximumI d + | numVertices d == 0 = ([], 0) + | otherwise = + let loops = [v | v <- vertices d, arcExists d (v,v)] + d' = foldr removeVertex d loops + components = strongComponents d' + in foldr + (\c (cs', k') -> + let h = inducedSubgraph d $ S.fromList c + (cs1, k1) = fromJust $ maximumI' h 1 + in (cs1 ++ cs', k1 + k') + ) + (map (:[]) loops, length loops) + (filter (\c -> not $ null $ drop 1 c) components) + +maximumI' d kMin + | numVertices d <= 1 && kMin <= 0 = Just ([], 0) + | numVertices d < (2 * kMin) = Nothing + | numArcs d == 0 = Nothing + | otherwise = guessArc d kMin $ head (arcs d) + +maximumIWeak d kMin = + let components = strongComponents d + ds = map (\c -> inducedSubgraph d $ S.fromList c) $ filter (\c -> not $ null $ drop 1 c) components + kMaxs = map (\h -> (numVertices h) `div` 2) ds + kMax = sum kMaxs + solution = fst $ foldr + (\(h, kMaxH) (solution, kMaxRest) -> + case solution of + Nothing -> (Nothing, kMaxRest) + Just (cs', k') -> + case maximumI' h $ max 1 (kMin - kMaxRest - k' - kMaxH) of + Nothing -> (Nothing, kMaxRest) + Just (csH, kH) -> (Just (csH ++ cs', kH + k'), kMaxRest - kMaxH)) + ( Just ([], 0) + , kMax) + (zip ds kMaxs) + in case solution of + Nothing -> Nothing + sol@(Just ([], 0)) -> + if kMin <= 0 then + sol + else + Nothing + sol@(Just (cs, k)) -> + if k >= kMin then + sol + else + Nothing + +guessArc d kMin (v,u) = + let withArc = packArc d kMin [u,v] v (v,u) + d' = removeArc (v,u) d + withoutArc kMin' = maximumIWeak d' kMin' + in case withArc of + Nothing -> withoutArc kMin + Just (cs, k) -> + case withoutArc (k + 1) of + Nothing -> withArc + Just (cs', k') -> if k' > k then Just (cs', k') else withArc + +packArc :: (DirectedGraph t, Mutable t, Adjacency t) + => t Int -> Int -> [Int] -> Int -> (Int, Int) -> Maybe ([[Int]], Int) +packArc d kMin cv w (v,u) + | u == w = + let h = foldr removeVertex d $ drop 1 cv + in case maximumIWeak h (kMin - 1) of + Nothing -> Nothing + Just (cs, k) -> Just ((reverse $ drop 1 cv) : cs, k + 1) + | otherwise = + let d1 = foldr removeArc d + [(v,x) | x <- outneighbors d v + , x /= u] + d' = foldr removeArc + d1 + [(x,u) | x <- inneighbors d1 u + , x /= v] + candidates = [ x | x <- + if v == w then + outneighbors d' u + else + filter (/=v) $ outneighbors d' u + , reachable d' x w + ] + bestChoice solution _ [] = solution + bestChoice solution kMin' (x:xs) = + case packArc d' kMin' (x : cv) w (u,x) of + Nothing -> bestChoice solution kMin' xs + sol@(Just (cs, k')) -> bestChoice sol (k' + 1) xs + in + if arcExists d (u, w) then + bestChoice Nothing kMin [w] + else + bestChoice Nothing kMin candidates diff --git a/src/HGraph/Directed/Subgraph.hs b/src/HGraph/Directed/Subgraph.hs --- a/src/HGraph/Directed/Subgraph.hs +++ b/src/HGraph/Directed/Subgraph.hs @@ -4,6 +4,8 @@ , subgraphIsomorphism , subgraphIsomorphismI , isSubgraphIsomorphism + , enumerateSubgraphs + , enumerateSubgraphsI ) where @@ -12,6 +14,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe +import Data.List -- | Whether `d` contains `h` as a subgraph (the identity is used for the isomorphism). contains d h = null $ @@ -58,6 +61,58 @@ return $ findIso vs phi' candidates' else [] + +-- | Enumerate all subgraphs of `d` which are isomorphic to `h` +enumerateSubgraphs :: (DirectedGraph t, Adjacency t, Mutable t) => t a -> t b -> [t a] +enumerateSubgraphs d h = map (renameVertices iToV (empty d)) $ enumerateSubgraphsI di hi + where + (hi, itovh) = linearizeVertices h + (di, itovd) = linearizeVertices d + iToV = M.fromList itovd + +enumerateSubgraphsI d hi = + do + u0 <- S.toList $ candidates0 M.! v0 + embed d M.empty S.empty candidates0 ((inneighbors hi v0) ++ (outneighbors hi v0)) (S.fromList $ vertices hi) v0 u0 + where + (v0, deg0) = maximumBy (\v u -> compare (snd v) (snd u)) [(v, indegree hi v + outdegree hi v) | v <- vertices hi] + candidates0 = M.fromList + [ (v, S.fromList us) + | v <- vertices hi + , let ov = outdegree hi v + , let iv = indegree hi v + , let us = filter (\u -> outdegree d u >= ov && indegree d u >= iv) $ vertices d + ] + embed :: (DirectedGraph t, Adjacency t, Mutable t, Ord a) => + t a -> M.Map Int a -> S.Set a -> M.Map Int (S.Set a) -> [Int] -> (S.Set Int) -> Int -> a -> [t a] + embed d phi blocked candidates queue missing v u + | or $ map (\v' -> S.null $ candidates' M.! v' ) vN = [] + | otherwise = embeddings d (M.insert v u phi) (S.insert u blocked) candidates' queue missing + where + vN = filter (not . (`M.member` phi)) $ outneighbors hi v ++ inneighbors hi v + candidates' = (foldr (\(v', n) c -> M.insertWith S.intersection v' n c) candidates $ + [ (v', S.fromList $ filter (not . (`S.member` blocked)) $ + outneighbors d u) + | v' <- outneighbors hi v ] ++ + [ (v', S.fromList $ filter (not . (`S.member` blocked)) $ + inneighbors d u) + | v' <- inneighbors hi v ] + ) + embeddings :: (DirectedGraph t, Adjacency t, Mutable t, Ord a) => + t a -> M.Map Int a -> S.Set a -> M.Map Int (S.Set a) -> [Int] -> (S.Set Int) -> [t a] + embeddings d phi blocked candidates [] missing + | S.null missing = return $ toSubgraph d phi + | otherwise = + let v = head $ S.toList missing + in embeddings d phi blocked candidates [v] (S.delete v missing) + embeddings d phi blocked candidates (v:vs) missing + | v `M.member` phi = embeddings d phi blocked candidates vs missing + | otherwise = do + u <- S.toList $ candidates M.! v + embed d phi blocked candidates ((inneighbors hi v) ++ (outneighbors hi v) ++ vs) (S.delete v missing) v u + toSubgraph :: (DirectedGraph t, Adjacency t, Mutable t, Ord a) => t a -> M.Map Int a -> t a + toSubgraph d phi = + foldr addArc (foldr addVertex (empty d) $ M.elems phi) [(phi M.! v, phi M.! u) | (v,u) <- arcs hi] -- | Whether `phi` is a subgraph isomorphism from `h` to some subgraph of `d`. isSubgraphIsomorphism d h phi = null diff --git a/src/HGraph/Directed/TopologicalMinor.hs b/src/HGraph/Directed/TopologicalMinor.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Directed/TopologicalMinor.hs @@ -0,0 +1,41 @@ +module HGraph.Directed.TopologicalMinor + ( isMinorOf + , isMinorOfI + , isMinorEmbedding + , topologicalMinor + , topologicalMinorI + ) +where + +import HGraph.Directed +import HGraph.Directed.Connectivity +import HGraph.Directed.Subgraph +import HGraph.Utils +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe + +-- | Whether there is some subgraph of `d` which is isomorphic to some subdivision of `h` +isMinorOf h d = isJust $ topologicalMinor h d + +isMinorOfI h di = isJust $ topologicalMinor h di + +isMinorEmbedding h d phi = isJust $ linkage d [(phi M.! v, phi M.! u) | (v,u) <- arcs h] + +topologicalMinor h d = fmap convertResult $ topologicalMinorI h di + where + (di, itova) = linearizeVertices d + iToV = M.fromList itova + convertResult phi = M.map (iToV M.!) phi + +topologicalMinorI h di = mhead $ + [ phi + | phi <- embeddings + , isJust $ linkageI di [(phi M.! v, phi M.! u) | (v,u) <- arcs h] + ] + where + embeddings = embeddings' (vertices h) S.empty M.empty + embeddings' [] _ phi = return phi + embeddings' (v:vs) blocked phi = do + u <- filter (\u -> (not $ u `S.member` blocked) && indegree di u >= indegree h v && outdegree di u >= outdegree h v ) $ vertices di + embeddings' vs (S.insert u blocked) (M.insert v u phi) diff --git a/src/HGraph/Parallel.hs b/src/HGraph/Parallel.hs new file mode 100644 --- /dev/null +++ b/src/HGraph/Parallel.hs @@ -0,0 +1,137 @@ +{-# Language CPP #-} + +module HGraph.Parallel + ( produceConsumeExhaustive + , processJobList + ) +where + +import HGraph.Debugging + +import Control.Concurrent +import Data.Maybe +import Control.Monad +import Control.Concurrent.MVar +import Control.Exception +import System.IO (hPutStrLn, stderr) + +-- | Runs the producer until it output `Nothing`. +-- Each successful product is sent to the consumer. +-- Returns an IO action which takes the next product (or `Nothing` if there are no more products) +produceConsumeExhaustive :: (IO (Maybe a)) -> (a -> IO b) -> IO (IO (Maybe b)) +produceConsumeExhaustive produce consume = do + numForks <- getNumCapabilities + mProduct <- newEmptyMVar + workerDone <- replicateM numForks $ newEmptyMVar + producers <- forM workerDone $ \doneM -> forkFinally + ( let loop = do + g <- hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ produce + when (isJust g) $ do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar mProduct g + loop + in loop + ) + (\e -> do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar doneM () + case e of + Left err -> (sayErrString (__FILE__ ++ " on line " ++ show __LINE__ + ++ " produce-consume error (producer):\n\t -" + ++ show (err :: SomeException))) + Right res -> do + return () + ) + consumerDone <- replicateM numForks $ newEmptyMVar + consumerOutput <- newEmptyMVar + consumers <- forM consumerDone $ \doneM -> forkFinally + ( let loop = do + g <- hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ takeMVar mProduct + case g of + Just p -> do + out <- hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ consume p + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar consumerOutput (Just out) + loop + Nothing -> hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar mProduct Nothing + in loop + ) + (\e -> do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar doneM () + case e of + Left err -> (sayErrString (__FILE__ ++ " on line " ++ show __LINE__ ++ ": produce-consume error (consumer):\n\t- " ++ show (err :: SomeException))) + Right res -> do + return () + ) + forkFinally (do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ mapM_ takeMVar workerDone + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar mProduct Nothing + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ mapM_ takeMVar consumerDone + ) + (\res -> do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar consumerOutput Nothing + case res of + Left err -> sayErrString (__FILE__ ++ " on line " ++ show __LINE__ + ++ ": produce-consume error (final):\n\t- " + ++ show (err :: SomeException)) + Right _ -> return () + ) + + return (takeMVar consumerOutput) + +processJobList :: (a -> IO ([a], [b])) -> [a] -> IO (IO (Maybe b)) +processJobList worker jobs = do + numForks <- getNumCapabilities + workerDone <- replicateM numForks $ newEmptyMVar + workerOutput <- newEmptyMVar + mReady <- newMVar () + mJobs <- newMVar jobs + mBusyCount <- newMVar 0 + + _ <- forM workerDone $ \doneM -> forkFinally + ( let loop = do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ takeMVar mReady + openJobs <- hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ takeMVar mJobs + busy0 <- modifyMVar mBusyCount (\c -> return $ (c + 1, c + 1)) + case openJobs of + [] -> do + modifyMVar_ mBusyCount (\c -> return $ c - 1) + if busy0 == 1 then do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar mReady () + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar mJobs [] + else + loop + (j : jobs') -> do + when (not $ null jobs') $ + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar mReady () + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar mJobs jobs' + (newJobs, newResults) <- worker j + openJobs'' <- modifyMVar mJobs $ \openJobs' -> do + return $ (newJobs ++ openJobs', openJobs') + busy <- modifyMVar mBusyCount (\c -> return $ (c - 1, c - 1)) + when (null openJobs'' && ( (not $ null newJobs) || busy == 0)) $ do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar mReady () + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ mapM_ ((putMVar workerOutput) . Just) newResults + loop + in loop + ) + (\e -> do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar doneM () + case e of + Left err -> (sayErrString (__FILE__ ++ " on line " ++ show __LINE__ + ++ " job list error (worker):\n\t -" + ++ show (err :: SomeException))) + Right res -> do + return () + ) + + forkFinally (do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ mapM_ takeMVar workerDone + ) + (\res -> do + hasLocked (__FILE__ ++ " on line " ++ show __LINE__) $ putMVar workerOutput Nothing + case res of + Left err -> sayErrString (__FILE__ ++ " on line " ++ show __LINE__ + ++ ": job list error (end):\n\t- " + ++ show (err :: SomeException)) + Right _ -> return () + ) + + return (takeMVar workerOutput) diff --git a/src/HGraph/Undirected.hs b/src/HGraph/Undirected.hs --- a/src/HGraph/Undirected.hs +++ b/src/HGraph/Undirected.hs @@ -49,7 +49,7 @@ component = metaBfs g v id class Mutable t where - addVertex :: t a -> a -> t a - removeVertex :: t a -> a -> t a - addEdge :: t a -> (a,a) -> t a - removeEdge :: t a -> (a,a) -> t a + addVertex :: a -> t a -> t a + removeVertex :: a -> t a -> t a + addEdge :: (a,a) -> t a -> t a + removeEdge :: (a,a) -> t a -> t a diff --git a/src/HGraph/Undirected/AdjacencyMap.hs b/src/HGraph/Undirected/AdjacencyMap.hs --- a/src/HGraph/Undirected/AdjacencyMap.hs +++ b/src/HGraph/Undirected/AdjacencyMap.hs @@ -27,7 +27,7 @@ where assocs = zip [0..] (M.keys adj) ltoi = M.fromList $ zip (M.keys adj) [0..] - g' = foldr (flip addEdge) (foldr (flip addVertex) emptyGraph (map fst assocs)) $ + g' = foldr addEdge (foldr addVertex emptyGraph (map fst assocs)) $ [ (ltoi M.! u, ltoi M.! v) | (u,v) <- edges g ] @@ -41,17 +41,17 @@ svs = S.fromList vs instance Mutable Graph where - addVertex (Graph adj nE) v = Graph (M.insert v S.empty adj) nE - removeVertex g@(Graph adj nE) v = + addVertex v (Graph adj nE) = Graph (M.insert v S.empty adj) nE + removeVertex v g@(Graph adj nE) = Graph (M.delete v $ foldr (M.adjust (S.delete v)) adj nv) (nE - (degree g v)) where nv = neighbors g v - addEdge g@(Graph adj nE) (v,u) + addEdge (v,u) g@(Graph adj nE) | edgeExists g (v,u) = g | otherwise = Graph adj' (nE + 1) where adj' = M.insertWith S.union v (S.singleton u) $ M.insertWith S.union u (S.singleton v) adj - removeEdge g@(Graph adj nE) (v,u) + removeEdge (v,u) g@(Graph adj nE) | not $ edgeExists g (v,u) = g | otherwise = Graph adj' (nE - 1) where diff --git a/src/HGraph/Undirected/Generator.hs b/src/HGraph/Undirected/Generator.hs --- a/src/HGraph/Undirected/Generator.hs +++ b/src/HGraph/Undirected/Generator.hs @@ -4,39 +4,52 @@ , completeTree , completeGraph , randomGraph + , randomTree ) where -import HGraph.Undirected -import Data.List import Control.Monad.State +import Data.List +import HGraph.Undirected +import HGraph.Utils +import qualified Data.Set as S import System.Random -cycleGraph g0 n = foldr (flip addEdge) (foldr (flip addVertex) g0 [0..n-1]) [(x, (x + 1) `mod` n) | x <- [0..n-1]] +cycleGraph g0 n = foldr addEdge (foldr addVertex g0 [0..n-1]) [(x, (x + 1) `mod` n) | x <- [0..n-1]] -grid g0 w h = foldr (flip addEdge) (foldr (flip addVertex) g0 vs) es +grid g0 w h = foldr addEdge (foldr addVertex g0 vs) es where vs = [(x,y) | x <- [1..w], y <- [1..h]] es = concat [[(v,(x+1,y)), (v, (x,y+1))] | x <- [1..w-1], y <- [1..h-1], let v = (x,y)] ++ [((x, h), (x+1, h)) | x <- [1..w-1]] ++ [((w, y), (w, y+1)) | y <- [1..h-1]] -completeTree g0 depth arity = completeTree' (addVertex (empty g0) 0) 0 1 +completeTree g0 depth arity = completeTree' (addVertex 0 (empty g0)) 0 1 where completeTree' g root d | d > depth = g | otherwise = head $ drop arity $ iterate' (\h -> let r1 = numVertices h - in addEdge (completeTree' (addVertex h r1) r1 (d+1) ) (root,r1)) g + in addEdge (root,r1) (completeTree' (addVertex r1 h) r1 (d+1) ) ) g -completeGraph g0 k = foldr (flip addEdge) (foldr (flip addVertex) (empty g0) [0..k-1]) [(u,v) | u <- [0..k-1], v <- [u+1..k-1] ] +completeGraph g0 k = foldr addEdge (foldr addVertex (empty g0) [0..k-1]) [(u,v) | u <- [0..k-1], v <- [u+1..k-1] ] +randomTree g0 n = do + randomTree' (foldr addVertex (empty g0) [0..n-1]) (S.singleton 0) (S.fromList [1..n-1]) + where + randomTree' g added missing + | S.null missing = return g + | otherwise = do + v <- fmap (\i -> S.elemAt i missing) $ randomN 0 (S.size missing - 1) + u <- fmap (\i -> S.elemAt i added) $ randomN 0 (S.size added - 1) + randomTree' (addEdge (v,u) g) (S.insert v added) (S.delete v missing) + randomGraph g0 n m | m > (n * (n - 1)) `div` 4 = do -- dense graph - let g1 = foldr (flip addEdge) (foldr (flip addVertex) (empty g0) [1..n]) [(v,u) | v <- [1..n], u <- [v+1..n]] + let g1 = foldr addEdge (foldr addVertex (empty g0) [1..n]) [(v,u) | v <- [1..n], u <- [v+1..n]] removeRandomEdges g1 m - | otherwise = do -- spare graph - let g1 = foldr (flip addVertex) (empty g0) [0..n-1] + | otherwise = do -- sparse graph + let g1 = foldr addVertex (empty g0) [0..n-1] addRandomEdges g1 m addRandomEdges g m @@ -45,7 +58,7 @@ v <- randomN 0 (numVertices g - 1) u <- randomN 0 (numVertices g - 1) if u /= v then - addRandomEdges (addEdge g (v,u)) m + addRandomEdges (addEdge (v,u) g) m else addRandomEdges g m @@ -55,13 +68,7 @@ v <- randomN 0 (numVertices g - 1) u <- randomN 0 (numVertices g - 1) if u /= v && edgeExists g (v,u) then - removeRandomEdges (removeEdge g (v,u)) m + removeRandomEdges (removeEdge (v,u) g) m else removeRandomEdges g m -randomN :: (Random a, RandomGen g) => a -> a -> State g a -randomN n0 n1 = do - gen <- get - let (r,gen') = randomR (n0,n1) gen - put gen' - return r diff --git a/src/HGraph/Undirected/Load.hs b/src/HGraph/Undirected/Load.hs --- a/src/HGraph/Undirected/Load.hs +++ b/src/HGraph/Undirected/Load.hs @@ -15,6 +15,6 @@ return $ let (ns, es) = D.adjacency dot names = (S.toList $ S.fromList $ map getNodeName ns) - addE (D.Edge v u _) d = addEdge d (v, u) + addE (D.Edge v u _) d = addEdge (v, u) d getNodeName (D.Node name _) = name - in foldr addE (foldr (flip addVertex) gr names) es + in foldr addE (foldr addVertex gr names) es diff --git a/src/HGraph/Undirected/Solvers/IndependentSet.hs b/src/HGraph/Undirected/Solvers/IndependentSet.hs --- a/src/HGraph/Undirected/Solvers/IndependentSet.hs +++ b/src/HGraph/Undirected/Solvers/IndependentSet.hs @@ -25,7 +25,7 @@ fmap (xs ++) $ mhead [ u : fromJust ys | u <- vertices g' - , let ys = atLeast (foldr (flip removeVertex) g' $ u : neighbors g' u) (k - 1 - k') + , let ys = atLeast (foldr removeVertex g' $ u : neighbors g' u) (k - 1 - k') , isJust ys] reduce g k @@ -34,12 +34,12 @@ | otherwise = let xs0 = filter (\v -> degree g v == 0) $ vertices g xsn = filter (\v -> degree g v >= (numVertices g) - k + 1) $ vertices g - g' = foldr (flip removeVertex) g (xsn ++ xs0) + g' = foldr removeVertex g (xsn ++ xs0) x1 = take 1 $ filter (\v -> degree g' v == 1) $ vertices g' in case x1 of [v] -> let k0 = length xs0 - g'' = foldr (flip removeVertex) g' $ v : neighbors g' v + g'' = foldr removeVertex g' $ v : neighbors g' v (g''', xs', k') = reduce g'' (k - k0 - 1) in (g''', v:xs0 ++ xs', 1 + k0 + k') [] -> (g', xs0, length xs0) diff --git a/src/HGraph/Undirected/Solvers/Treedepth.hs b/src/HGraph/Undirected/Solvers/Treedepth.hs --- a/src/HGraph/Undirected/Solvers/Treedepth.hs +++ b/src/HGraph/Undirected/Solvers/Treedepth.hs @@ -48,7 +48,7 @@ where guess v = fmap (addRoot v) td where - td = treedepthAtMost (removeVertex g v) (k - 1) + td = treedepthAtMost (removeVertex v g) (k - 1) isDecomposition g td = all (\(v,u) -> v `S.member` (ancestors M.! u) || u `S.member` (ancestors M.! v)) $ diff --git a/src/HGraph/Undirected/Solvers/VertexCover.hs b/src/HGraph/Undirected/Solvers/VertexCover.hs --- a/src/HGraph/Undirected/Solvers/VertexCover.hs +++ b/src/HGraph/Undirected/Solvers/VertexCover.hs @@ -29,8 +29,8 @@ | numEdges g' == 0 = Just sol' | numEdges g' > k * k = Nothing | otherwise = - (fmap (v:) $ vertexCoverAtMost' (removeVertex g' v) (k'-1)) `mplus` - (fmap (nv++) $ vertexCoverAtMost' (foldr (flip removeVertex) g' (v:nv)) (k' - (degree g' v))) + (fmap (v:) $ vertexCoverAtMost' (removeVertex v g') (k'-1)) `mplus` + (fmap (nv++) $ vertexCoverAtMost' (foldr removeVertex g' (v:nv)) (k' - (degree g' v))) where (g', sol', k') = reduce g k e' = edges g' @@ -42,11 +42,11 @@ reduce' g k sol [] _ = (g,sol,k) reduce' g k sol (v:vs) visited | v `S.member` visited = reduce' g k sol vs visited - | d == 1 = reduce' (removeVertex (removeVertex g v) u) (k-1) (u:sol) (un ++ vs) + | d == 1 = reduce' (removeVertex u (removeVertex v g)) (k-1) (u:sol) (un ++ vs) ( (S.insert v $ S.insert u visited) `S.difference` (S.delete v $ S.fromList un)) - | d == 0 = reduce' (removeVertex g v) k sol vs (S.insert v visited) - | d > k = reduce' (removeVertex g v) (k - 1) (v:sol) (vn ++ vs) + | d == 0 = reduce' (removeVertex v g) k sol vs (S.insert v visited) + | d > k = reduce' (removeVertex v g) (k - 1) (v:sol) (vn ++ vs) ((S.insert v visited) `S.difference` (S.fromList vn)) | otherwise = reduce' g k sol vs (S.insert v visited) where diff --git a/src/HGraph/Utils.hs b/src/HGraph/Utils.hs --- a/src/HGraph/Utils.hs +++ b/src/HGraph/Utils.hs @@ -1,4 +1,26 @@ module HGraph.Utils where +import System.Random +import Control.Monad +import Control.Monad.State + mhead [] = Nothing mhead (x:_) = Just x + +randomN :: (Random a, RandomGen g) => a -> a -> State g a +randomN n0 n1 = do + gen <- get + let (r,gen') = randomR (n0,n1) gen + put gen' + return r + +-- | Lists all subsets of `s` of size exactly `k`. +choose 0 _ = [[]] +choose _ [] = [] +choose k (x:xs) = map (x:) (choose (k - 1) xs) ++ choose k xs + +guessOne _ _ _ [] = Nothing +guessOne taken notTaken guess (x:xs) = + (taken x guess) + `mplus` + (guessOne taken notTaken (notTaken x guess) xs) diff --git a/tests/Digraph/AdjacencyMap.hs b/tests/Digraph/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/tests/Digraph/AdjacencyMap.hs @@ -0,0 +1,32 @@ +module Main where + +import HGraph.Directed +import qualified HGraph.Directed.AdjacencyMap as AM +import qualified Data.Set as S + +import Test.HUnit hiding (Node) +import System.Exit (exitFailure, exitSuccess) + +tests = TestList + [ TestLabel "Subgraph around path 1" $ TestCase + ( do + let d = foldr addArc (foldr addVertex AM.emptyDigraph [0,1,2,3,4,5]) + (zip [0..4] [1..5]) + assertEqual "r = 0" ([]) (arcs $ subgraphAround 0 d 3) + assertEqual "r = 1" (S.fromList [(2,3), (3,4)]) (S.fromList $ arcs $ subgraphAround 1 d 3) + assertEqual "r = 2" (S.fromList [(2,3), (3,4), (4,5), (1,2)]) (S.fromList $ arcs $ subgraphAround 2 d 3) + assertEqual "r = 3" (S.fromList $ arcs d) (S.fromList $ arcs $ subgraphAround 3 d 3) + ) + , TestLabel "Subgraph around 2" $ TestCase + ( do + let d = foldr addArc (foldr addVertex AM.emptyDigraph [0,1,2]) + ([(0,1), (1,2), (0,2)]) + assertEqual "r = 0" ([]) (arcs $ subgraphAround 0 d 0) + assertEqual "r = 1" (S.fromList $ [(0,1), (0,2)]) (S.fromList $ arcs $ subgraphAround 1 d 0) + assertEqual "r = 2" (S.fromList $ arcs d) (S.fromList $ arcs $ subgraphAround 2 d 0) + ) + ] + +main = do + count <- runTestTT tests + if errors count + failures count > 0 then exitFailure else exitSuccess diff --git a/tests/Digraph/Connectivity.hs b/tests/Digraph/Connectivity.hs --- a/tests/Digraph/Connectivity.hs +++ b/tests/Digraph/Connectivity.hs @@ -2,9 +2,13 @@ import HGraph.Directed import HGraph.Directed.Connectivity +import HGraph.Directed.Connectivity.OneWayWellLinkedness import qualified HGraph.Directed.AdjacencyMap as AM import qualified Data.Set as S +import qualified Data.Map as M +import Data.Maybe +import TestUtils import Test.HUnit hiding (Node) import System.Exit (exitFailure, exitSuccess) @@ -86,6 +90,206 @@ ] ) (S.fromList $ map arcSet ps) + ) + , TestLabel "Maximum flow 0" $ TestCase + ( do + let w = 2 + h = 4 + s = w * h + t = s + 1 + let d = foldr addArc (foldr addVertex (AM.emptyDigraph :: AM.Digraph Int) (s:t:[0..w * h - 1])) $ + [ (v, v + 1) + | r <- [0..h-1] + , c <- [0..w-2] + , let v = r*w + c + ] + ++ + [ (v, v + w) + | r <- [0..h-2] + , c <- [0..w-1] + , let v = r*w + c + ] + ++ + [(s,a) | a <- [0,w,2*w]] + ++ + [(b,t) | b <- [w+1, 2*w + 1, 3*w + 1]] + + flow = maxFlow d s t + assertEqual "s degree" + ( 3 ) + (length [v | v <- vertices d, M.lookup (s,v) flow == Just True]) + assertEqual "t degree" + ( 3 ) + (length [v | v <- vertices d, M.lookup (v,t) flow == Just True]) + ) + , TestLabel "Linkage 1" $ TestCase + ( do + let d = foldr addArc (foldr addVertex (AM.emptyDigraph :: AM.Digraph Int) [0,1]) $ + [ (0,1), (1,0) ] + inst0 = + LinkageInstance + { liLinkage = M.fromList $ + concatMap (\(i, (s,t)) -> [(s, i), (t, i)]) [(0,(0,1))] + , liTerminalPairs = M.singleton 0 (0,1) + , liPath = M.empty + } + {-assertEqual "extend 0-1 linkage" + (Just inst0{liPath = M.singleton 0 [0,1]}) + (extendLinkage d inst0)-} + assertBool "0-1 linkage" + (isJust $ linkageI d [(0,1)]) + assertBool "0-1 1-0 linkage" + (isJust $ linkageI d [(0,1), (1,0)]) + ) + , TestLabel "Linkage 2" $ TestCase + ( do + let d = foldr addArc (foldr addVertex (AM.emptyDigraph :: AM.Digraph Int) [0,1,2]) $ + [ (0,1), (1,2), (2,0) ] + inst0 = + LinkageInstance + { liLinkage = M.fromList $ + concatMap (\(i, (s,t)) -> [(s, i), (t, i)]) [(0,(0,2)), (1, (2,0))] + , liTerminalPairs = M.fromList [(0,(0,2)), (1,(2,0))] + , liPath = M.empty + } + assertEqual "extend 0-2 linkage" + (Just inst0{ liPath = M.singleton 0 [2,1] + , liLinkage = M.fromList [(0,1), (1,0), (2,1)] + , liTerminalPairs = M.fromList [(0, (0,1)), (1, (2,0))] + }) + (extendLinkage d inst0) + assertBool "0-2 linkage" + (isJust $ linkageI d [(0,2)]) + assertBool "0-2 2-0 linkage" + (isJust $ linkageI d [(0,2), (2,0)]) + ) + , TestLabel "Linkage 3" $ TestCase + ( do + let d = foldr addArc (foldr addVertex (AM.emptyDigraph :: AM.Digraph Int) [0..11]) $ + [ (0,1), (1,2), (2,1) + , (1,0), (1,4), (1,7) + , (3,4), (3,5), (3,11) + , (4,6), (4,5), (4,7), (4,3) + , (5,10), (5,6), (5,8), (5,3) + , (6,4), (6,5) + , (7,9), (7,8) + , (8,9), (8,10) + , (11,3) + ] + assertBool "0-10 linkage" + (isJust $ linkageI d [(0,10)]) + assertBool "3-9 linkage" + (isJust $ linkageI d [(3,9)]) + assertBool "0-10 3-9 linkage" + (isNothing $ linkageI d [(0,10), (3,9)]) + ) + , TestLabel "Well-linked sets 0" $ TestCase + ( do + -- 0 → 1 → 2 → 3 + -- ↓ ↓ ↓ ↓ + -- 4 → 5 → 6 → 7 + -- ↓ ↓ ↓ ↓ + -- 8 → 9 → 10 → 11 + -- ↓ ↓ ↓ ↓ + -- 12 → 13 → 14 → 15 + -- ↓ ↓ ↓ ↓ + -- 16 → 17 → 18 → 19 + let w = 4 + h = 5 + let d = foldr addArc (foldr addVertex (AM.emptyDigraph :: AM.Digraph Int) [0..w * h - 1]) $ + [ (v, v + 1) + | r <- [0..h-1] + , c <- [0..w-2] + , let v = r*w + c + ] + ++ + [ (v, v + w) + | r <- [0..h-2] + , c <- [0..w-1] + , let v = r*w + c + ] + assertEqual "0,4 → 11,15 well-linked" + Nothing + (separableSets d [0,4] [11,15]) + assertEqual "4,8 → 5,9 not well-linked" + (Just ([8],[5])) + (separableSets d [4,8] [5,9]) + assertEqual "0,4,8 → 9,13,17 not well-linked" + (Just ([0,4,8],[9,13,17])) + (separableSets d [0,4,8] [9,13,17]) + ) + , TestLabel "Well-linked sets 0" $ TestCase + ( do + -- 4 + -- ↓ + -- 2 → 1 → 0 + -- ↓ ↑ ↓ + -- ∟ → 3 → 5 + let d = foldr addArc (foldr addVertex (AM.emptyDigraph :: AM.Digraph Int) [0..5]) $ + [ (0, 5) + , (1, 0) + , (2, 1), (2, 3) + , (3, 1), (3, 5) + , (4, 1) + ] + dSplit = splitVertices d + s = numVertices dSplit + t = s + 1 + a = map (2*) [2,3,4] + b = map (\v -> 2*v + 1) [0,1,5] + dSplit' = foldr addArc (foldr addVertex dSplit [s,t]) $ + [(s, va) | va <- a] ++ + [(vb, t) | vb <- b] + assertEqual "max flow 2" + 2 + (maxFlowValue dSplit' s t) + assertEqual "no 3 one-way-well-linked set pair" + Nothing + (vertexWellLinkedPair d 3) + ) + , TestLabel "Vertex well-linked sets 1" $ TestCase + ( do + -- 0 → 1 + -- ↓ ↓ + -- 2 → 3 + -- ↓ ↓ + -- 4 → 5 + let w = 2 + h = 3 + let d = foldr addArc (foldr addVertex (AM.emptyDigraph :: AM.Digraph Int) [0..w * h - 1]) $ + [ (v, v + 1) + | r <- [0..h-1] + , c <- [0..w-2] + , let v = r*w + c + ] + ++ + [ (v, v + w) + | r <- [0..h-2] + , c <- [0..w-1] + , let v = r*w + c + ] + dSplit = splitVertices d + assertEqual "0,2 → 3,5 edge well-linked" + (Just (S.fromList [0,2], S.fromList [3,4])) + (edgeWellLinkedPair (removeVertex 5 d) 2) + assertEqual "0,2 → 3,5 well-linked" + (Just (S.fromList [0,1], S.fromList [3,5])) + (vertexWellLinkedPair d 2) + ) + , TestLabel "Strong components 1" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [(0,1), (0,2), (1,3), (2,3)] + components0 = strongComponents d + assertEqual "Vertices" 4 (numVertices d) + assertEqual "Arcs" 4 (numArcs d) + assertEqual "Strong components 0" + (S.fromList [[0],[1],[2],[3]]) + (S.fromList components0) + let d1 = addArc (3,0) d + components1 = strongComponents d1 + assertEqual "Strong components 1" + ([S.fromList [0,1,2,3]]) + (map S.fromList components1) ) ] diff --git a/tests/Digraph/EditDistance-Acyclic.hs b/tests/Digraph/EditDistance-Acyclic.hs new file mode 100644 --- /dev/null +++ b/tests/Digraph/EditDistance-Acyclic.hs @@ -0,0 +1,59 @@ +module Main where + +import HGraph.Directed +import qualified HGraph.Directed.EditDistance.Acyclic.VertexDeletion as VD +import qualified HGraph.Directed.EditDistance.Acyclic.ArcDeletion as AD +import qualified HGraph.Directed.AdjacencyMap as AM + +import TestUtils +import Test.HUnit hiding (Node) +import System.Exit (exitFailure, exitSuccess) + + +tests = TestList + [ TestLabel "vertex deletion 1" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [(0,1), (0,2), (1,3), (2,3)] + assertEqual "Acyclic" + ([], 0) + (VD.minimum d) + let d' = addArc (3,0) d + (xs, k) = VD.minimum d' + assertAny "Deletion set" + [([0],1), ([3],1)] + (xs,k) + ) + , TestLabel "vertex deletion 2" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [(0,1), (1,0), (1,2), (2,1), (0,2), (2,0)] + (xs, k) = VD.minimum d + print xs + assertAny "Deletion set" + [([0,1],2), ([0,2],2), ([1,2], 2)] + (xs,k) + ) + , TestLabel "arc deletion 1" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [(0,1), (0,2), (1,3), (2,3)] + assertEqual "Acyclic" + ([], 0) + (AD.minimum d) + let d' = addArc (3,0) d + (xs, k) = AD.minimum d' + assertEqual "Deletion set" + ([(3,0)], 1) + (xs,k) + ) + , TestLabel "arc deletion 2" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [(0,1),(1,2),(4,0),(3,4),(2,0),(2,3)] + (xs, k) = AD.minimum d + assertAny "Deletion set 1" + [([(1,2)], 1), ([(0,1)], 1)] + (xs,k) + ) + ] + +main = do + count <- runTestTT tests + if errors count + failures count > 0 then exitFailure else exitSuccess diff --git a/tests/Digraph/Generator.hs b/tests/Digraph/Generator.hs new file mode 100644 --- /dev/null +++ b/tests/Digraph/Generator.hs @@ -0,0 +1,212 @@ +module Main where + +import HGraph.Directed +import HGraph.Directed.Generator.Hereditary +import HGraph.Utils +import qualified HGraph.Directed.AdjacencyMap as AM +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Maybe +import Data.List + +import Test.HUnit hiding (Node) +import System.Exit (exitFailure, exitSuccess) + +tests = TestList + [ TestLabel "One arc, two vertices" $ TestCase + ( do + ds <- do + gen <- enumerateParallel' + (\d v -> let d1 = addVertex v d + in + if v == 0 then + [d1] + else + [ addArc a d1 + | u <- vertices d + , a <- [(v,u), (u,v)] + ] + ) + [AM.emptyDigraph] + [0, 1] + let loop = do + md <- gen + case md of + Just d -> do + ds <- loop + return $ d : ds + Nothing -> return [] + loop + assertEqual "one arc" + [0, 1] + (map numArcs ds) + ) + , TestLabel "9" $ TestCase + ( do + ds <- do + gen <- enumerateParallel' + (\d v -> let d1 = addVertex v d + in + case v of + 0 -> [d1] + 1 -> + let [u] = vertices d + in + [ addArc (u,v) d1 + --, addArc (v,u) d1 + , d1 + ] + 2 -> + case arcs d of + [(u,w)] -> + [-- addArc (w, v) d1 + --, addArc (v, w) d1 + --, addArc (u, v) d1 + --, addArc (v, u) d1 + addArc (u, v) $ addArc (w, v) d1 + --, addArc (v, u) $ addArc (v, w) d1 + , addArc (v, u) $ addArc (w, v) d1 + --, addArc (v, w) $ addArc (u, v) d1 + --, addArc (v, u) $ addArc (w, v) d1 + ] + [] -> + let [u,w] = vertices d + in + [ addArc (w, v) d1 + --, addArc (v, w) d1 + --, addArc (u, v) d1 + --, addArc (v, u) d1 + , addArc (u, v) $ addArc (w, v) d1 + , addArc (v, u) $ addArc (v, w) d1 + , addArc (u, v) $ addArc (v, w) d1 + , addArc (v, u) $ addArc (w, v) d1 + , addArc (v, w) $ addArc (u, v) d1 + ] + ) + [AM.emptyDigraph] + [0, 1, 2] + let loop = do + md <- gen + case md of + Just d -> do + ds <- loop + return $ d : ds + Nothing -> return [] + loop + assertEqual "count" + 9 + (length ds) + ) + , TestLabel "oriented digraphs with at most 3 vertices" $ TestCase + ( do + ds <- do + gen <- enumerateParallel' + (\d v -> let d1 = addVertex v d + in + if v == 0 then + [d1] + else + [ foldr addArc d1 as' + | k <- [0.. numVertices d] + , neighbors <- choose k $ vertices d + , as' <- orientations $ map (\u -> (v, u)) neighbors + ] + ) + [AM.emptyDigraph] + [0, 1, 2] + let loop = do + md <- gen + case md of + Just d -> do + ds <- loop + return $ d : ds + Nothing -> return [] + loop + assertEqual "count" + 10 + (length ds) + ) + , TestLabel "max indegree and outdegree 1" $ TestCase + ( do + ds <- do + gen <- enumerateParallel' + (\d v -> let d1 = addVertex v d + possibleInneighbors = filter (\u -> outdegree d u == 0) $ vertices d + possibleOutneighbors = filter (\u -> indegree d u == 0) $ vertices d + ds' = [ foldr addArc d1 as' + | k <- [0.. length possibleInneighbors] + , neighbors <- choose k $ possibleInneighbors + , let as' = map (\u -> (u, v)) neighbors + ] + in + if v == 0 then + [d1] + else + ds' + ++ + [ addArc (v, outNeighbor) d' + | outNeighbor <- possibleOutneighbors + , d' <- ds' + ] + ) + [AM.emptyDigraph] + [0, 1, 2] + exhaust gen + assertEqual "arcs" + [0, 0, 0, 1, 1, 2, 2, 2, 2, 3, 3] + (sort $ map numArcs ds) + assertEqual "count" + 11 + (length ds) + ) + , TestLabel "empty" $ TestCase + ( do + ds <- do + gen <- enumerateParallel + (\d v -> let d1 = addVertex v d + in + if v == 0 then + [d1] + else if v == 1 then + let [u] = vertices d + in [ -- addArc (v,u) $ addArc (u,v) $ d1 + addArc (u,v) $ d1 + --, addArc (v, u) $ d1 + ] + else if v == 2 then + if numArcs d == 1 then + let [u] = filter (\u -> outdegree d u == 0) $ vertices d + [w] = filter (\u -> indegree d u == 0) $ vertices d + in [ addArc (u, v) d1 + , addArc (v, w) $ addArc (u, v) d1 + ] + else + [] + else + [] + ) + [AM.emptyDigraph :: AM.Digraph Int] + [0, 1, 2] + let loop = do + md <- gen + case md of + Just d -> do + ds <- loop + return $ d : ds + Nothing -> return [] + loop + assertEqual "count" + 4 + (length ds) + ) + ] + +orientations :: [(a,a)] -> [[(a,a)]] +orientations [] = [[]] +orientations ((v,u) : es) = + let orientations' = orientations es + in ( map ((v,u) : ) orientations') ++ ( map ((u,v) : ) orientations') + +main = do + count <- runTestTT tests + if errors count + failures count > 0 then exitFailure else exitSuccess diff --git a/tests/Digraph/Packing-Cycles.hs b/tests/Digraph/Packing-Cycles.hs new file mode 100644 --- /dev/null +++ b/tests/Digraph/Packing-Cycles.hs @@ -0,0 +1,106 @@ +module Main where + +import HGraph.Directed +import qualified HGraph.Directed.Packing.Cycles as PC +import qualified HGraph.Directed.AdjacencyMap as AM +import qualified Data.Set as S + +import TestUtils +import Test.HUnit hiding (Node) +import System.Exit (exitFailure, exitSuccess) + +cycleNormalForm vs = + let minV = minimum vs + (end, begin) = span (/= minV) vs + in begin ++ end + + +tests = TestList + [ TestLabel "cycle 1" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [(0,1)] + assertEqual "Acyclic" + ([], 0) + (PC.maximumI d) + let d' = addArc (1,0) d + (xs, k) = PC.maximumI d' + assertEqual "cycle" + ([[0,1]],1) + (map cycleNormalForm xs, k) + ) + , TestLabel "cycle 2" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [ (0,1), (1,0) + , (0,2), (2,3), (3,0) + , (1,4), (4,5), (5,1) + ] + (xs, k) = (PC.maximumI d) + assertEqual "2 cycles" + (S.fromList [[0,2,3], [1,4,5]], 2) + (S.fromList $ map cycleNormalForm xs,k) + ) + , TestLabel "cycle 3" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph + [ (0,1), (0,2) + , (1,5), (1,6) + , (2,7) + , (3,0) + , (4,5), (4,6) + , (5,0) + , (6,1), (6,2) + , (7,5), (7,6) + ] + (xs, k) = (PC.maximumI d) + assertEqual "2 cycles" + (S.fromList [[0,1,5], [2,7,6]], 2) + (S.fromList $ map cycleNormalForm xs,k) + ) + , TestLabel "arc disjoint cycle 1" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [ (0,1), (1,0) + , (0,2), (2,3), (3,0) + , (1,4), (4,5), (5,1) + ] + (xs, k) = (PC.arcMaximumI d) + assertEqual "3 cycles" + (S.fromList [[0,1], [0,2,3], [1,4,5]], 3) + (S.fromList $ map cycleNormalForm xs,k) + ) + , TestLabel "arc disjoint cycles 2" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [ (1,2) + , (2,5), (2,0) + , (3,1), (3,5) + , (5,1), (5,2) + , (0,5) + ] + (xs, k) = (PC.arcMaximumI d) + assertAny "2 cycles" + [ (S.fromList [[1,2,5], [2,0,5]], 2) + , (S.fromList [[0,5,1,2], [2,5]], 2) + ] + (S.fromList $ map cycleNormalForm xs, k) + ) + , TestLabel "arc disjoint cycles 3" $ TestCase + ( do + let d = digraphFromArcList AM.emptyDigraph [(0,2),(2,5),(2,6),(5,0),(5,2),(5,6),(6,1),(6,2)] + (xs, k) = (PC.arcMaximumI d) + assertEqual "2 cycles" + (S.fromList [[0,2,5], [2,6]], 2) + (S.fromList $ map cycleNormalForm xs, k) + ) + , TestLabel "arc disjoint cycles 4" $ TestCase + ( do + -- let d = digraphFromArcList AM.emptyDigraph [(0,1),(1,3),(1,6),(1,9),(2,0),(2,4),(3,1),(3,8),(4,6),(4,9),(5,6),(6,0),(6,3),(6,5),(7,1),(7,3),(8,1),(8,9),(9,1),(9,7)] + let d = digraphFromArcList AM.emptyDigraph [(0,1),(1,3),(1,6),(3,1),(3,4),(5,6),(6,0),(6,3),(6,5),(7,3),(4,2),(2,7)] + (xs, k) = (PC.arcMaximumI d) + assertEqual "5 cycles" + (S.fromList [[0,1,6], [1,3], [2,7,3,4], [5,6]], 4) + (S.fromList $ map cycleNormalForm xs, k) + ) + ] + +main = do + count <- runTestTT tests + if errors count + failures count > 0 then exitFailure else exitSuccess diff --git a/tests/Digraph/Subgraph.hs b/tests/Digraph/Subgraph.hs --- a/tests/Digraph/Subgraph.hs +++ b/tests/Digraph/Subgraph.hs @@ -61,6 +61,31 @@ assertBool "Subgraph Iso h2" (d `isSubgraphOf` h2) ) + , TestLabel "Enumerate subgraphs 1" $ TestCase + ( do + let d = foldr addArc (foldr addVertex AM.emptyDigraph [0,1,2,3]) [(0,1), (1,2), (2,3), (3,0)] + v1 = addVertex 0 AM.emptyDigraph + v1s = enumerateSubgraphs d v1 + assertEqual "Count v1" 4 (length v1s) + assertEqual "Vertex sets" (S.fromList $ map S.fromList [[0],[1],[2],[3]]) + (S.fromList $ map (S.fromList . vertices) v1s) + let a1 = addArc (0,1) $ foldr addVertex AM.emptyDigraph [0,1] + a1s = enumerateSubgraphs d a1 + assertEqual "Count a1" 4 (length a1s) + assertEqual "Vertex sets" (S.fromList $ map S.fromList [[0,1],[1,2],[2,3],[3,0]]) + (S.fromList $ map (S.fromList . vertices) a1s) + let p3 = foldr addArc (foldr addVertex AM.emptyDigraph [0,1,2]) [(0,1), (1,2)] + p3s = enumerateSubgraphs d p3 + assertEqual "Count p3" 4 (length p3s) + assertEqual "Arc sets" (S.fromList $ map S.fromList + [ [(0,1), (1,2)] + , [(1,2), (2,3)] + , [(2,3), (3,0)] + , [(3,0), (0,1)] + ] + ) + (S.fromList $ map (S.fromList . arcs) p3s) + ) ] arcSet p = S.fromList $ zip p $ tail p diff --git a/tests/Digraph/TestUtils.hs b/tests/Digraph/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/Digraph/TestUtils.hs @@ -0,0 +1,20 @@ +module TestUtils where + +import qualified Data.Set as S +import HGraph.Directed +import Control.Monad +import Data.List +import Test.HUnit.Base + +digraphFromArcList :: (DirectedGraph t, Mutable t, Eq a, Ord a) => t a -> [(a,a)] -> t a +digraphFromArcList d es = + let vs = S.fromList $ concat [[v,u] | (v,u) <- es] + in foldr addArc (foldr addVertex d $ S.toList vs) es + +assertAny msg expected got = + when (all (/= got) expected) $ + assertFailure (intercalate "\n" + [ msg + , "Expected one of:\n " ++ (intercalate "\n " $ map show expected) + , "but got:\n " ++ show got + ]) diff --git a/tests/Digraph/TopologicalMinor.hs b/tests/Digraph/TopologicalMinor.hs new file mode 100644 --- /dev/null +++ b/tests/Digraph/TopologicalMinor.hs @@ -0,0 +1,39 @@ +module Main where + +import HGraph.Directed +import HGraph.Directed.TopologicalMinor +import qualified HGraph.Directed.AdjacencyMap as AM +import qualified Data.Map as M +import qualified Data.Set as S + +import Test.HUnit hiding (Node) +import System.Exit (exitFailure, exitSuccess) + +tests = TestList + [ TestLabel "Minor 0" $ TestCase + ( do + let d = addVertex 1 AM.emptyDigraph + assertBool "Subgraph" + (d `isMinorOf` d) + ) + , TestLabel "Minor 1" $ TestCase + ( do + let d = foldr addArc (foldr addVertex AM.emptyDigraph [0,1]) [(0,1), (1,0)] + h1 = foldr addVertex AM.emptyDigraph [1] + h2 = addArc (0,1) (foldr addVertex AM.emptyDigraph [0,1]) + assertBool "Minor h1" + (h1 `isMinorOf` d) + assertBool "Minor embedding h2" + (isMinorEmbedding h2 d $ M.fromList [(0,0), (1,1)]) + assertBool "Minor h2" + (h2 `isMinorOf` d) + assertBool "Minor d" + (d `isMinorOf` d) + ) + ] + +arcSet p = S.fromList $ zip p $ tail p + +main = do + count <- runTestTT tests + if errors count + failures count > 0 then exitFailure else exitSuccess diff --git a/tests/Graph/AdjacencyMap.hs b/tests/Graph/AdjacencyMap.hs --- a/tests/Graph/AdjacencyMap.hs +++ b/tests/Graph/AdjacencyMap.hs @@ -10,18 +10,18 @@ tests = TestList [ TestLabel "No edges 1" $ TestCase ( do - let g = addVertex emptyGraph 1 + let g = addVertex 1 emptyGraph assertEqual "0" 0 (degree g 1) assertEqual "[1]" [[1]] (connectedComponents g) ) , TestLabel "No edges 2" $ TestCase ( do - let g = foldr (flip addVertex) emptyGraph [1,2,3,4,5,6] + let g = foldr addVertex emptyGraph [1,2,3,4,5,6] assertEqual "1 2 3 4 5 6" [[1], [2], [3], [4], [5], [6]] (connectedComponents g) ) , TestLabel "Path 1" $ TestCase ( do - let g = addEdge (foldr (flip addVertex) emptyGraph [1,2]) (1,2) + let g = addEdge (1,2) (foldr addVertex emptyGraph [1,2]) assertEqual "deg(1) = 1" 1 (degree g 1) assertEqual "" [[1,2]] (map sort $ connectedComponents g) assertEqual "" [1,2] (sort $ metaBfs g 1 id) diff --git a/tests/Graph/TestVertexCover.hs b/tests/Graph/TestVertexCover.hs --- a/tests/Graph/TestVertexCover.hs +++ b/tests/Graph/TestVertexCover.hs @@ -6,32 +6,32 @@ import Test.HUnit hiding (Node) import System.Exit (exitFailure, exitSuccess) -isVc g vc = numEdges (foldr (flip removeVertex) g vc) == 0 +isVc g vc = numEdges (foldr removeVertex g vc) == 0 tests = TestList [ TestLabel "No edges 1" $ TestCase ( do - let g = addVertex emptyGraph 1 + let g = addVertex 1 emptyGraph vc = minimumVertexCover g assertEqual "Empty VC" [] vc ) , TestLabel "No edges 2" $ TestCase ( do - let g = foldr (flip addVertex) emptyGraph [1,2,3,4,5,6] + let g = foldr addVertex emptyGraph [1,2,3,4,5,6] vc = minimumVertexCover g assertEqual "Empty VC" [] vc ) , TestLabel "VC 1" $ TestCase ( do - let g = addEdge (foldr (flip addVertex) emptyGraph [1,2]) (1,2) + let g = addEdge (1,2) (foldr addVertex emptyGraph [1,2]) vc = minimumVertexCover g assertEqual "VC = 1" 1 (length vc) assertBool "Is VC" $ isVc g vc ) , TestLabel "VC 2" $ TestCase ( do - let g = foldr (flip addEdge) - (foldr (flip addVertex) emptyGraph [1,2,3,4]) + let g = foldr addEdge + (foldr addVertex emptyGraph [1,2,3,4]) [(1,2), (1,3), (1,4)] vc = minimumVertexCover g assertEqual "VC = 1" 1 (length vc) @@ -39,8 +39,8 @@ ) , TestLabel "VC 3" $ TestCase ( do - let g = foldr (flip addEdge) - (foldr (flip addVertex) emptyGraph [1,2,3,4]) + let g = foldr addEdge + (foldr addVertex emptyGraph [1,2,3,4]) [(1,2), (1,3), (1,4), (2,3)] vc = minimumVertexCover g assertEqual "|VC|" 2 (length vc) @@ -48,8 +48,8 @@ ) , TestLabel "VC 4" $ TestCase ( do - let g = foldr (flip addEdge) - (foldr (flip addVertex) emptyGraph [1,2,3,4,5,6]) + let g = foldr addEdge + (foldr addVertex emptyGraph [1,2,3,4,5,6]) ((1,6):(zip [1..5] [2..6])) vc = minimumVertexCover g assertEqual "|VC|" 3 (length vc) @@ -57,8 +57,8 @@ ) , TestLabel "VC grid" $ TestCase ( do - let g = foldr (flip addEdge) - (foldr (flip addVertex) emptyGraph [ (x,y) | x <- [1..4], y <- [1..4]]) + let g = foldr addEdge + (foldr addVertex emptyGraph [ (x,y) | x <- [1..4], y <- [1..4]]) ([((4,y), (4,y+1)) | y <- [1..3]] ++ [((x,4), (x+1,4)) | x <- [1..3]] ++ concat [[ ((x,y), (x+1,y)) diff --git a/tests/Graph/Treedepth.hs b/tests/Graph/Treedepth.hs --- a/tests/Graph/Treedepth.hs +++ b/tests/Graph/Treedepth.hs @@ -11,7 +11,7 @@ tests = TestList [ TestLabel "No edges 1" $ TestCase ( do - let g = addVertex emptyGraph 1 + let g = addVertex 1 emptyGraph td = optimalDecomposition g assertEqual "TD" Decomposition{ ancestor = M.empty @@ -23,7 +23,7 @@ ) , TestLabel "No edges 2" $ TestCase ( do - let g = foldr (flip addVertex) emptyGraph [1,2,3,4,5,6] + let g = foldr addVertex emptyGraph [1,2,3,4,5,6] td = optimalDecomposition g assertEqual "TD" Decomposition{ ancestor = M.empty @@ -35,21 +35,21 @@ ) , TestLabel "Path 1" $ TestCase ( do - let g = addEdge (foldr (flip addVertex) emptyGraph [1,2]) (1,2) + let g = addEdge (1,2) (foldr addVertex emptyGraph [1,2]) td = optimalDecomposition g assertEqual (show td) 2 (depth td) assertBool (show td) $ isDecomposition g td ) , TestLabel "Path 2" $ TestCase ( do - let g = foldr (flip addEdge) (foldr (flip addVertex) emptyGraph [1,2,3,4,5,6]) [(1,2), (2,3), (3,4), (4,5), (5,6)] + let g = foldr addEdge (foldr addVertex emptyGraph [1,2,3,4,5,6]) [(1,2), (2,3), (3,4), (4,5), (5,6)] td = optimalDecomposition g assertEqual (show td) 3 (depth td) assertBool (show td) $ isDecomposition g td ) , TestLabel "Cycle 1" $ TestCase ( do - let g = foldr (flip addEdge) (foldr (flip addVertex) emptyGraph [1,2,3,4,5,6]) [(1,2), (2,3), (3,4), (4,5), (5,6), (6,1)] + let g = foldr addEdge (foldr addVertex emptyGraph [1,2,3,4,5,6]) [(1,2), (2,3), (3,4), (4,5), (5,6), (6,1)] td = optimalDecomposition g assertEqual (show td) 4 (depth td) assertBool (show td) $ isDecomposition g td