hgraph 1.2.0.1 → 1.10.0.0

raw patch · 42 files changed

+2325/−233 lines, 42 filesdep +saydep ~arraydep ~containersdep ~happy-dotPVP ok

version bump matches the API change (PVP)

Dependencies added: say

Dependency ranges changed: array, containers, happy-dot, linear, mtl, random, transformers

API changes (from Hackage documentation)

Files

• benchmarks/ArcDeletionAcyclic.hs +49/−0
• benchmarks/PackingCycles.hs +53/−0
• hgraph.cabal +89/−8
• src/HGraph/Debugging.hs +17/−0
• src/HGraph/Directed.hs +121/−0
• src/HGraph/Directed/Connectivity.hs +3/−128
• src/HGraph/Directed/Connectivity/Basic.hs +101/−0
• src/HGraph/Directed/Connectivity/Flow.hs +117/−24
• src/HGraph/Directed/Connectivity/IntegralLinkage.hs +29/−15
• src/HGraph/Directed/Connectivity/OneWayWellLinkedness.hs +9/−0
• src/HGraph/Directed/Connectivity/OneWayWellLinkedness/Internal.hs +136/−0
• src/HGraph/Directed/EditDistance/Acyclic/ArcDeletion.hs +9/−0
• src/HGraph/Directed/EditDistance/Acyclic/ArcDeletion/Internal.hs +154/−0
• src/HGraph/Directed/EditDistance/Acyclic/VertexDeletion.hs +9/−0
• src/HGraph/Directed/EditDistance/Acyclic/VertexDeletion/Internal.hs +64/−0
• src/HGraph/Directed/Generator.hs +100/−0
• src/HGraph/Directed/Generator/Hereditary.hs +9/−0
• src/HGraph/Directed/Generator/Hereditary/Internal.hs +108/−0
• src/HGraph/Directed/Packing/Cycles.hs +9/−0
• src/HGraph/Directed/Packing/Cycles/Internal.hs +122/−0
• src/HGraph/Directed/Subgraph.hs +55/−0
• src/HGraph/Directed/TopologicalMinor.hs +41/−0
• src/HGraph/Parallel.hs +137/−0
• src/HGraph/Undirected.hs +4/−4
• src/HGraph/Undirected/AdjacencyMap.hs +5/−5
• src/HGraph/Undirected/Generator.hs +25/−18
• src/HGraph/Undirected/Load.hs +2/−2
• src/HGraph/Undirected/Solvers/IndependentSet.hs +3/−3
• src/HGraph/Undirected/Solvers/Treedepth.hs +1/−1
• src/HGraph/Undirected/Solvers/VertexCover.hs +5/−5
• src/HGraph/Utils.hs +22/−0
• tests/Digraph/AdjacencyMap.hs +32/−0
• tests/Digraph/Connectivity.hs +204/−0
• tests/Digraph/EditDistance-Acyclic.hs +59/−0
• tests/Digraph/Generator.hs +212/−0
• tests/Digraph/Packing-Cycles.hs +106/−0
• tests/Digraph/Subgraph.hs +25/−0
• tests/Digraph/TestUtils.hs +20/−0
• tests/Digraph/TopologicalMinor.hs +39/−0
• tests/Graph/AdjacencyMap.hs +3/−3
• tests/Graph/TestVertexCover.hs +12/−12
• tests/Graph/Treedepth.hs +5/−5

@@ -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 ()

@@ -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

@@ -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

@@ -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+  ]

@@ -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+    ]+  )

@@ -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

@@ -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'

@@ -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+        ]+  

@@ -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                    

@@ -0,0 +1,9 @@+module HGraph.Directed.Connectivity.OneWayWellLinkedness+       ( edgeWellLinkedPair+       , edgeWellLinkedPair'+       , vertexWellLinkedPair+       , Guess(..)+       )+where++import HGraph.Directed.Connectivity.OneWayWellLinkedness.Internal

@@ -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)+      }+

@@ -0,0 +1,9 @@+module HGraph.Directed.EditDistance.Acyclic.ArcDeletion+       ( minimum+       , minimumI+       )+where++import Prelude hiding (minimum)++import HGraph.Directed.EditDistance.Acyclic.ArcDeletion.Internal

@@ -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'+    +    

@@ -0,0 +1,9 @@+module HGraph.Directed.EditDistance.Acyclic.VertexDeletion+       ( minimum+       , minimumI+       )+where++import Prelude hiding (minimum)++import HGraph.Directed.EditDistance.Acyclic.VertexDeletion.Internal

@@ -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'+    +    

@@ -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

@@ -0,0 +1,9 @@+module HGraph.Directed.Generator.Hereditary+       ( enumerateParallel+       , enumerateParallel'+       , random+       , exhaust+       )+where++import HGraph.Directed.Generator.Hereditary.Internal

@@ -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+  }+

@@ -0,0 +1,9 @@+module HGraph.Directed.Packing.Cycles+        ( arcMaximumI+        , maximum+        , maximumI+        )+where++import Prelude hiding (maximum)+import HGraph.Directed.Packing.Cycles.Internal

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)) $

@@ -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

@@ -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)

@@ -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

@@ -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)     )   ] 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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+      ])

@@ -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

@@ -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)

@@ -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))

@@ -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