math-grads 0.1.6.4 → 0.1.6.7
raw patch · 3 files changed
+84/−51 lines, 3 filesdep ~aesondep ~arraydep ~base
Dependency ranges changed: aeson, array, base, bimap, containers, hspec, ilist, lens, linear, vector
Files
- math-grads.cabal +23/−23
- src/Math/Grads/Algo/SSSR.hs +49/−25
- src/Math/Grads/Algo/Traversals.hs +12/−3
math-grads.cabal view
@@ -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
src/Math/Grads/Algo/SSSR.hs view
@@ -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. -- <https://www.ncbi.nlm.nih.gov/pubmed/19805142> -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 ]
src/Math/Grads/Algo/Traversals.hs view
@@ -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. --