diff --git a/math-grads.cabal b/math-grads.cabal --- a/math-grads.cabal +++ b/math-grads.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: math-grads -version: 0.1.6.4 +version: 0.1.6.7 license: BSD3 license-file: LICENSE copyright: 2017 Alexandr Sadovnikov @@ -60,17 +60,17 @@ default-language: Haskell2010 build-depends: base >=4.7 && <5, - aeson >=1.4.2.0 && <1.5, - array >=0.5.3.0 && <0.6, - bimap >=0.3.3 && <0.4, - containers >=0.6.0.1 && <0.7, - lens ==4.17.*, - linear >=1.20.8 && <1.21, + aeson >=1.4.7.0 && <1.5, + array >=0.5.4.0 && <0.6, + bimap >=0.4.0 && <0.5, + containers >=0.6.2.1 && <0.7, + lens >=4.18.1 && <4.19, + linear >=1.20.9 && <1.21, matrix >=0.3.6.1 && <0.4, mtl >=2.2.2 && <2.3, - ilist >=0.3.1.0 && <0.4, + ilist >=0.4.0.0 && <0.5, random ==1.1.*, - vector >=0.12.0.2 && <0.13 + vector >=0.12.1.2 && <0.13 test-suite Coords-test type: exitcode-stdio-1.0 @@ -79,9 +79,9 @@ default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.12.0.0 && <4.13, - containers >=0.6.0.1 && <0.7, - hspec >=2.6.1 && <2.7, + base >=4.13.0.0 && <4.14, + containers >=0.6.2.1 && <0.7, + hspec >=2.7.1 && <2.8, math-grads -any, random ==1.1.* @@ -92,9 +92,9 @@ default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.12.0.0 && <4.13, - containers >=0.6.0.1 && <0.7, - hspec >=2.6.1 && <2.7, + base >=4.13.0.0 && <4.14, + containers >=0.6.2.1 && <0.7, + hspec >=2.7.1 && <2.8, math-grads -any test-suite Isomorphism-test @@ -104,10 +104,10 @@ default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.12.0.0 && <4.13, - array >=0.5.3.0 && <0.6, - containers >=0.6.0.1 && <0.7, - hspec >=2.6.1 && <2.7, + base >=4.13.0.0 && <4.14, + array >=0.5.4.0 && <0.6, + containers >=0.6.2.1 && <0.7, + hspec >=2.7.1 && <2.8, math-grads -any test-suite SSSR-test @@ -117,8 +117,8 @@ default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.12.0.0 && <4.13, - array >=0.5.3.0 && <0.6, - containers >=0.6.0.1 && <0.7, - hspec >=2.6.1 && <2.7, + base >=4.13.0.0 && <4.14, + array >=0.5.4.0 && <0.6, + containers >=0.6.2.1 && <0.7, + hspec >=2.7.1 && <2.8, math-grads -any diff --git a/src/Math/Grads/Algo/SSSR.hs b/src/Math/Grads/Algo/SSSR.hs --- a/src/Math/Grads/Algo/SSSR.hs +++ b/src/Math/Grads/Algo/SSSR.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Math.Grads.Algo.SSSR ( findSSSR ) where -import Prelude hiding (map) - import Control.Arrow ((***)) -import Control.Lens (over, _1, _2) -import Data.Bimap ((!>)) +import Control.Lens (over, to, toListOf, (%~), (&), _1, _2) +import Data.Bimap (Bimap, (!>)) import Data.List (intersect, nub, sort) import Data.List.Index (ifoldl) import Data.Map.Strict (Map) @@ -19,42 +18,62 @@ import qualified Data.Set as S import Math.Grads.Algo.Cycles (getCyclic) -import Math.Grads.Algo.Traversals (getComps) +import Math.Grads.Algo.Traversals (getCompsWithReindex) import Math.Grads.GenericGraph (GenericGraph, subgraphWithReindex) import Math.Grads.Graph (EdgeList, toList) + -- | RP-Path algorithm for searching the smallest set of smallest rings. -- -findSSSR :: Ord v => Ord e => GenericGraph v e -> [EdgeList e] +-- | Find SSSR of any graph. +-- +findSSSR :: (Ord v, Ord e) => GenericGraph v e -> [EdgeList e] findSSSR graph = sssr where (reindex, cyclicGraph) = subgraphWithReindex graph . S.toList $ getCyclic graph - g@(_, edges) = toList cyclicGraph - (n, m) = (length *** length) g - maxSSSRs = m - n + length (getComps cyclicGraph) + sssr = reindexCycles reindex $ findCyclicSSSR cyclicGraph +-- | Find SSSR of cyclic graph, i.e. each graphs edge belongs at least 1 cycle. +-- +findCyclicSSSR :: forall v e. (Ord v, Ord e) => GenericGraph v e -> [EdgeList e] +findCyclicSSSR cyclicGraph = sssr + where + reindex2compList :: [(Bimap Int Int, GenericGraph v e)] + reindex2compList = getCompsWithReindex cyclicGraph + + sssr = reindex2compList & traverse %~ over _2 findFusedSSSR + & traverse %~ uncurry reindexCycles + & concat + +-- | Find SSSR of fused graph, i.e. graph is cyclic and connected. +-- +findFusedSSSR :: (Ord v, Ord e) => GenericGraph v e -> [EdgeList e] +findFusedSSSR fusedGraph = sssr + where + g@(_, edges) = toList fusedGraph + (n, m) = (length *** length) g + maxSSSRs = m - n + 1 + edgeIndex :: Map (Int, Int) Int edgeIndex = ifoldl insertEdge M.empty edges where - insertEdge map ix (x, y, _) = M.insert (y, x) ix $ M.insert (x, y) ix map + insertEdge edgeMap ind (x, y, _) = M.insert (y, x) ind $ M.insert (x, y) ind edgeMap (pid, pid') = calculatePidMatrices n m edgeIndex sssrEdges = takeSSSR n maxSSSRs pid pid' - sssr = fmap (backToOriginIndex . (edges !!)) <$> sssrEdges - where - backToOriginIndex = over _1 (reindex !>) . over _2 (reindex !>) + sssr = fmap (edges !!) <$> sssrEdges takeSSSR :: Int -> Int -> Matrix (Int, [[Int]]) -> Matrix [[Int]] -> [[Int]] -takeSSSR n maxSSSRs pid pid' = takeSSSR' [] [] 3 (1, 1) +takeSSSR n maxSSSRs pid pid' = go [] [] 3 (1, 1) where - takeSSSR' cycles edges len (i, j) + go cycles edges len (i, j) | (i, j) > (n, n) || length cycles >= maxSSSRs = cycles | curLen /= len || length ij < 1 || length ij == 1 && null ij' = - takeSSSR' cycles edges nextLen nextInd + go cycles edges nextLen nextInd | otherwise = - takeSSSR' nextCycles nextEdges nextLen nextInd + go nextCycles nextEdges nextLen nextInd where (ijDist, ij) = unsafeGet i j pid ij' = unsafeGet i j pid' @@ -68,9 +87,8 @@ cartesianProduct ij (if even len then ij else ij') notIntersects concatSort where notIntersects a b = null $ intersect a b - concatSort a b = sort $ a ++ b - - notContains a b = length (a `intersect` b) < length b - 1 + concatSort a b = sort $ a ++ b + notContains a b = length (a `intersect` b) < length b - 1 nextCycles = cycles ++ newCycles nextEdges = nub $ edges ++ concat newCycles @@ -118,9 +136,15 @@ | otherwise = pid' nextInd - | (i, j) == (n, n) = (k + 1, 1, 1) - | j == n = (k, i + 1, i + 1) - | otherwise = (k, i,j + 1) + | (i, j) == (n, n) = (k + 1, 1, 1 ) + | j == n = (k, i + 1, 1 ) + | otherwise = (k, i, j + 1) + +reindexCycles :: Bimap Int Int -> [EdgeList e] -> [EdgeList e] +reindexCycles reindex = fmap reindexCycle + where + reindexCycle :: EdgeList e -> EdgeList e + reindexCycle = toListOf $ traverse . to (over _1 (reindex !>) . over _2 (reindex !>)) cartesianProduct :: Eq a => [a] -> [a] -> (a -> a -> Bool) -> (a -> a -> b) -> [b] cartesianProduct xs ys f g = [ g x y | x <- xs, y <- ys, f x y ] diff --git a/src/Math/Grads/Algo/Traversals.hs b/src/Math/Grads/Algo/Traversals.hs --- a/src/Math/Grads/Algo/Traversals.hs +++ b/src/Math/Grads/Algo/Traversals.hs @@ -6,6 +6,7 @@ , dfsCycle , dfs , getComps + , getCompsWithReindex , getCompsIndices ) where @@ -13,13 +14,15 @@ import Control.Monad.State (State, execState) import Control.Monad.State.Class (get, put) import qualified Data.Array as A +import Data.Bimap (Bimap) import Data.List (findIndex) import Data.Map (Map, keys, (!)) import Data.Maybe (fromJust) import Math.Grads.Algo.Interaction (edgeListToMap, getIndices, getOtherEnd, matchEdges, (~=)) -import Math.Grads.GenericGraph (GenericGraph, gIndex, subgraph) +import Math.Grads.GenericGraph (GenericGraph, gIndex, + subgraphWithReindex) import Math.Grads.Graph (EdgeList, Graph (..)) import Math.Grads.Utils (nub) @@ -45,11 +48,17 @@ -- Note that indexation will be CHANGED. -- getComps :: Ord v => GenericGraph v e -> [GenericGraph v e] -getComps graph = res +getComps graph = snd <$> getCompsWithReindex graph + +-- | Get graph components and mapping from old indices to +-- new indices of resulting graph components. +-- +getCompsWithReindex :: Ord v => GenericGraph v e -> [(Bimap Int Int, GenericGraph v e)] +getCompsWithReindex graph = res where (_, edges) = toList graph comps = getComps' edges [0..length (gIndex graph) - 1] [] [] - res = fmap (subgraph graph) comps + res = fmap (subgraphWithReindex graph) comps -- | Get indices of vertices that belong to different connected components. --