├── Setup.hs ├── .gitignore ├── stack.yaml ├── src └── Math │ └── Grads │ ├── Angem.hs │ ├── Utils.hs │ ├── Algo │ ├── Isomorphism │ │ ├── Types.hs │ │ ├── RI.hs │ │ └── Ullman.hs │ ├── Isomorphism.hs │ ├── Traversals.hs │ ├── Interaction.hs │ ├── Paths.hs │ ├── SSSR.hs │ └── Cycles.hs │ ├── Graph.hs │ ├── Angem │ └── Internal │ │ ├── MatrixOperations.hs │ │ └── VectorOperations.hs │ ├── Drawing │ ├── Internal │ │ ├── Coords.hs │ │ ├── Utils.hs │ │ ├── Sampling.hs │ │ ├── CyclesPathsAlignment.hs │ │ ├── Cycles.hs │ │ └── Paths.hs │ └── Coords.hs │ └── GenericGraph.hs ├── .travis.yml ├── LICENSE ├── CHANGELOG.md ├── test ├── Graph.hs ├── Coords.hs ├── SSSR.hs └── Isomorphism.hs ├── math-grads.cabal ├── README.md └── data ├── GraphsGHC9.txt └── Graphs.txt /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | 3 | .DS_Store 4 | \#*\# 5 | .\#* 6 | 7 | *.iml 8 | out/ 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.5 2 | 3 | packages: 4 | - '.' 5 | 6 | ignore-revision-mismatch: true 7 | 8 | extra-deps: [] 9 | -------------------------------------------------------------------------------- /src/Math/Grads/Angem.hs: -------------------------------------------------------------------------------- 1 | -- | Module providing miscellaneous functions for working with 2 | -- coordinates, vectors and matrices. 3 | -- 4 | module Math.Grads.Angem 5 | ( alignmentFunc 6 | , areIntersected 7 | , eqV2 8 | , rotation2D 9 | , reflectPoint 10 | ) where 11 | 12 | import Math.Grads.Angem.Internal.MatrixOperations (alignmentFunc, 13 | rotation2D) 14 | import Math.Grads.Angem.Internal.VectorOperations (areIntersected, 15 | eqV2, reflectPoint) 16 | -------------------------------------------------------------------------------- /src/Math/Grads/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | Different utility functions for usage in Math.Grads. 2 | -- 3 | module Math.Grads.Utils 4 | ( nub 5 | , subsets 6 | , uniter 7 | ) where 8 | 9 | import Data.List (group, sort) 10 | 11 | -- | nub that works in O(n log n) time. 12 | -- 13 | nub :: (Ord a, Eq a) => [a] -> [a] 14 | nub = fmap head . group . sort 15 | 16 | -- | Zips list with its tail. 17 | -- 18 | uniter :: [a] -> [(a, a)] 19 | uniter [] = [] 20 | uniter l = zip l $ drop 1 l 21 | 22 | -- | Returns all possible subsets of given list as list of lists. 23 | -- 24 | subsets :: [a] -> [[a]] 25 | subsets [] = [[]] 26 | subsets (x : xs) = subsets xs ++ ((x :) <$> subsets xs) 27 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/Isomorphism/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | module Math.Grads.Algo.Isomorphism.Types 3 | ( VertexIndex 4 | , VComparator 5 | , EComparator 6 | , GComparable(..) 7 | ) where 8 | 9 | import Math.Grads.Graph (Graph, GraphEdge) 10 | 11 | 12 | -- | Type alias for 'Int'. 13 | -- 14 | type VertexIndex = Int 15 | 16 | -- | Function that checks whether two vertices are identical. 17 | -- Due to properties related to index of vertex, 18 | -- like number of neighbors, we consider vertex indices instead of vertices. 19 | -- 20 | type VComparator v1 v2 = VertexIndex -> VertexIndex -> Bool 21 | 22 | -- | Function that checks whether two edges are identical. 23 | -- Due to properties related to index of vertex, 24 | -- like belonging to a cycle, we consider GraphEdge (Int, Int, e) instead of e. 25 | -- 26 | type EComparator e1 e2 = GraphEdge e1 -> GraphEdge e2 -> Bool 27 | 28 | -- | Type class for graphs that could be checked for isomorphism. 29 | -- 30 | class (Graph g1, Graph g2) => GComparable g1 v1 e1 g2 v2 e2 where 31 | vComparator :: g1 v1 e1 -> g2 v2 e2 -> VComparator v1 v2 32 | eComparator :: g1 v1 e1 -> g2 v2 e2 -> EComparator e1 e2 33 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: generic 3 | 4 | env: 5 | global: 6 | # HACKAGE_PASSWORD 7 | - secure: "bVtV8gJZ+s08cF7ONOUZ2ZDNfaDNCYVWTmuKthaKjBZOqSZM8SFtZFaczcvd25uGKmVg4z6V7EAoNmEGdLka/9ouySndXMlCECOn+WEX2v4YHWL7KiIxncKIpFeOGUygFqI2veDbxrQFR4YY+pGXlSuqQdfYgQq/OFpt9PzwXPS8malfOBVEtKJ9Su9vmANWUywGQbfb6/YcfHLFiLJdya9rcWDZsz+jJHr8BVY9w6pAhYPwQnovP1FUClPLHKAGVwshtkb/kFiI/zq9kAK5w57AAD/EIWLcBChcu93m5/1ROhSMosCGWl2Hq5CrNK81hRS8kTrMQG5UMRlkutdbaCNW+77Xz4avo8GOVCys7tNSr59pcXTsFEVH5VYKiWQFRoIjCJ52nkXClD3RTCNmp8u/yeogzjPtVZGJaMMNKEq2UFikWCFp/qQUAaxmuX/NIwECRGonN69TQvy59OI0v8D+/dt7kFYRO2k4wR3rcQ8P/MFWxmTH2d/UagBfbH10bSsiV/PY1WGf5AI7/s0VWYW8roa4fM+oXhEPcrPwFl2QAEWLXEnx4MbARIw9LdG2Flhvi6L68HlLzSrNF+69xMu6Pcc4voyRdpNiuiIlorloyEvkWSOFt5MHmlhiUL6LNqsrrER3sUxln0QKt1BSWRBNSBkghcBZ0RkfrqjfI9g=" 8 | 9 | # Caching so the next build will be fast too. 10 | cache: 11 | directories: 12 | - $HOME/.stack 13 | 14 | before_install: 15 | - curl -sSL https://get.haskellstack.org/ | sh 16 | - stack --version 17 | 18 | install: 19 | - stack build --test --bench --only-dependencies 20 | 21 | jobs: 22 | include: 23 | - stage: Build and test 24 | script: stack build --pedantic --test --bench --no-run-benchmarks 25 | - stage: Hackage deploy 26 | # n is for "store credentials" question 27 | script: echo -e "AlexKane\n${HACKAGE_PASSWORD}\nn" | stack upload --pvp-bounds both . 28 | if: tag IS present 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Alexandr Sadovnikov (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 5 | and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). 6 | 7 | ## [Unreleased] 8 | 9 | ## [0.1.6.8] - 2023-02-03 10 | ### Fixed 11 | - Fixes for GHC 9.2.5. 12 | 13 | ## [0.1.6.7] - 2020-03-31 14 | ### Fixed 15 | - Compilation with `--pedantic`. 16 | 17 | ## [0.1.6.6] - 2020-01-15 18 | ### Fixed 19 | - Calculate full PID and PID' matrices instead of half matrices. 20 | 21 | ## [0.1.6.5] - 2020-01-15 22 | ### Fixed 23 | - Find SSSR for each fused cycle system separately 24 | 25 | ## [0.1.6.4] - 2020-01-10 26 | ### Fixed 27 | - SSSR for multi fused cycles 28 | 29 | ## [0.1.6.3] - 2019-12-04 30 | ### Added 31 | - `Semigroup`/`Monoid` instances for `GenericGraph` 32 | 33 | ## [0.1.6.2] - 2019-11-13 34 | ### Fixed 35 | - Origin indexation for `SSSR` 36 | 37 | ## [0.1.6.1] - 2019-11-11 38 | ### Added 39 | - `subgraphWithReindex` function 40 | 41 | ## [0.1.5.2] - 2019-08-09 42 | ### Added 43 | - Export `findSimpleCycles` function 44 | 45 | ## [0.1.4.4] - 2018-12-17 46 | ### Changed 47 | - isConnected, getCompsIndices 48 | 49 | ## [0.1.4.3] - 2018-11-20 50 | ### Changed 51 | - duplicate vertices in BFS fix 52 | 53 | ## [0.1.4.2] - 2018-11-14 54 | ### Changed 55 | - isIso now checks for equal number of bonds 56 | 57 | ## [0.1.4.1] - 2018-10-31 58 | ### Added 59 | - To/From JSON instances 60 | 61 | ## [0.1.4.0] - 2018-09-27 62 | 63 | ### Changed 64 | - EComparator type. From `e1 -> e2 -> Bool` to `GraphEdge e1 -> GraphEdge e2 -> Bool` 65 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/Isomorphism.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Module that provides functions for identifying graph/subgraph isomorphism. 6 | -- 7 | module Math.Grads.Algo.Isomorphism 8 | ( EComparator, VComparator 9 | , GComparable(..) 10 | , VertexIndex 11 | , getIso 12 | , getMultiIso 13 | , isIso 14 | , isIsoSub 15 | ) where 16 | 17 | import Data.Map (Map) 18 | import Data.Maybe (isJust, listToMaybe) 19 | 20 | import qualified Math.Grads.Algo.Isomorphism.RI as RI 21 | import Math.Grads.Algo.Isomorphism.Types (EComparator, 22 | GComparable (..), 23 | VComparator, VertexIndex) 24 | import Math.Grads.GenericGraph (GenericGraph (..)) 25 | import Math.Grads.Graph (toList) 26 | 27 | 28 | -- | Checks whether two graphs are isomorphic. 29 | -- 30 | isIso :: (Ord v1, Ord v2, GComparable GenericGraph v1 e1 GenericGraph v2 e2, Eq e1, Eq e2) 31 | => GenericGraph v1 e1 32 | -> GenericGraph v2 e2 33 | -> Bool 34 | isIso queryGraph targetGraph = res 35 | where 36 | (v1, e1) = toList queryGraph 37 | (v2, e2) = toList targetGraph 38 | isoSub = isIsoSub queryGraph targetGraph 39 | 40 | res = length v1 == length v2 && length e1 == length e2 && isoSub 41 | 42 | -- | Check for queryGraph \( \subseteq \) targetGraph. 43 | -- 44 | isIsoSub :: (Ord v1, Ord v2, GComparable GenericGraph v1 e1 GenericGraph v2 e2, Eq e1, Eq e2) 45 | => GenericGraph v1 e1 -- ^ queryGraph 46 | -> GenericGraph v2 e2 -- ^ targetGraph 47 | -> Bool 48 | isIsoSub queryGraph targetGraph = isJust $ getIso queryGraph targetGraph 49 | 50 | -- | Get one vertices matching (if exists) from queryGraph to targetGraph. 51 | -- 52 | getIso :: (Ord v1, Ord v2, GComparable GenericGraph v1 e1 GenericGraph v2 e2, Eq e1, Eq e2) 53 | => GenericGraph v1 e1 -- ^ queryGraph 54 | -> GenericGraph v2 e2 -- ^ targetGraph 55 | -> Maybe (Map Int Int) 56 | getIso queryGraph targetGraph = listToMaybe $ getMultiIso queryGraph targetGraph 57 | 58 | -- | Get all possible vertices matchings from queryGraph to targetGraph. 59 | -- 60 | getMultiIso :: (Ord v1, Ord v2, GComparable GenericGraph v1 e1 GenericGraph v2 e2, Eq e1, Eq e2) 61 | => GenericGraph v1 e1 -- ^ queryGraph 62 | -> GenericGraph v2 e2 -- ^ targetGraph 63 | -> [Map Int Int] 64 | getMultiIso = RI.getMultiIso 65 | -------------------------------------------------------------------------------- /test/Graph.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List (sort) 4 | import Math.Grads.GenericGraph (GenericGraph, removeEdges, 5 | removeVertices, subgraph) 6 | import Math.Grads.Graph (fromList, incident, safeIncident, 7 | (!.), (!>), (?>)) 8 | import Test.Hspec 9 | 10 | main :: IO () 11 | main = hspec $ do 12 | opTests 13 | subgraphTests 14 | removalTests 15 | 16 | vertices :: [Int] 17 | vertices = [0, 1, 2, 5, 7, 8, 9, 10, 11, 19, 31, 78, 79, 85, 99, 60, 53, 100, 42] 18 | 19 | edges :: [(Int, Int, Int)] 20 | edges = [(0, 1, 1), (1, 2, 3), (1, 1, 2), (0, 2, 4), (3, 4, 2), (3, 5, 1), 21 | (5, 6, 2), (5, 7, 5), (7, 8, 3), (0, 9, 7), (0, 10, 2), (10, 11, 2), 22 | (10, 13, 565), (13, 14, 546), (15, 14, 42), (15, 16, -4), (16, 17, 0), 23 | (18, 16, 1), (16, 12, 0), (12, 10, 1)] 24 | 25 | graph :: GenericGraph Int Int 26 | graph = fromList (vertices, edges) 27 | 28 | opTests :: Spec 29 | opTests = describe "Operations on graphs." $ do 30 | it "Adjacent to 0." $ sort (graph !> 0) `shouldBe` [(1, 1), (2, 4), (19, 7), (31, 2)] 31 | it "Adjacent to 1." $ sort <$> (graph ?> 1) `shouldBe` Just [(0, 1), (1, 2), (2, 3)] 32 | it "Adjacent to 5." $ sort (graph !> 5) `shouldBe` [(7, 2), (8, 1)] 33 | it "Adjacent to 14." $ (graph ?> 14) `shouldBe` Nothing 34 | it "Edges incident to 8." $ sort (graph `incident` 8) `shouldBe` [(8, 5, 1), (8, 9, 2), (8, 10, 5)] 35 | it "Edges incident to 53." $ sort <$> (graph `safeIncident` 53) `shouldBe` Just [(53, 42, 1), (53, 60, -4), (53, 79, 0), (53, 100, 0)] 36 | 37 | subgraphTests :: Spec 38 | subgraphTests = describe "Subgraph tests." $ do 39 | let subg = graph `subgraph` [0, 3, 5, 7, 8, 11, 14] 40 | it "Adjacent to 0." $ subg !> 0 `shouldBe` [] 41 | it "Adjacent to 3." $ subg !. 1 `shouldBe` [(2, 1)] 42 | it "Adjacent to 8." $ sort (subg !. 2) `shouldBe` [(1, 1), (3, 5)] 43 | 44 | removalTests :: Spec 45 | removalTests = describe "Remove operations tests." $ do 46 | let g1 = graph `removeEdges` [(5, 6), (15, 14), (0, 10), (10, 12)] 47 | let g2 = graph `removeVertices` [1, 3, 5, 7, 10, 15] 48 | it "Adjacent to 0." $ sort (g1 !> 0) `shouldBe` [(1, 1), (2, 4), (19, 7)] 49 | it "Adjacent to 31." $ sort (g1 !> 31) `shouldBe` [(78, 2), (85, 565)] 50 | it "Edges incident to 8." $ sort (g1 `incident` 8) `shouldBe` [(8, 5, 1), (8, 10, 5)] 51 | it "Adjacent to 14." $ (g1 ?> 14) `shouldBe` Nothing 52 | it "Adjacent to 0." $ sort (g2 !> 0) `shouldBe` [(2, 4), (19, 7)] 53 | it "Adjacent to 10." $ g2 ?> 31 `shouldBe` Nothing 54 | it "Adjacent to 11." $ g2 !> 78 `shouldBe` [] 55 | -------------------------------------------------------------------------------- /src/Math/Grads/Graph.hs: -------------------------------------------------------------------------------- 1 | -- | Module that provides 'Graph' type class and several useful functions 2 | -- for interaction with 'Graph's. 3 | -- 4 | module Math.Grads.Graph 5 | ( EdgeList 6 | , Graph (..) 7 | , GraphEdge 8 | , changeIndsEdge 9 | , changeTypeEdge 10 | , edgeType 11 | ) where 12 | 13 | import Data.List (nub) 14 | 15 | -- | 'GraphEdge' is just triple, containing index of starting vertex of edge, 16 | -- index of ending vertex of edge and edge's type. 17 | -- 18 | type GraphEdge e = (Int, Int, e) 19 | 20 | -- | Type alias for list of 'GraphEdge's. 21 | -- 22 | type EdgeList e = [GraphEdge e] 23 | 24 | -- | Get edge's type from 'GraphEdge'. 25 | -- 26 | edgeType :: GraphEdge e -> e 27 | edgeType (_, _, t) = t 28 | 29 | -- | Given transformation of edge types transforms 'GraphEdge'. 30 | -- 31 | changeTypeEdge :: (e1 -> e2) -> GraphEdge e1 -> GraphEdge e2 32 | changeTypeEdge f (a, b, t) = (a, b, f t) 33 | 34 | -- | Given transformation of edge's indices transforms 'GraphEdge'. 35 | -- 36 | changeIndsEdge :: (Int -> Int) -> GraphEdge e -> GraphEdge e 37 | changeIndsEdge f (a, b, t) = (f a, f b, t) 38 | 39 | -- | Type class that gives data structure properties of graph. 40 | -- 41 | class Graph g where 42 | -- | Construct a graph from list of vertices and edges. 43 | -- 44 | fromList :: (Ord v, Eq v) => ([v], [GraphEdge e]) -> g v e 45 | 46 | -- | Get a list of all vertices and edges from the graph. 47 | -- 48 | toList :: (Ord v, Eq v) => g v e -> ([v], [GraphEdge e]) 49 | 50 | -- | Get the number of vertices. 51 | -- 52 | vCount :: g v e -> Int 53 | 54 | -- | Unsafe get adjacent vertices. 55 | -- 56 | infixl 9 !> 57 | (!>) :: (Ord v, Eq v) => g v e -> v -> [(v, e)] 58 | 59 | -- | Unsafe get adjacent indices. 60 | -- 61 | infixl 9 !. 62 | (!.) :: g v e -> Int -> [(Int, e)] 63 | 64 | -- | Safe get adjacent vertices. 65 | -- 66 | infixl 9 ?> 67 | (?>) :: (Ord v, Eq v) => g v e -> v -> Maybe [(v, e)] 68 | 69 | -- | Safe get adjacent indices. 70 | -- 71 | infixl 9 ?. 72 | (?.) :: g v e -> Int -> Maybe [(Int, e)] 73 | 74 | -- | Get a list of edges starting at given vertex. 75 | -- 76 | incident :: (Ord v, Eq v) => g v e -> v -> [(v, v, e)] 77 | incident gr at = (\(a, b) -> (at, a, b)) <$> gr !> at 78 | 79 | -- | Safe get a list of edges starting at given vertex. 80 | -- 81 | safeIncident :: (Ord v, Eq v) => g v e -> v -> Maybe [(v, v, e)] 82 | safeIncident gr at = map (\(a, b) -> (at, a, b)) <$> gr ?> at 83 | 84 | -- | Get a list of index edges starting at given vertex. 85 | -- 86 | incidentIdx :: (Eq e) => g v e -> Int -> [GraphEdge e] 87 | incidentIdx gr idx = nub ((\(a, b) -> (min idx a, max idx a, b)) <$> gr !. idx) 88 | 89 | -- | Safe get a list of index edges starting at given vertex. 90 | -- 91 | safeIncidentIdx :: (Eq e) => g v e -> Int -> Maybe [GraphEdge e] 92 | safeIncidentIdx gr idx = nub <$> (map (\(a, b) -> (min idx a, max idx a, b)) <$> gr ?. idx) 93 | -------------------------------------------------------------------------------- /test/Coords.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Main where 6 | 7 | import Data.Map.Strict (Map) 8 | import qualified Data.Map.Strict as M 9 | import Math.Grads.Drawing.Coords (Drawable, getCoordsForGraph) 10 | import Math.Grads.GenericGraph (GenericGraph) 11 | import Math.Grads.Graph (fromList) 12 | import System.Random (mkStdGen) 13 | import Test.Hspec 14 | 15 | instance Drawable GenericGraph Int Int 16 | 17 | pathToGraphs, pathToGraphsGHC9 :: FilePath 18 | pathToGraphs = "data/Graphs.txt" 19 | pathToGraphsGHC9 = "data/GraphsGHC9.txt" 20 | 21 | roundPair :: (Float, Float) -> (Int, Int) 22 | roundPair (a, b) = (round a, round b) 23 | 24 | testMap :: IO (Map String (GenericGraph Int Int, Map Int (Int, Int))) 25 | testMap = do 26 | #if MIN_VERSION_GLASGOW_HASKELL(9, 2, 5, 0) 27 | graphsInLines <- lines <$> readFile pathToGraphsGHC9 28 | #else 29 | graphsInLines <- lines <$> readFile pathToGraphs 30 | #endif 31 | let graphsInWords = fmap words graphsInLines 32 | 33 | let forMap = fmap (\(x : y : z : _) -> (x, (fromList (read y), fmap roundPair (read z)))) graphsInWords 34 | return (M.fromList forMap) 35 | 36 | testDrawing :: SpecWith () 37 | testDrawing = describe "Check whether molecules are being drawn correctly." $ do 38 | it "Only path" $ do 39 | (graph, coords) <- fmap (M.! "only_path") testMap 40 | (roundPair <$>) <$> getCoordsForGraph (mkStdGen 0) graph `shouldBe` Just coords 41 | it "Only cycles" $ do 42 | (graph, coords) <- fmap (M.! "only_cycles") testMap 43 | (roundPair <$>) <$> getCoordsForGraph (mkStdGen 0) graph `shouldBe` Just coords 44 | it "Simple drawing" $ do 45 | (graph, coords) <- fmap (M.! "simple_drawing") testMap 46 | (roundPair <$>) <$> getCoordsForGraph (mkStdGen 0) graph `shouldBe` Just coords 47 | it "Hard drawing" $ do 48 | (graph, coords) <- fmap (M.! "hard_drawing") testMap 49 | (roundPair <$>) <$> getCoordsForGraph (mkStdGen 0) graph `shouldBe` Just coords 50 | it "Paths through conjugated cycles" $ do 51 | (graph, coords) <- fmap (M.! "paths_through_conjugated_cycles") testMap 52 | (roundPair <$>) <$> getCoordsForGraph (mkStdGen 0) graph `shouldBe` Just coords 53 | 54 | testErrors :: SpecWith () 55 | testErrors = describe "Check that coordinates for molecules that we can't draw are returned as Nothing." $ do 56 | it "Too big cycle" $ do 57 | (graph, _) <- fmap (M.! "too_big_cycle") testMap 58 | (roundPair <$>) <$> getCoordsForGraph (mkStdGen 0) graph `shouldBe` Nothing 59 | it "Bad conjugated cycle" $ do 60 | (graph, _) <- fmap (M.! "bad_conjugated_cycle") testMap 61 | (roundPair <$>) <$> getCoordsForGraph (mkStdGen 0) graph `shouldBe` Nothing 62 | it "Disappearing cycle" $ do 63 | (graph, _) <- fmap (M.! "disappearing_cycle") testMap 64 | (roundPair <$>) <$> getCoordsForGraph (mkStdGen 0) graph `shouldBe` Nothing 65 | 66 | main :: IO () 67 | main = hspec $ do 68 | testDrawing 69 | testErrors 70 | -------------------------------------------------------------------------------- /src/Math/Grads/Angem/Internal/MatrixOperations.hs: -------------------------------------------------------------------------------- 1 | -- | Functions for working with coordinates' alignment and matrix rotations. 2 | -- 3 | module Math.Grads.Angem.Internal.MatrixOperations 4 | ( alignmentFunc 5 | , rotation2D 6 | ) where 7 | 8 | import Linear.Matrix (M22, det22, 9 | transpose, (!*!), 10 | (*!)) 11 | import Linear.V2 (V2 (..)) 12 | import Linear.Vector (negated, (^+^), 13 | (^-^)) 14 | import Math.Grads.Angem.Internal.VectorOperations (avg) 15 | 16 | -- | Given two lists of points produces function that transforms coordinates of given point 17 | -- according to allignment of first list of points on second. 18 | -- 19 | alignmentFunc :: [V2 Float] -> [V2 Float] -> V2 Float -> V2 Float 20 | alignmentFunc points1 points2 = transformFunc 21 | where 22 | (rotationM, transitionV) = superImpose points1 points2 23 | transformFunc = transform rotationM transitionV 24 | 25 | superImpose :: [V2 Float] -> [V2 Float] -> (M22 Float, V2 Float) 26 | superImpose points1 points2 = (rotation, transition) 27 | where 28 | (avg1, moved1) = moveToCenter points1 29 | (avg2, moved2) = moveToCenter points2 30 | aMatrix = transpose moved2 !*! moved1 31 | (u, vt) = svd aMatrix 32 | 33 | rotation' = rotationMatrix vt u 34 | rotation = if det22 rotation' >= 0 35 | then rotation' 36 | else case vt of 37 | (V2 v1 v2) -> rotationMatrix (V2 v1 (negated v2)) u 38 | 39 | transition = avg1 - (avg2 *! rotation) 40 | 41 | svd :: M22 Float -> (M22 Float, M22 Float) 42 | svd aMatrix' = (doubleToFloatM22 rotationA, doubleToFloatM22 rotationB) 43 | where 44 | V2 (V2 a b) (V2 c d) = floatToDoubleM22 aMatrix' 45 | e = (a + d) / 2 46 | f = (a - d) / 2 47 | g = (c + b) / 2 48 | h = (c - b) / 2 49 | q = sqrt (e ** 2 + h ** 2) 50 | r = sqrt (f ** 2 + g ** 2) 51 | a1 = atan2 g f 52 | a2 = atan2 h e 53 | sy = q - r 54 | s = if sy < 0 then -1 else 1 55 | theta = (a2 - a1) / 2 56 | phi = (a2 + a1) / 2 57 | 58 | rotationA = V2 (V2 (cos phi) (- s * sin phi)) (V2 (sin phi) (s * cos phi)) 59 | rotationB = V2 (V2 (cos theta) (- sin theta)) (V2 (sin theta) (cos theta)) 60 | 61 | moveToCenter :: [V2 Float] -> (V2 Float, [V2 Float]) 62 | moveToCenter points = (avgPoint, movedPoints) 63 | where 64 | avgPoint = avg points 65 | movedPoints = (^-^ avgPoint) <$> points 66 | 67 | rotationMatrix :: M22 Float -> M22 Float -> M22 Float 68 | rotationMatrix vt u = transpose $ transpose vt !*! transpose u 69 | 70 | -- | Given angle in degrees produces rotation matrix that corresponds to that angle. 71 | -- 72 | rotation2D :: Float -> M22 Float 73 | rotation2D angle = V2 (V2 (cos trueAngle) (- sin trueAngle)) (V2 (sin trueAngle) (cos trueAngle)) 74 | where 75 | trueAngle = 2 * pi * angle / 360.0 76 | 77 | transform :: M22 Float -> V2 Float -> V2 Float-> V2 Float 78 | transform rotationM transitionV = convFunc 79 | where 80 | convFunc = transformVector rotationM transitionV 81 | 82 | transformVector :: M22 Float -> V2 Float -> V2 Float-> V2 Float 83 | transformVector rotationM transitionV v = (v *! rotationM) ^+^ transitionV 84 | 85 | doubleToFloatM22 :: M22 Double -> M22 Float 86 | doubleToFloatM22 (V2 a' b') = V2 (realToFrac <$> a') (realToFrac <$> b') 87 | 88 | floatToDoubleM22 :: M22 Float -> M22 Double 89 | floatToDoubleM22 (V2 a' b') = V2 (realToFrac <$> a') (realToFrac <$> b') 90 | -------------------------------------------------------------------------------- /src/Math/Grads/Angem/Internal/VectorOperations.hs: -------------------------------------------------------------------------------- 1 | -- | Some useful functions for operations with vectors. 2 | -- 3 | module Math.Grads.Angem.Internal.VectorOperations 4 | ( areIntersected 5 | , avg 6 | , eqV2 7 | , reflectPoint 8 | ) where 9 | 10 | import Linear.Metric (distance, norm) 11 | import Linear.V2 (V2 (..)) 12 | import Linear.Vector ((*^), (^+^), (^/)) 13 | 14 | -- | End of each line shouldn't be closer then this to other line. 15 | -- 16 | eps :: Float 17 | eps = 5 18 | 19 | -- | Checks whether two lines intersect. 20 | -- 21 | areIntersected :: (V2 Float, V2 Float) -> (V2 Float, V2 Float) -> Bool 22 | areIntersected (x@(V2 x0 y0), y@(V2 x1 y1)) (x'@(V2 x0' y0'), y'@(V2 x1' y1')) = res 23 | where 24 | epsA = 20 -- Minimal distance between two lines 25 | 26 | a = x0 * y1 - y0 * x1 27 | b = x0' * y1' - x1' * y0' 28 | 29 | x01 = x0 - x1 30 | x01' = x0' - x1' 31 | y01 = y0 - y1 32 | y01' = y0' - y1' 33 | 34 | division = x01 * y01' - y01 * x01' 35 | 36 | px = (a * x01' - x01 * b) / division 37 | py = (a * y01' - y01 * b) / division 38 | 39 | notCommonPoint = not (x `eqV2` x' || x `eqV2` y' || y `eqV2` x' || y `eqV2` y') 40 | 41 | inXBounds = min x0 x1 - eps < px && px < max x0 x1 + eps && min x0' x1' - eps < px && px < max x0' x1' + eps 42 | inYBounds = min y0 y1 - eps < py && py < max y0 y1 + eps && min y0' y1' - eps < py && py < max y0' y1' + eps 43 | 44 | pointOnLine = pointBelongsToLine (x', y') x || pointBelongsToLine (x', y') y 45 | || pointBelongsToLine (x, y) x' || pointBelongsToLine (x, y) y' 46 | notDistantEnough = not (norm (x - x') > epsA && norm (x - y') > epsA && norm (y - x') > epsA && norm (y - y') > epsA) 47 | 48 | res = notCommonPoint && (division /= 0 && inXBounds && inYBounds || pointOnLine || notDistantEnough) 49 | 50 | -- | Reflects point over given line. 51 | -- 52 | reflectPoint :: (V2 Float, V2 Float) -> V2 Float -> V2 Float 53 | reflectPoint (coordA, coordB) thisPoint = res 54 | where 55 | V2 dirA dirB = coordB - coordA 56 | 57 | a' = V2 (-dirB) dirA 58 | a = a' ^/ distance a' (V2 0.0 0.0) 59 | b' = V2 dirB (-dirA) 60 | b = b' ^/ distance b' (V2 0.0 0.0) 61 | 62 | distanceFrom = distanceFromPointToLine (coordA, coordB) 63 | normVec = if distanceFrom (thisPoint + a) < distanceFrom (thisPoint + b) then a 64 | else b 65 | 66 | transform x = x + 2 * distanceFromPointToLine (coordA, coordB) x *^ normVec 67 | 68 | res = if pointBelongsToLine (coordA, coordB) thisPoint then thisPoint 69 | else transform thisPoint 70 | 71 | distanceFromPointToLine :: (V2 Float, V2 Float) -> V2 Float -> Float 72 | distanceFromPointToLine (V2 x1 y1, V2 x2 y2) (V2 x0 y0) = res 73 | where 74 | res = abs ((y2 - y1) * x0 - (x2 - x1) * y0 + x2 * y1 - y2 * x1) / sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) 75 | 76 | pointBelongsToLine :: (V2 Float, V2 Float) -> V2 Float -> Bool 77 | pointBelongsToLine (V2 x0 y0, V2 x1 y1) (V2 x' y') = (x0 * (x' - x1) + y0 * (y' - y1)) `eqFloat` 0.0 && 78 | (min x0 x1 < x' && x' < max x0 x1 && min y0 y1 < y' && y' < max y0 y1) 79 | 80 | -- | Given list of points calculates centroid of these points. 81 | -- 82 | avg :: [V2 Float] -> V2 Float 83 | avg points = foldl1 (^+^) points ^/ fromIntegral (length points) 84 | 85 | -- | Checks two vectors of coordinates for equality. 86 | -- 87 | eqV2 :: V2 Float -> V2 Float -> Bool 88 | eqV2 (V2 a b) (V2 a' b') = a `eqFloat` a' && b `eqFloat` b' 89 | 90 | -- TODO: We need to somehow consider length of line when comparing coordinates of two points 91 | eqFloat :: Float -> Float -> Bool 92 | eqFloat x y = abs (x - y) < eps 93 | -------------------------------------------------------------------------------- /src/Math/Grads/Drawing/Internal/Coords.hs: -------------------------------------------------------------------------------- 1 | -- | Module providing functions for working with coordinates in Drawing module. 2 | -- 3 | module Math.Grads.Drawing.Internal.Coords 4 | ( Coord 5 | , CoordList 6 | , CoordMap 7 | , Link 8 | , bondLength 9 | , coordListForDrawing 10 | , coordListToMap 11 | , coordMapToCoordList 12 | , tupleToList 13 | ) where 14 | 15 | import Control.Arrow ((***)) 16 | import Data.List (sortOn) 17 | import Data.Map.Strict (Map, fromList, (!)) 18 | import Linear.Metric (distance, norm) 19 | import Linear.V2 (V2 (..)) 20 | import Linear.Vector ((^/)) 21 | import Math.Grads.Angem (alignmentFunc) 22 | import Math.Grads.Drawing.Internal.Utils (Coord, CoordList, pairToV2, 23 | tupleToList, uV2) 24 | import Math.Grads.Graph (EdgeList, GraphEdge) 25 | 26 | -- | (Number of vertex, edge) for linked paths. 27 | -- 28 | type Link e = (Int, GraphEdge e) 29 | 30 | -- | Map that matches indexes of vertices to coordinates of these vertices. 31 | -- 32 | type CoordMap = Map Int (Float, Float) 33 | 34 | -- | This constant is used to determine length of one edge when graph is drawn. 35 | -- 36 | bondLength :: Float 37 | bondLength = 100.0 38 | 39 | -- | Given 'CoordMap' and 'EdgeList' constructs 'CoordList'. 40 | -- 41 | coordMapToCoordList :: CoordMap -> EdgeList e -> CoordList e 42 | coordMapToCoordList coordMap = fmap (\bond@(a, b, _) -> (bond, (toV2Coord a, toV2Coord b))) 43 | where 44 | toV2Coord :: Int -> V2 Float 45 | toV2Coord = pairToV2 . (coordMap !) 46 | 47 | -- | Converts 'CoordList' int 'CoordMap'. 48 | -- 49 | coordListForDrawing :: Eq e => CoordList e -> CoordMap 50 | coordListForDrawing coordinates = uV2 <$> coordListToMap coordsT 51 | where 52 | coordsT = rotateAlongLongestDist coordinates 53 | 54 | -- | Converts 'CoordList' to 'Map Int (V2 Float)'. 55 | -- 56 | coordListToMap :: Eq e => CoordList e -> Map Int (V2 Float) 57 | coordListToMap coordinates = fromList (helper coordinates [] []) 58 | where 59 | 60 | helper :: CoordList e -> [Int] -> [(Int, V2 Float)] -> [(Int, V2 Float)] 61 | helper [] _ res = res 62 | helper (((a, b, _), (cA, cB)) : xs) taken res | a `elem` taken && b `elem` taken = helper xs taken res 63 | | a `elem` taken && b `notElem` taken = helper xs (b : taken) ((b, cB) : res) 64 | | a `notElem` taken && b `elem` taken = helper xs (a : taken) ((a, cA) : res) 65 | | otherwise = helper xs (a : b : taken) ((a, cA) : (b, cB) : res) 66 | 67 | rotateAlongLongestDist :: CoordList e -> CoordList e 68 | rotateAlongLongestDist coordinates = res 69 | where 70 | coordsU = getFloats coordinates 71 | (distA, distB) = findTwoMostDistantPoints coordsU 72 | dirVec = distB - distA 73 | 74 | alFunc = alignmentFunc [V2 0 0, V2 1 0] [V2 0 0, dirVec ^/ norm dirVec] 75 | res = fmap (alFunc *** alFunc) <$> coordinates 76 | 77 | getFloats :: CoordList e -> [V2 Float] 78 | getFloats coords = foldl (\x y -> x ++ tupleToList y) [] (fmap snd coords) 79 | 80 | findTwoMostDistantPoints :: [V2 Float] -> (V2 Float, V2 Float) 81 | findTwoMostDistantPoints points = res 82 | where 83 | res = head (sortOn (\(a, b) -> -(distance a b)) (allPairs points)) 84 | 85 | allPairs :: [a] -> [(a, a)] 86 | allPairs [] = [] 87 | allPairs (x : xs) = fmap (\x' -> (x, x')) xs ++ allPairs xs 88 | -------------------------------------------------------------------------------- /test/SSSR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Main where 3 | 4 | import Data.List (group, nub, sort) 5 | import Data.Map (Map) 6 | import qualified Data.Map as M 7 | 8 | import Test.Hspec (Expectation, Spec, describe, hspec, 9 | it, shouldBe, shouldMatchList, 10 | shouldSatisfy) 11 | 12 | import Math.Grads.Algo.SSSR (findSSSR) 13 | import Math.Grads.GenericGraph (GenericGraph) 14 | import Math.Grads.Graph (GraphEdge, fromList) 15 | 16 | 17 | main :: IO () 18 | main = hspec $ describe "SSSR" $ do 19 | graphSpec "graphA" graphA resultA 20 | graphSpec "graphB" graphB resultB 21 | graphSpec "graphC" graphC resultC 22 | graphSpec "graphD" graphD resultD 23 | 24 | 25 | graphSpec :: String -> GenericGraph Int Int -> Map Int Int -> Spec 26 | graphSpec name (sort . fmap sort . findSSSR -> sssr) cycleMap = it name $ do 27 | sssr `shouldMatchList` nub sssr 28 | mapM_ checkSimpleCycle sssr 29 | sssr `shouldSatisfy` (==) (sum . M.elems $ cycleMap) . length 30 | mapM_ (\(len, count) -> numCyclesOfLen len `shouldBe` count) $ M.toList cycleMap 31 | where 32 | checkSimpleCycle :: [GraphEdge Int] -> Expectation 33 | checkSimpleCycle = mapM_ (`shouldSatisfy` (==) 2 . length) . group . sort . concatMap (\(x, y, _) -> [x, y]) 34 | 35 | numCyclesOfLen :: Int -> Int 36 | numCyclesOfLen n = length . filter ((==) n . length) $ sssr 37 | 38 | 39 | -- | This 4 graphs comes from figure 5 page 5 of the original paper. 40 | -- 41 | -- 42 | 43 | -- | Note that this graph image wrong in the paper - it has 3 cycles of length 4. 44 | -- We fix it with 3 additional edges to match with results from table 4 page 5 of the paper. 45 | -- 46 | graphA :: GenericGraph Int Int 47 | graphA = fromList ( 48 | [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20], 49 | 50 | [(0,1,1),(0,5,1),(0,10,1),(0,13,1),(0,20,1),(1,2,1),(1,3,1),(1,4,1),(1,5,1),(1,20,1),(2,3,1), 51 | (2,8,1),(2,10,1),(2,20,1),(3,4,1),(3,8,1),(3,14,1),(3,15,1),(4,5,1),(4,15,1),(4,16,1),(4,19,1), 52 | (5,6,1),(5,13,1),(5,19,1),(6,7,1),(6,12,1),(6,13,1),(6,18,1),(6,19,1),(7,8,1),(7,9,1),(7,11,1), 53 | (7,12,1),(7,14,1),(7,17,1),(7,18,1),(8,9,1),(8,10,1),(8,14,1),(9,10,1),(9,11,1),(10,11,1), 54 | (10,12,1),(10,13,1),(11,12,1),(12,13,1),(14,15,1),(14,17,1),(15,16,1),(15,17,1),(16,17,1), 55 | (16,18,1),(16,19,1),(17,18,1),(18,19,1)]) 56 | 57 | resultA :: Map Int Int 58 | resultA = M.fromList [(3, 36)] 59 | 60 | 61 | graphB :: GenericGraph Int Int 62 | graphB = fromList ( 63 | [0,1,2,3,4,5,6,7,8,9,10,11,12], 64 | 65 | [(0,1,1),(0,10,1),(1,2,1),(1,8,1),(1,12,1),(2,3,1),(2,7,1),(3,4,1),(3,12,1),(4,5,1),(4,11,1), 66 | (5,6,1),(5,10,1),(6,7,1),(6,9,1),(7,8,1),(8,9,1),(9,10,1),(10,11,1),(11,12,1)]) 67 | 68 | resultB :: Map Int Int 69 | resultB = M.fromList [(4, 6), (5, 2)] 70 | 71 | 72 | graphC :: GenericGraph Int Int 73 | graphC = fromList ( 74 | [0,1,2,3,4,5,6,7,8,9,10,11,12], 75 | 76 | [(0,1,1),(0,12,1),(1,2,1),(1,8,1),(1,9,1),(1,10,1),(2,3,1),(2,4,1),(2,9,1),(3,4,1),(3,5,1), 77 | (3,9,1),(4,5,1),(4,12,1),(5,6,1),(5,12,1),(6,7,1),(6,11,1),(6,12,1),(7,8,1),(7,10,1),(7,11,1), 78 | (8,9,1),(8,10,1),(10,11,1),(11,12,1)]) 79 | 80 | resultC :: Map Int Int 81 | resultC = M.fromList [(3, 12), (5, 2)] 82 | 83 | 84 | graphD :: GenericGraph Int Int 85 | graphD = fromList ( 86 | [0,1,2,3,4,5,6,7,8,9], 87 | 88 | [(0,1,1),(0,3,1),(1,2,1),(1,9,1),(2,3,1),(2,9,1),(3,4,1),(3,5,1),(4,5,1),(4,6,1),(5,6,1),(6,7,1), 89 | (6,8,1),(7,8,1),(7,9,1),(8,9,1)]) 90 | 91 | resultD :: Map Int Int 92 | resultD = M.fromList [(3, 5), (4, 1), (6, 1)] 93 | -------------------------------------------------------------------------------- /src/Math/Grads/Drawing/Coords.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | -- | Module providing functions for obtaining coordinates of 'GenericGraph's on 5 | -- a 2D plane. 6 | -- 7 | module Math.Grads.Drawing.Coords 8 | ( Coord 9 | , CoordList 10 | , CoordMap 11 | , Drawable (..) 12 | , EdgeFixator 13 | , bondLength 14 | , getCoordsForGraph 15 | ) where 16 | 17 | import Control.Monad (join) 18 | import Data.Map.Strict (keys, 19 | singleton) 20 | import Math.Grads.Algo.Cycles (findCycles) 21 | import Math.Grads.Algo.Interaction (getIndices) 22 | import Math.Grads.Drawing.Internal.Coords (Coord, 23 | CoordList, 24 | CoordMap, 25 | bondLength, 26 | coordListForDrawing) 27 | import Math.Grads.Drawing.Internal.Cycles (getCoordsOfGlobalCycle) 28 | import Math.Grads.Drawing.Internal.CyclesPathsAlignment (alignCyclesAndPaths) 29 | import Math.Grads.Drawing.Internal.Paths (findPaths, getCoordsOfPath) 30 | import Math.Grads.Drawing.Internal.Sampling (EdgeFixator, 31 | bestSample) 32 | import Math.Grads.GenericGraph (GenericGraph) 33 | import Math.Grads.Graph (EdgeList, 34 | Graph, 35 | toList) 36 | import System.Random (StdGen) 37 | 38 | -- | Type class that defines whether graph can be drawn or not. 39 | -- 40 | class Graph g => Drawable g v e where 41 | -- | Change coordinates and fixate edges that shouldn't take part in sampling. 42 | -- 43 | edgeFixator :: g v e -> EdgeFixator e 44 | edgeFixator = const $ (,) [] 45 | 46 | -- | Given 'StdGen' returns 'CoordMap', which keys correspond to indices of 47 | -- vertices of given 'GenericGraph'. Works only for simple planar graphs. If graph 48 | -- is neither simple nor planar, returns Nothing. This function is best used for 49 | -- graphs that can be represented as systems of conjugated cycles and paths between 50 | -- them. If graph contains too complex conjugated cycles, function will return Nothing. 51 | -- 52 | getCoordsForGraph :: (Ord v, Ord e, Eq e, Drawable GenericGraph v e) => StdGen -> GenericGraph v e -> Maybe CoordMap 53 | getCoordsForGraph stdGen graph = if length vertices == 1 then Just (singleton 0 (0, 0)) 54 | else res 55 | where 56 | (vertices, edges) = toList graph 57 | (globalCycles, paths) = splitIntoCyclesAndPaths edges 58 | 59 | globalCyclesWithCoords = sequence (fmap (getCoordsOfGlobalCycle pathsWithCoords) globalCycles) 60 | pathsWithCoords = fmap getCoordsOfPath paths 61 | 62 | finalCoords = join (fmap (alignCyclesAndPaths pathsWithCoords) globalCyclesWithCoords) 63 | resCoords = join (fmap (bestSample stdGen (edgeFixator graph) (concat paths)) finalCoords) 64 | 65 | resMap = fmap coordListForDrawing resCoords 66 | 67 | res = if fmap (length . keys) resMap == pure (length vertices) then resMap else Nothing 68 | 69 | splitIntoCyclesAndPaths :: (Ord e, Eq e) => EdgeList e -> ([EdgeList e], [EdgeList e]) 70 | splitIntoCyclesAndPaths edges = (globalCycles, paths) 71 | where 72 | globalCycles = findCycles edges 73 | forPaths = filter (`notElem` concat globalCycles) edges 74 | paths = findPaths forPaths $ concatMap getIndices globalCycles 75 | -------------------------------------------------------------------------------- /math-grads.cabal: -------------------------------------------------------------------------------- 1 | name: math-grads 2 | version: 0.1.6.8 3 | synopsis: Library containing graph data structures and graph algorithms 4 | description: Library containing graph data structures and graph algorithms. 5 | . 6 | Graph data structures: 7 | . 8 | * Graph type class; 9 | . 10 | * GenericGraph data structure. 11 | . 12 | Graph algorithms: 13 | . 14 | * Ullmann's subgraph isomorphism algorithm; 15 | . 16 | * drawing of planar graphs. 17 | homepage: https://github.com/biocad/math-grads#readme 18 | license: BSD3 19 | license-file: LICENSE 20 | author: Alexandr Sadovnikov 21 | maintainer: artemkondyukov, AlexKaneRUS, vks4git 22 | copyright: 2017 Alexandr Sadovnikov 23 | category: Math, Graph 24 | build-type: Simple 25 | extra-source-files: README.md 26 | cabal-version: >=1.10 27 | 28 | library 29 | hs-source-dirs: src 30 | exposed-modules: Math.Grads.Algo.Cycles 31 | , Math.Grads.Algo.Interaction 32 | , Math.Grads.Algo.Isomorphism 33 | , Math.Grads.Algo.Isomorphism.RI 34 | , Math.Grads.Algo.Isomorphism.Types 35 | , Math.Grads.Algo.Isomorphism.Ullman 36 | , Math.Grads.Algo.Paths 37 | , Math.Grads.Algo.SSSR 38 | , Math.Grads.Algo.Traversals 39 | , Math.Grads.Drawing.Coords 40 | , Math.Grads.Graph 41 | , Math.Grads.GenericGraph 42 | , Math.Grads.Utils 43 | other-modules: Math.Grads.Drawing.Internal.Coords 44 | , Math.Grads.Drawing.Internal.Cycles 45 | , Math.Grads.Drawing.Internal.CyclesPathsAlignment 46 | , Math.Grads.Drawing.Internal.Paths 47 | , Math.Grads.Drawing.Internal.Sampling 48 | , Math.Grads.Drawing.Internal.Utils 49 | 50 | , Math.Grads.Angem 51 | , Math.Grads.Angem.Internal.VectorOperations 52 | , Math.Grads.Angem.Internal.MatrixOperations 53 | build-depends: base >= 4.7 && < 5 54 | , aeson 55 | , array 56 | , bimap 57 | , containers 58 | , lens 59 | , linear 60 | , matrix 61 | , mtl 62 | , ilist 63 | , random 64 | , vector 65 | default-language: Haskell2010 66 | 67 | test-suite Coords-test 68 | type: exitcode-stdio-1.0 69 | hs-source-dirs: test 70 | main-is: Coords.hs 71 | build-depends: base 72 | , containers 73 | , hspec 74 | , math-grads 75 | , random 76 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 77 | default-language: Haskell2010 78 | 79 | test-suite Graph-test 80 | type: exitcode-stdio-1.0 81 | hs-source-dirs: test 82 | main-is: Graph.hs 83 | build-depends: base 84 | , containers 85 | , hspec 86 | , math-grads 87 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 88 | default-language: Haskell2010 89 | 90 | test-suite Isomorphism-test 91 | type: exitcode-stdio-1.0 92 | hs-source-dirs: test 93 | main-is: Isomorphism.hs 94 | build-depends: base 95 | , array 96 | , containers 97 | , hspec 98 | , math-grads 99 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 100 | default-language: Haskell2010 101 | 102 | test-suite SSSR-test 103 | type: exitcode-stdio-1.0 104 | hs-source-dirs: test 105 | main-is: SSSR.hs 106 | build-depends: base 107 | , array 108 | , containers 109 | , hspec 110 | , math-grads 111 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 112 | default-language: Haskell2010 113 | 114 | source-repository head 115 | type: git 116 | location: https://github.com/biocad/math-grads 117 | -------------------------------------------------------------------------------- /src/Math/Grads/Drawing/Internal/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | Module that provides utility functions for whole Drawing module. 2 | -- 3 | module Math.Grads.Drawing.Internal.Utils 4 | ( Coord 5 | , CoordList 6 | , randomVectors 7 | , findIncidentCoords 8 | , reflectCycle 9 | , reflectBond 10 | , centroid 11 | , tupleToList 12 | , compareCoords 13 | , cleanListOfCoordLists 14 | , cleanCoordList 15 | , coordElem 16 | , pairToV2 17 | , uV2 18 | ) where 19 | 20 | import Control.Arrow ((***)) 21 | import Data.List (unfoldr) 22 | import Linear.V2 (V2 (..)) 23 | import Math.Grads.Algo.Interaction (isIncident) 24 | import Math.Grads.Angem (reflectPoint) 25 | import Math.Grads.Graph (GraphEdge) 26 | import System.Random (StdGen, randomR) 27 | 28 | -- | Alias for list of 'Coord's. 29 | -- 30 | type CoordList e = [Coord e] 31 | 32 | -- | 'Coord' is pair that containts graph's edge and coordinates of vertices that 33 | -- are incident to it. 34 | -- 35 | type Coord e = (GraphEdge e, (V2 Float, V2 Float)) 36 | 37 | -- | Generates vector of random 'Int's of given length. 38 | -- 39 | randomVector :: Int -> StdGen -> ([Int], StdGen) 40 | randomVector len gen = helper 0 ([], gen) 41 | where 42 | helper :: Int -> ([Int], StdGen) -> ([Int], StdGen) 43 | helper currentLength (a, g) | currentLength < len = helper (currentLength + 1) (headA : a, newGen) 44 | | otherwise = (a, g) 45 | where 46 | (headA, newGen) = randomR (0, 1) g 47 | 48 | -- | Generates list of random vectors of length numberOfVectors. 49 | -- Each vector has length lengthOfVector. 50 | -- 51 | randomVectors :: StdGen -> Int -> Int -> [[Int]] 52 | randomVectors gen lengthOfVector numberOfVectors = helper gen 53 | where 54 | helper = take numberOfVectors . unfoldr (Just . randomVector lengthOfVector) 55 | 56 | -- | Find all 'Coord's in 'CoordList' that are incident to vertex with given index. 57 | -- 58 | findIncidentCoords :: Int -> CoordList e -> CoordList e 59 | findIncidentCoords ind = filter (flip isIncident ind . fst) 60 | 61 | -- | Reflect given cycle in form of 'CoordList' over given axis. 62 | -- 63 | reflectCycle :: CoordList e -> (V2 Float, V2 Float) -> CoordList e 64 | reflectCycle thisCycle = (<$> thisCycle) . flip reflectBond 65 | 66 | -- | Reflect given 'Coord' over given axis. 67 | -- 68 | reflectBond :: Coord e -> (V2 Float, V2 Float) -> Coord e 69 | reflectBond coord ends = fmap (reflectPoint ends *** reflectPoint ends) coord 70 | 71 | -- | Calculates centroid of vertices in given 'CoordList'. 72 | -- 73 | centroid :: CoordList e -> V2 Float 74 | centroid coords' = sum coords / fromIntegral (length coords) 75 | where 76 | coords = snd <$> foldl (\x ((a, b, _), (coordA, coordB)) -> helper x (a, coordA) (b, coordB)) [] coords' 77 | helper list (a, coordA') (b, coordB') | a `elem` fmap fst list && b `elem` fmap fst list = list 78 | | a `elem` fmap fst list = (b, coordB') : list 79 | | b `elem` fmap fst list = (a, coordA') : list 80 | | otherwise = (a, coordA') : ((b, coordB') : list) 81 | 82 | -- | Converts tuple to lis. 83 | -- 84 | tupleToList :: (a, a) -> [a] 85 | tupleToList (x, y) = [x, y] 86 | 87 | -- | Converts 'V2' to pair. 88 | -- 89 | uV2 :: V2 Float -> (Float, Float) 90 | uV2 (V2 a b) = (a, b) 91 | 92 | -- | Converts pair to 'V2'. 93 | -- 94 | pairToV2 :: (Float, Float) -> V2 Float 95 | pairToV2 (a, b) = V2 a b 96 | 97 | -- | Given 'CoordList' of conjugated cycles leaves only cycles that don't intersect 98 | -- with each other excluding first cycle in list that is taken by default. 99 | -- 100 | cleanListOfCoordLists :: Eq e => [CoordList e] -> [CoordList e] -> [CoordList e] 101 | cleanListOfCoordLists [] final = final 102 | cleanListOfCoordLists (x : xs) [] = cleanListOfCoordLists xs [x] 103 | cleanListOfCoordLists (x : xs) final = if any (\thisCycle -> any (`coordElem` thisCycle) x) xs then cleanListOfCoordLists xs final 104 | else cleanListOfCoordLists xs (x : final) 105 | 106 | -- | Leaves only unique 'Coord's in given 'CoordList'. 107 | -- 108 | cleanCoordList :: Eq e => CoordList e -> CoordList e -> CoordList e 109 | cleanCoordList [] coords = coords 110 | cleanCoordList (x : xs) coords = if not (x `coordElem` coords) then cleanCoordList xs (x : coords) 111 | else cleanCoordList xs coords 112 | 113 | -- | Checks that 'Coord' is present in 'CoordList'. 114 | -- 115 | coordElem :: Eq e => Coord e -> CoordList e -> Bool 116 | coordElem coord = any (compareCoords coord) 117 | 118 | -- | Comparator for 'Coord's. 119 | -- 120 | compareCoords :: Eq e => Coord e -> Coord e -> Bool 121 | compareCoords (a, _) (b, _) = a == b 122 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/Traversals.hs: -------------------------------------------------------------------------------- 1 | -- | Module providing various kinds of graph traversals and their modifications. 2 | -- 3 | module Math.Grads.Algo.Traversals 4 | ( BFSState 5 | , bfsState 6 | , dfsCycle 7 | , dfs 8 | , getComps 9 | , getCompsWithReindex 10 | , getCompsIndices 11 | ) where 12 | 13 | import Control.Arrow ((&&&)) 14 | import Control.Monad.State (State, execState) 15 | import Control.Monad.State.Class (get, put) 16 | import qualified Data.Array as A 17 | import Data.Bimap (Bimap) 18 | import Data.List (findIndex) 19 | import Data.Map (Map, keys, (!)) 20 | import Data.Maybe (fromJust) 21 | 22 | import Math.Grads.Algo.Interaction (edgeListToMap, getIndices, 23 | getOtherEnd, matchEdges, (~=)) 24 | import Math.Grads.GenericGraph (GenericGraph, gIndex, 25 | subgraphWithReindex) 26 | import Math.Grads.Graph (EdgeList, Graph (..)) 27 | import Math.Grads.Utils (nub) 28 | 29 | -- | Classic dfs. 30 | -- 31 | dfs :: EdgeList e -> Int -> EdgeList e 32 | dfs bonds ind = if ind `elem` keys graphMap then matchEdges bonds bondsInd else [] 33 | where 34 | graphMap = edgeListToMap bonds 35 | bondsInd = dfs' graphMap [ind] [] [] 36 | 37 | dfs' :: Map Int [Int] -> [Int] -> [Int] -> [(Int, Int)] -> [(Int, Int)] 38 | dfs' _ [] _ bonds = bonds 39 | dfs' gr (cur : rest) vis bs | cur `elem` vis = dfs' gr rest vis bs 40 | | otherwise = dfs' gr (gr ! cur ++ rest) (cur : vis) visitedBonds 41 | where 42 | visitedBonds = concatMap helper (gr ! cur) ++ bs 43 | 44 | helper :: Int -> [(Int, Int)] 45 | helper sec = [(cur, sec) | notElem (cur, sec) bs && notElem (sec, cur) bs] 46 | 47 | -- | Get connected components of graph. 48 | -- Note that indexation will be CHANGED. 49 | -- 50 | getComps :: Ord v => GenericGraph v e -> [GenericGraph v e] 51 | getComps graph = snd <$> getCompsWithReindex graph 52 | 53 | -- | Get graph components and mapping from old indices to 54 | -- new indices of resulting graph components. 55 | -- 56 | getCompsWithReindex :: Ord v => GenericGraph v e -> [(Bimap Int Int, GenericGraph v e)] 57 | getCompsWithReindex graph = res 58 | where 59 | (_, edges) = toList graph 60 | comps = getComps' edges [0..length (gIndex graph) - 1] [] [] 61 | res = fmap (subgraphWithReindex graph) comps 62 | 63 | -- | Get indices of vertices that belong to different connected components. 64 | -- 65 | getCompsIndices :: Ord v => GenericGraph v e -> [[Int]] 66 | getCompsIndices graph = getComps' (snd $ toList graph) [0..length (gIndex graph) - 1] [] [] 67 | 68 | getComps' :: EdgeList e -> [Int] -> [Int] -> [[Int]] -> [[Int]] 69 | getComps' _ [] _ res = res 70 | getComps' edges (x : xs) taken res = if x `elem` taken then getComps' edges xs taken res 71 | else getComps' edges xs (taken ++ newComp) (newComp : res) 72 | where 73 | newComp = nub (x : getIndices (dfs edges x)) 74 | 75 | -- | Dfs a simple cycle. 76 | -- 77 | dfsCycle :: A.Array Int [Int] -> [Int] -> [Int] -> [Int] 78 | dfsCycle _ [] visited = visited 79 | dfsCycle graph (current:toVisit) visited | current `elem` visited = dfsCycle graph toVisit visited 80 | | otherwise = dfsCycle graph ((graph A.! current) ++ toVisit) (current:visited) 81 | 82 | -- | List of (level, (edgeIdx, vertexIdx)). 83 | -- 84 | type BFSState = [(Int, (Int, Int))] 85 | 86 | -- | Bfs algorithm that takes graph, its 'EdgeList', 'BFSState' corresponding to 87 | -- already visited vertices and 'BFSState' that corresponds to starting point 88 | -- of traversal and returns 'BFSState' as a result. 89 | -- 90 | bfsState :: (Ord v, Eq e, Show v, Show e, Graph g) => g v e -> EdgeList e -> BFSState -> BFSState -> BFSState 91 | bfsState graph bonds ign start = fst $ execState (bfsState' graph bonds) (ign, start) 92 | 93 | -- | Traverses graph from a given starting point (queue) in Breadth-first search manner. 94 | -- 95 | bfsState' :: (Ord v, Eq e, Show v, Show e, Graph g) => g v e -> EdgeList e -> State (BFSState, BFSState) () 96 | bfsState' gr bonds = do 97 | (visited, queue) <- get 98 | let (visitedL, (visitedB, visitedV)) = (fst &&& unzip . snd) $ unzip visited 99 | case queue of 100 | ((curLevel, (curBnd, curNum)) : rest) -> do 101 | let curInc = (fromJust . (\x -> (~= x) `findIndex` bonds)) <$> gr `incidentIdx` curNum 102 | let nextBonds = nub $ filter ((`notElem` visitedV) . (`getOtherEnd` curNum) . (bonds !!)) curInc 103 | let nextLevel = ((`getOtherEnd` curNum) . (bonds !!)) <$> nextBonds 104 | let nextVisited = zip (curLevel : visitedL) $ zip (curBnd : visitedB) (curNum : visitedV) 105 | put (nextVisited, rest ++ zip (repeat $ curLevel +1) (zip nextBonds nextLevel)) 106 | bfsState' gr bonds 107 | _ -> return () 108 | -------------------------------------------------------------------------------- /src/Math/Grads/Drawing/Internal/Sampling.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | -- | Module that provides function for sampling of coords of graph. 5 | -- 6 | module Math.Grads.Drawing.Internal.Sampling 7 | ( EdgeFixator 8 | , bestSample 9 | ) where 10 | 11 | import Data.List (delete, find, (\\)) 12 | import Data.Maybe (fromJust) 13 | import Math.Grads.Algo.Traversals (dfs) 14 | import Math.Grads.Angem (areIntersected, eqV2) 15 | import Math.Grads.Drawing.Internal.Coords (CoordMap, 16 | coordListForDrawing, 17 | coordMapToCoordList) 18 | import Math.Grads.Drawing.Internal.Utils (Coord, CoordList, 19 | randomVectors, reflectBond) 20 | import Math.Grads.Graph (EdgeList, GraphEdge) 21 | import System.Random (StdGen) 22 | 23 | -- | Type alias for function that, given 'CoordMap' of graph, returns modified 24 | -- version of that 'CoordMap' alongside with 'EdgeList' of graph's edges of that 25 | -- shouldn't participate in sampling. 26 | -- 27 | type EdgeFixator e = CoordMap -> (EdgeList e, CoordMap) 28 | 29 | -- | Finds conformation with minimal number of intersections. 30 | -- 31 | bestSample :: Eq e => StdGen -> EdgeFixator e -> EdgeList e -> CoordList e -> Maybe (CoordList e) 32 | bestSample stdGen edgeFixator bondsOfPaths coords = res 33 | where 34 | (fixedBonds, coordsChangedMap) = edgeFixator (coordListForDrawing coords) 35 | 36 | coordsChanged = coordMapToCoordList coordsChangedMap (fmap fst coords) 37 | samples = generateSamples stdGen coordsChanged (bondsOfPaths \\ fixedBonds) 38 | curInt = findIntersections (head samples) 39 | 40 | resSample = if curInt == 0 then head samples 41 | else minInterSample (tail samples) (head samples) curInt 42 | 43 | res = if findIntersections resSample /= 0 then Nothing 44 | else Just resSample 45 | 46 | minInterSample :: Eq e => [CoordList e] -> CoordList e -> Int -> CoordList e 47 | minInterSample [] prev _ = prev 48 | minInterSample (x : xs) prev prevMin | curInt' >= prevMin = minInterSample xs prev prevMin 49 | | curInt' == 0 = x 50 | | otherwise = minInterSample xs x curInt' 51 | where 52 | curInt' = findIntersections x 53 | 54 | generateSamples :: Eq e => StdGen -> CoordList e -> EdgeList e -> [CoordList e] 55 | generateSamples _ coords [] = [coords] 56 | generateSamples stdGen coords rotatableBonds = (rotateOnBonds coords <$>) filteredSubsets 57 | where 58 | numberOfSamples = 2000 59 | lengthOfBonds = length rotatableBonds 60 | 61 | vectors = replicate lengthOfBonds 0 : randomVectors stdGen lengthOfBonds numberOfSamples 62 | filteredSubsets = fmap (\vector -> concatMap (\(x, y) -> [y | x == 1]) (zip vector rotatableBonds)) vectors 63 | 64 | rotateOnBonds :: Eq e => CoordList e -> EdgeList e -> CoordList e 65 | rotateOnBonds = foldl rotateOnBond 66 | 67 | rotateOnBond :: Eq e => CoordList e -> GraphEdge e -> CoordList e 68 | rotateOnBond coords bond = res 69 | where 70 | bondItself@((_, b, _), (coordA, coordB)) = fromJust (find ((== bond) . fst) coords) 71 | 72 | toTheRightBonds = dfs (fst <$> delete bondItself coords) b 73 | 74 | toTheRightCoords = filter (\(x, _) -> x `elem` toTheRightBonds) coords 75 | toTheLeftCoords = filter (\(x, _) -> notElem x toTheRightBonds) coords 76 | 77 | (doNotRotate, rotate) = if length toTheLeftCoords < length toTheRightCoords then (toTheRightCoords, toTheLeftCoords) 78 | else (toTheLeftCoords, toTheRightCoords) 79 | 80 | res = if null toTheLeftCoords || null toTheRightCoords then coords 81 | else doNotRotate ++ ((`reflectBond` (coordA, coordB)) <$> rotate) 82 | 83 | doOverlap :: Coord e -> Coord e -> Bool 84 | doOverlap ((a, b, _), (coordA, coordB)) ((a', b', _), (coordA', coordB')) = condA || condB 85 | where 86 | condA = coordA `eqV2` coordA' && coordB `eqV2` coordB' || 87 | coordA `eqV2` coordB' && coordB `eqV2` coordA' 88 | condB = a /= a' && coordA `eqV2` coordA' || a /= b' && coordA `eqV2` coordB' || 89 | b /= a' && coordB `eqV2` coordA' || b /= b' && coordB `eqV2` coordB' 90 | 91 | findIntersections :: forall e. Eq e => CoordList e -> Int 92 | findIntersections [] = error "Find intersections helper on empty list." 93 | findIntersections [_] = 0 94 | findIntersections (x : xs) = foldl (allLeftIntersections x) 0 xs + findIntersections xs 95 | 96 | allLeftIntersections :: Eq e => Coord e -> Int -> Coord e -> Int 97 | allLeftIntersections coord x' coord' = x' + addIfIntersect coord coord' 98 | 99 | addIfIntersect :: Eq e => Coord e -> Coord e -> Int 100 | addIfIntersect x@(bond, coords) coord@(bond', coords') = fromEnum cond 101 | where 102 | cond = bond /= bond' && (doOverlap x coord || areIntersected coords coords') 103 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Math.Grads 2 | 3 | [![Travis](https://img.shields.io/travis/biocad/math-grads.svg)](https://travis-ci.org/biocad/math-grads) 4 | [![hackage](https://img.shields.io/hackage/v/math-grads.svg)](https://hackage.haskell.org/package/math-grads) 5 | [![hackage-deps](https://img.shields.io/hackage-deps/v/math-grads.svg)](https://hackage.haskell.org/package/math-grads) 6 | 7 | Math.Grads is library that provides graph-like data structures 8 | and various useful algorithms for analysis of these data structures. 9 | 10 | Its main feature is that all of provided type classes, data structures and 11 | functions are written in most abstract way possible to meet different demands 12 | in functionality. 13 | 14 | ## Data Structures 15 | 16 | ### Graph 17 | 18 | Graph is a type class that upon being instantiated gives data structure 19 | properties of graph-like object. 20 | 21 | ### GenericGraph 22 | 23 | GenericGraph is a data structure that describes undirected graphs and is 24 | parametrized by type of graph's vertices and type of graph's edges. 25 | So it's really up to the developer what will be stored in Generic Graph's vertices 26 | and edges. 27 | 28 | GenericGraph is honest instance of Graph, therefore it can be used in all functions 29 | that require their parameters to be Graphs. 30 | 31 | ## Algorithms 32 | 33 | ### Ullmann's subgraph isomorphism algorithm 34 | 35 | Math.Grads contains implementation of Ullmann's subgraph isomorphism 36 | [algorithm](https://www.cs.bgu.ac.il/~dinitz/Course/SS-12/Ullman_Algorithm.pdf). 37 | There are several functions that one can find helpful in order to check two graphs 38 | for isomorphism or subgraph isomorphism: 39 | 40 | * `isIso` checks whether two graphs are isomorphic; 41 | * `isIsoSub` checks whether second graph has subgraph isomorphic to the first one; 42 | * `getIso` finds matching of vertices of first graph to vertices of subgraph in second graph that 43 | is isomorphic to the first graph; 44 | * `getMultiIso` finds all such matchings. 45 | 46 | In order for these functions to work graphs that are being passed to them have to also 47 | be instances of `GComparable` type class. 48 | 49 | Definition of this class is as follows: 50 | 51 | ```haskell 52 | class (Graph g1, Graph g2) => GComparable g1 v1 e1 g2 v2 e2 where 53 | vComparator :: g1 v1 e1 -> g2 v2 e2 -> VComparator v1 v2 54 | eComparator :: g1 v1 e1 -> g2 v2 e2 -> EComparator e1 e2 55 | 56 | -- | Function that checks whether two vertices are identical. 57 | type VComparator v1 v2 = VertexIndex -> VertexIndex -> Bool 58 | 59 | -- | Function that checks whether two edges are identical. 60 | type EComparator e1 e2 = GraphEdge e1 -> GraphEdge e2 -> Bool 61 | ``` 62 | 63 | So, basically, if two `Graph`s are `GComparable` with each other there exist 64 | two functions that are responsible for establishing equality between vertices and edges 65 | of such Graphs. 66 | 67 | Here Math.Grads gets its chance to shine, because developer isn't constrained to 68 | what we (as developers of Math.Grads) thought would be an appropriate way for comparing 69 | vertices and edges of your data structure. We give the developers opportunity to define 70 | such relations for their data structures themselves. 71 | 72 | Maybe you want to know surroundings of two vertices in order to compare them, maybe 73 | you don't — the choice is yours! 74 | 75 | ### Algorithm for calculation of planar graph's coordinates 76 | 77 | Math.Grads provides algorithm for calculation of coordinates of planar graphs. 78 | Its main idea is that most such graphs used in practice can be represented 79 | as union of systems of conjugated cycles and paths that connect these systems. 80 | 81 | So, if you know, that your planar graph looks just like this 82 | (for example, small molecules from chemistry perfectly fit 83 | into the definition of graphs that can be drawn correctly by the algorithm), 84 | you may find `getCoordsForGraph` function quite useful. 85 | 86 | Algorithm first draws systems of conjugated cycles, then draws paths between them, 87 | unites systems with path and using random generator samples different conformations 88 | of resulting graph until conformation without self-intersections (that's why graph needs 89 | to be planar) is found. 90 | 91 | Once again, in order for you graph to be drawn you need to make it an instance of 92 | special type class: 93 | 94 | ```haskell 95 | class Graph g => Drawable g v e where 96 | edgeFixator :: g v e -> EdgeFixator e 97 | edgeFixator = const $ (,) [] 98 | 99 | type EdgeFixator e = CoordMap -> (EdgeList e, CoordMap) 100 | ``` 101 | 102 | `edgeFixator` is function that given `Graph` returns other function that somehow transforms 103 | coordinates of graph before sampling and states, which edges of graph shouldn't change their coordinates 104 | during sampling ('fixates' them, if you will). As you can see, `edgeFixator` has default implementation, 105 | so if you don't want such functionality, just instantiate your graph as `Drawable` without 106 | getting into such details. 107 | 108 | ### Miscellaneous functions on graphs 109 | 110 | Math.Grads also provides all other kinds of graph algorithms that you might find useful: 111 | your depth-first searches, breadth-first searches, functions to find cycles in graphs and so on. 112 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/Interaction.hs: -------------------------------------------------------------------------------- 1 | -- | Module that provides various functions for interaction with 'GraphEdge's, 2 | -- 'EdgeList's and vertices themselves. 3 | -- 4 | module Math.Grads.Algo.Interaction 5 | ( 6 | -- * Vertex Functions 7 | -- 8 | areAdjacent 9 | , getEnds 10 | , getOtherEnd 11 | , getSharedVertex 12 | , getVertexAdjacent 13 | , getVertexIncident 14 | , getVertexIncidentIdx 15 | , haveSharedVertex 16 | , isIncident 17 | , (~=) 18 | , (/~=) 19 | -- * Edge Functions 20 | -- 21 | , matchEdges 22 | , getEdgeIncident 23 | -- * EdgeList Functions 24 | -- 25 | , doubleEdgeList 26 | , edgeListToMap 27 | , haveSharedEdge 28 | , sortBondList 29 | , getIndices 30 | ) where 31 | 32 | import Data.List (find, findIndices, intersect, sortOn) 33 | import Data.Map (Map) 34 | import qualified Data.Map as M 35 | import Data.Maybe (fromJust, isJust) 36 | 37 | import Math.Grads.Graph (EdgeList, GraphEdge, edgeType) 38 | import Math.Grads.Utils (nub) 39 | 40 | -- | Equality operator for 'GraphEdge's. 41 | -- 42 | (~=) :: GraphEdge e1 -> GraphEdge e2 -> Bool 43 | (b, e, _) ~= (b', e', _) = (b == b' && e == e') || (b == e' && e == b') 44 | 45 | -- | Inequality operator for 'GraphEdge's. 46 | -- 47 | (/~=) :: GraphEdge e1 -> GraphEdge e2 -> Bool 48 | b1 /~= b2 = not $ b1 ~= b2 49 | 50 | -- | Checks that vertex with given index is incident to 'GraphEdge'. 51 | -- 52 | isIncident :: GraphEdge e -> Int -> Bool 53 | isIncident (b, e, _) n = b == n || e == n 54 | 55 | -- | Find all edges in given 'EdgeList' that are incident to vertex with given index. 56 | -- 57 | getVertexIncident :: EdgeList e -> Int -> EdgeList e 58 | getVertexIncident bs n = filter (`isIncident` n) bs 59 | 60 | -- | Returns indices of edges in 'EdgeList' that are incident to vertex with given index. 61 | -- 62 | getVertexIncidentIdx :: EdgeList e -> Int -> [Int] 63 | getVertexIncidentIdx bs n = findIndices (`isIncident` n) bs 64 | 65 | -- | Returns index of vertex incident to given 'GraphEdge' and different from passed index. 66 | -- 67 | getOtherEnd :: GraphEdge e -> Int -> Int 68 | getOtherEnd (b, e, _) n | b == n = e 69 | | e == n = b 70 | | otherwise = error "There is no such index in edge." 71 | 72 | -- | Finds in given 'EdgeList' all indices of vertices adjacent to given vertex. 73 | -- 74 | getVertexAdjacent :: EdgeList e -> Int -> [Int] 75 | getVertexAdjacent bs n = (`getOtherEnd` n) <$> getVertexIncident bs n 76 | 77 | -- | Checks whether two vertices with given indices are adjacent in given 'EdgeList'. 78 | -- 79 | areAdjacent :: EdgeList e -> Int -> Int -> Bool 80 | areAdjacent bs n n' = n' `elem` getVertexAdjacent bs n 81 | 82 | -- | Retrieves indices of vertices that are being connected by given 'GraphEdge'. 83 | -- 84 | getEnds :: GraphEdge e -> [Int] 85 | getEnds (b, e, _) = [b, e] 86 | 87 | -- | Checks that two edges have common vertex. 88 | -- 89 | haveSharedVertex :: GraphEdge e1 -> GraphEdge e2 -> Bool 90 | haveSharedVertex b1 b2 = isJust $ getSharedVertex b1 b2 91 | 92 | -- | Gets shared common vertex of two edges. If edges don't have common vertex, 93 | -- returns Nothing. 94 | -- 95 | getSharedVertex :: GraphEdge e1 -> GraphEdge e2 -> Maybe Int 96 | getSharedVertex b1 b2 | null is = Nothing 97 | | length is == 2 = Nothing 98 | | otherwise = Just $ head is 99 | where 100 | is = getEnds b1 `intersect` getEnds b2 101 | 102 | -- | Find edges in 'EdgeList' which ordered pairs of indices, that they are connecting, 103 | -- are present in passed list of ordered pairs. 104 | -- 105 | matchEdges :: EdgeList e -> [(Int, Int)] -> EdgeList e 106 | matchEdges bonds = fmap (\(a, b) -> fromJust (find (~= (a, b, undefined)) bonds)) 107 | 108 | -- | Find all edges that are incident to edge in 'EdgeList' with given index. 109 | -- 110 | getEdgeIncident :: Ord e => EdgeList e -> Int -> EdgeList e 111 | getEdgeIncident bs n | n >= length bs = [] 112 | | otherwise = filter (/= (beg, end, typ)) $ getVertexIncident bs beg ++ getVertexIncident bs end 113 | where 114 | (beg, end, typ) = bs !! n 115 | 116 | -- | For every edge in 'EdgeList' add to that list an edge in opposite direction. 117 | -- 118 | doubleEdgeList :: EdgeList e -> EdgeList e 119 | doubleEdgeList = concatMap (\(a, b, t) -> [(a, b, t), (b, a, t)]) 120 | 121 | -- | Transforms 'EdgeList' into 'Map' that corresponds to adjacency list of undirected 122 | -- graph induced by these edges. 123 | -- 124 | edgeListToMap :: EdgeList e -> Map Int [Int] 125 | edgeListToMap bonds' = M.fromList (fmap (toVertex bonds) (getIndices bonds)) 126 | where 127 | bonds = doubleEdgeList bonds' 128 | 129 | toVertex :: EdgeList e -> Int -> (Int, [Int]) 130 | toVertex bs i = (i, concatMap (\(a, b, _) -> [a | b == i]) bs) 131 | 132 | -- | Checks that two 'EdgeList's have common edge. 133 | -- 134 | haveSharedEdge :: Eq e => EdgeList e -> EdgeList e -> Bool 135 | haveSharedEdge b1 b2 = or $ fmap (`elem` b2) b1 136 | 137 | -- | Sorting for 'EdgeList', that sorts edges on their type, then on index of their 138 | -- to (right) vertex, then on index of their from (left) vertex. 139 | -- 140 | sortBondList :: Ord e => EdgeList e -> EdgeList e 141 | sortBondList = sortOn left . sortOn right . sortOn edgeType 142 | where 143 | left (a, _, _) = a 144 | right (_, b, _) = b 145 | 146 | -- | Gets all vertices from 'EdgeList'. 147 | -- 148 | getIndices :: EdgeList e -> [Int] 149 | getIndices = nub . concatMap getEnds 150 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/Paths.hs: -------------------------------------------------------------------------------- 1 | -- | Module that provides functions for different kinds of path-finding in graph. 2 | -- 3 | module Math.Grads.Algo.Paths 4 | ( allPathsInGraph 5 | , allPathsFromVertex 6 | , dfsAllPaths 7 | , dfsSearch 8 | , findBeginnings 9 | ) where 10 | 11 | import Control.Monad (forM_) 12 | import Control.Monad.State (State, execState) 13 | import Control.Monad.State.Class (get, modify) 14 | import Data.Map (Map, keys, (!)) 15 | import Data.Maybe (fromMaybe, isJust) 16 | import Math.Grads.Algo.Interaction (edgeListToMap, getVertexAdjacent, 17 | matchEdges, sortBondList) 18 | import Math.Grads.GenericGraph (GenericGraph) 19 | import Math.Grads.Graph (EdgeList, Graph (..)) 20 | import Math.Grads.Utils (nub, subsets, uniter) 21 | 22 | -- | Finds all vertices in 'EdgeList' that have only one neighbour. 23 | -- 24 | findBeginnings :: EdgeList e -> [Int] 25 | findBeginnings edges = fmap fst (filter ((== 1) . snd) counters) 26 | where 27 | graph = edgeListToMap edges 28 | counters = zip (keys graph) (fmap (length . (graph !)) (keys graph)) 29 | 30 | -- | Calculates all branched paths in graph up to the given length. 31 | -- 32 | allPathsInGraph :: Ord e => GenericGraph v e -> Int -> [EdgeList e] 33 | allPathsInGraph graph lengthOfPath = helper graph vertexInds [] 34 | where 35 | vertexInds = [0 .. (vCount graph - 1)] 36 | 37 | helper :: Ord e => GenericGraph v e -> [Int] -> [Int] -> [EdgeList e] 38 | helper _ [] _ = [] 39 | helper gr (x : xs) forbidden = allPathsFromVertex gr x lengthOfPath forbidden ++ helper gr xs (x : forbidden) 40 | 41 | -- | Calculates all branched paths up to the given length from given vertex in graph 42 | -- considering indices of vertices that shouldn't be visited during path-finding. 43 | -- 44 | allPathsFromVertex :: Ord e => GenericGraph v e -> Int -> Int -> [Int] -> [EdgeList e] 45 | allPathsFromVertex graph vertex lengthOfPath forbidden = nub filtered 46 | where 47 | res' = execState (allPathsFromVertexSt graph [vertex] lengthOfPath forbidden []) [] 48 | filtered = sortBondList <$> filter (not . null) res' 49 | 50 | allPathsFromVertexSt :: Ord e => GenericGraph v e -> [Int] -> Int -> [Int] -> EdgeList e -> State [EdgeList e] [EdgeList e] 51 | allPathsFromVertexSt graph vertices lenOfPath forbidden res = if lenOfPath < 0 then get 52 | else 53 | do 54 | modify (res :) 55 | 56 | let edgesNeigh = nub (filter (`notElem` res) (concatMap (incidentIdx graph) vertices)) 57 | let allowedEdgesNeigh = filter (\(a, b, _) -> a `notElem` forbidden && b `notElem` forbidden) edgesNeigh 58 | let edgeSets = filter ((\x -> x > 0 && x <= lenOfPath) . length) (subsets allowedEdgesNeigh) 59 | if lenOfPath == 0 || not (null allowedEdgesNeigh) then 60 | do 61 | forM_ edgeSets (\set -> do 62 | let newNeighbors = concatMap (getVertexAdjacent set) vertices 63 | let newLength = lenOfPath - length set 64 | let newRes = res ++ set 65 | modify (execState (allPathsFromVertexSt graph newNeighbors newLength forbidden newRes) [] ++)) 66 | get 67 | else get 68 | 69 | -- | Finds path between two vertices in graph represented as 'EdgeList'. 70 | -- Graph shouldn't have any cycles. Hmmm, what's the difference between this function 71 | -- and DFS or BFS?.. 72 | -- 73 | dfsSearch :: EdgeList e -> Int -> Int -> Maybe (EdgeList e, [Int]) 74 | dfsSearch edges start finish = if cond then Just (matchEdges edges edgesInd, x) 75 | else Nothing 76 | where 77 | graph = edgeListToMap edges 78 | x = fromMaybe [] $ helperDfs graph (-1) finish [start] 79 | 80 | edgesInd = uniter x 81 | inds = concatMap (\(x', y, _) -> [x', y]) edges 82 | 83 | cond = start `elem` inds && finish `elem` inds 84 | 85 | helperDfs :: Map Int [Int] -> Int -> Int -> [Int] -> Maybe [Int] 86 | helperDfs graph prev finish path | current /= prev && current /= finish = if not (null (==?)) then head (==?) else Nothing 87 | | current == finish = Just path 88 | | otherwise = Nothing 89 | where 90 | current = head path 91 | children = filter (/= prev) (graph ! current) 92 | (==?) = filter isJust (map (\x -> helperDfs graph current finish (x : path)) children) 93 | 94 | -- | Finds all paths between vertices with given indices in 'EdgeList'. 95 | -- 96 | dfsAllPaths :: EdgeList e -> Int -> Int -> [EdgeList e] 97 | dfsAllPaths edges start finish = fmap (matchEdges edges) edgesInd 98 | where 99 | graph = edgeListToMap edges 100 | paths = execState (statePaths graph finish [start]) [] 101 | 102 | filteredPaths = filter ((> 2) . length) paths 103 | edgesInd = fmap helper filteredPaths 104 | 105 | helper :: [Int] -> [(Int, Int)] 106 | helper l = if (start, finish) `elem` united then united 107 | else (start, finish) : united 108 | where 109 | united = uniter l 110 | 111 | statePaths :: Map Int [Int] -> Int -> [Int] -> State [[Int]] [[Int]] 112 | statePaths graph finish path = if head path `elem` tail path then get else (do 113 | let current = head path 114 | if current == finish then do {modify ([path] ++); get} else 115 | do 116 | let children = filter (`notElem` path) (graph ! current) 117 | forM_ children (\child -> modify (execState (statePaths graph finish (child : path)) [] ++)) 118 | get) 119 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/Isomorphism/RI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | module Math.Grads.Algo.Isomorphism.RI 7 | ( getMultiIso 8 | ) where 9 | 10 | import Data.Array (Array) 11 | import qualified Data.Array as A 12 | import Data.Bimap (Bimap) 13 | import qualified Data.Bimap as BM 14 | import Data.List (delete, find, maximumBy) 15 | import Data.Map (Map) 16 | import Data.Ord (comparing) 17 | 18 | import Math.Grads.Algo.Isomorphism.Types (GComparable (..)) 19 | import Math.Grads.GenericGraph (GenericGraph, gAdjacency, 20 | getEdge) 21 | 22 | 23 | -- | RI isomorphism algorithm. 24 | -- 25 | 26 | type AdjArr = Array Int [Int] 27 | type VComp = (Int -> Int -> Bool) 28 | type EComp = ((Int, Int) -> (Int, Int) -> Bool) 29 | 30 | 31 | getMultiIso :: Ord v1 => Eq e1 => Ord v2 => Eq e2 32 | => GComparable GenericGraph v1 e1 GenericGraph v2 e2 33 | => GenericGraph v1 e1 -> GenericGraph v2 e2 34 | -> [Map Int Int] 35 | getMultiIso queryGraph@(toAdjArr -> queryAdjArr) targetGraph@(toAdjArr -> targetAdjArr) = isos 36 | where 37 | (order, parents) = buildMatchingOrder queryAdjArr 38 | isos = findIsos queryAdjArr targetAdjArr vComp eComp order parents 39 | 40 | vComp = vComparator queryGraph targetGraph 41 | eComp = eIndComp 42 | where 43 | comp = eComparator queryGraph targetGraph 44 | eIndComp (a, b) (x, y) = comp (a, b, getEdge queryGraph a b) (x, y, getEdge targetGraph x y) 45 | 46 | buildMatchingOrder :: AdjArr -> ([Int], [Maybe Int]) 47 | buildMatchingOrder graph = buildOrder [] [] $ A.indices graph 48 | where 49 | buildOrder :: [Int] -> [Maybe Int] -> [Int] -> ([Int], [Maybe Int]) 50 | buildOrder visited parents unvisited 51 | | null unvisited = (visited, parents) 52 | | otherwise = buildOrder nextVisited nextParents nextUnvisited 53 | where 54 | maxVertex = maximumBy (comparing vertexRank) unvisited 55 | maxVertexParent = find ((maxVertex `elem`) . (graph !.)) visited 56 | 57 | nextVisited = visited ++ [maxVertex] 58 | nextParents = parents ++ [maxVertexParent] 59 | nextUnvisited = delete maxVertex unvisited 60 | 61 | vertexRank :: Int -> (Int, Int, Int) 62 | vertexRank ind 63 | | null visited = (degree, 0, 0) 64 | | otherwise = (visRank, neiRank, unvisRank) 65 | where 66 | neis = graph !. ind 67 | neisUnvis = filter (`notElem` visited) neis 68 | 69 | degree = length neis 70 | visRank = count neisWithInd visited 71 | neiRank = count neisWithInd1Unvis visited 72 | unvisRank = count notNeiWithVis neisUnvis 73 | 74 | neisWithInd = (ind `elem`) . (graph !.) 75 | neisWithInd1Unvis = any (`elem` neisUnvis) . (graph !.) 76 | notNeiWithVis = all (`notElem` visited) . (graph !.) 77 | 78 | findIsos :: AdjArr -> AdjArr -> VComp -> EComp 79 | -> [Int] -> [Maybe Int] 80 | -> [Map Int Int] 81 | findIsos queryGraph targetGraph vComp eComp order parents = 82 | BM.toMap <$> goRI order parents BM.empty 83 | where 84 | goRI :: [Int] -> [Maybe Int] -> Bimap Int Int -> [Bimap Int Int] 85 | goRI [] _ match = [match] 86 | goRI _ [] match = [match] 87 | goRI (queryV : vs) (parent : ps) match = concatMap (goRI vs ps) matches 88 | where 89 | matches :: [Bimap Int Int] 90 | matches = (\targetV -> BM.insert queryV targetV match) <$> targetVs 91 | 92 | targetVs :: [Int] 93 | targetVs = filter isValidMatch $ maybe targetVsUnmatched findCandidates parent 94 | 95 | targetVsUnmatched :: [Int] 96 | targetVsUnmatched = filter (`BM.notMemberR` match) $ A.indices targetGraph 97 | 98 | findCandidates :: Int -> [Int] 99 | findCandidates = filter (`BM.notMemberR` match) . (targetGraph !.) . (match BM.!) 100 | 101 | isValidMatch :: Int -> Bool 102 | isValidMatch targetV = 103 | vComp queryV targetV && 104 | length queryNeis <= length targetNeis && 105 | all (`elem` targetNeisMatched) queryNeisMatchedProjection && 106 | all (uncurry eComp) matchedEdges 107 | where 108 | queryNeis = queryGraph !. queryV 109 | targetNeis = targetGraph !. targetV 110 | 111 | queryNeisMatched = filter (`BM.member` match) queryNeis 112 | queryNeisMatchedProjection = (match BM.!) <$> queryNeisMatched 113 | targetNeisMatched = filter (`BM.memberR` match) targetNeis 114 | 115 | matchedEdges :: [((Int, Int), (Int, Int))] 116 | matchedEdges = matchedEdgePair <$> queryNeisMatched 117 | where 118 | matchedEdgePair queryNei = ((queryV, queryNei), (targetV, match BM.! queryNei)) 119 | 120 | toAdjArr :: GenericGraph v b -> Array Int [Int] 121 | toAdjArr = fmap (fmap fst) . gAdjacency 122 | 123 | (!.) :: AdjArr -> Int -> [Int] 124 | (!.) = (A.!) 125 | 126 | count :: (a -> Bool) -> [a] -> Int 127 | count p = length . filter p 128 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/SSSR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Math.Grads.Algo.SSSR 6 | ( findSSSR 7 | ) where 8 | 9 | import Control.Arrow ((***)) 10 | import Control.Lens (over, to, toListOf, (%~), (&), _1, _2) 11 | import Data.Bimap (Bimap, (!>)) 12 | import Data.List (intersect, nub, sort) 13 | import Data.List.Index (ifoldl) 14 | import Data.Map.Strict (Map) 15 | import qualified Data.Map.Strict as M (empty, insert, member, (!)) 16 | import Data.Matrix (Matrix, matrix, unsafeGet, 17 | unsafeSet) 18 | import qualified Data.Set as S 19 | 20 | import Math.Grads.Algo.Cycles (getCyclic) 21 | import Math.Grads.Algo.Traversals (getCompsWithReindex) 22 | import Math.Grads.GenericGraph (GenericGraph, subgraphWithReindex) 23 | import Math.Grads.Graph (EdgeList, toList) 24 | 25 | 26 | -- | RP-Path algorithm for searching the smallest set of smallest rings. 27 | -- 28 | 29 | -- | Find SSSR of any graph. 30 | -- 31 | findSSSR :: (Ord v, Ord e) => GenericGraph v e -> [EdgeList e] 32 | findSSSR graph = sssr 33 | where 34 | (reindex, cyclicGraph) = subgraphWithReindex graph . S.toList $ getCyclic graph 35 | sssr = reindexCycles reindex $ findCyclicSSSR cyclicGraph 36 | 37 | -- | Find SSSR of cyclic graph, i.e. each graphs edge belongs at least 1 cycle. 38 | -- 39 | findCyclicSSSR :: forall v e. (Ord v, Ord e) => GenericGraph v e -> [EdgeList e] 40 | findCyclicSSSR cyclicGraph = sssr 41 | where 42 | reindex2compList :: [(Bimap Int Int, GenericGraph v e)] 43 | reindex2compList = getCompsWithReindex cyclicGraph 44 | 45 | sssr = reindex2compList & traverse %~ over _2 findFusedSSSR 46 | & traverse %~ uncurry reindexCycles 47 | & concat 48 | 49 | -- | Find SSSR of fused graph, i.e. graph is cyclic and connected. 50 | -- 51 | findFusedSSSR :: (Ord v, Ord e) => GenericGraph v e -> [EdgeList e] 52 | findFusedSSSR fusedGraph = sssr 53 | where 54 | g@(_, edges) = toList fusedGraph 55 | (n, m) = (length *** length) g 56 | maxSSSRs = m - n + 1 57 | 58 | edgeIndex :: Map (Int, Int) Int 59 | edgeIndex = ifoldl insertEdge M.empty edges 60 | where 61 | insertEdge edgeMap ind (x, y, _) = M.insert (y, x) ind $ M.insert (x, y) ind edgeMap 62 | 63 | (pid, pid') = calculatePidMatrices n m edgeIndex 64 | sssrEdges = takeSSSR n maxSSSRs pid pid' 65 | sssr = fmap (edges !!) <$> sssrEdges 66 | 67 | takeSSSR :: Int -> Int -> Matrix (Int, [[Int]]) -> Matrix [[Int]] -> [[Int]] 68 | takeSSSR n maxSSSRs pid pid' = go [] [] 3 (1, 1) 69 | where 70 | go cycles edges len (i, j) 71 | | (i, j) > (n, n) || length cycles >= maxSSSRs = 72 | cycles 73 | | curLen /= len || length ij < 1 || length ij == 1 && null ij' = 74 | go cycles edges nextLen nextInd 75 | | otherwise = 76 | go nextCycles nextEdges nextLen nextInd 77 | where 78 | (ijDist, ij) = unsafeGet i j pid 79 | ij' = unsafeGet i j pid' 80 | 81 | curLen = ijDist * 2 + len `mod` 2 82 | 83 | newCycles = take (maxSSSRs - length cycles) $ 84 | filter (`notElem` cycles) $ 85 | filter (\c -> all (c `notContains`) cycles) $ 86 | nub $ 87 | cartesianProduct ij (if even len then ij else ij') notIntersects concatSort 88 | where 89 | notIntersects a b = null $ intersect a b 90 | concatSort a b = sort $ a ++ b 91 | notContains a b = length (a `intersect` b) < length b - 1 92 | 93 | nextCycles = cycles ++ newCycles 94 | nextEdges = nub $ edges ++ concat newCycles 95 | 96 | (nextLen, nextInd) 97 | | (i, j) == (n, n) = (len + 1, (1, 1)) 98 | | j == n = (len, (i + 1, 1)) 99 | | otherwise = (len, (i, j + 1)) 100 | 101 | calculatePidMatrices :: Int -> Int -> Map (Int, Int) Int 102 | -> (Matrix (Int, [[Int]]), Matrix [[Int]]) 103 | calculatePidMatrices n m edgeIndex = calcPids initPid initPid' (1, 1, 1) 104 | where 105 | initPid :: Matrix(Int, [[Int]]) 106 | initPid = matrix n n $ \(x, y) -> if 107 | | (x - 1, y - 1) `M.member` edgeIndex -> (1, [[edgeIndex M.! (x - 1, y - 1)]]) 108 | | otherwise -> (m + 1, []) 109 | 110 | initPid' :: Matrix [[Int]] 111 | initPid' = matrix n n $ const [] 112 | 113 | calcPids :: Matrix(Int, [[Int]]) -> Matrix [[Int]] 114 | -> (Int, Int, Int) 115 | -> (Matrix(Int, [[Int]]), Matrix [[Int]]) 116 | calcPids pid pid' ind@(k, i, j) 117 | | ind > (n, n, n) = (pid, pid') 118 | | otherwise = calcPids nextPid nextPid' nextInd 119 | where 120 | (ijDist, ij) = unsafeGet i j pid 121 | (ikDist, ik) = unsafeGet i k pid 122 | (kjDist, kj) = unsafeGet k j pid 123 | ikjDist = ikDist + kjDist 124 | ikj = cartesianProduct ik kj (/=) (++) 125 | ij' = unsafeGet i j pid' 126 | 127 | nextPid 128 | | ijDist > ikjDist = unsafeSet (ikjDist, ikj) (i, j) pid 129 | | ijDist == ikjDist = unsafeSet (ijDist, ij ++ ikj) (i, j) pid 130 | | otherwise = pid 131 | 132 | nextPid' 133 | | ijDist == ikjDist + 1 = unsafeSet ij (i, j) pid' 134 | | ijDist == ikjDist - 1 = unsafeSet (ij' ++ ikj) (i, j) pid' 135 | | ijDist > ikjDist + 1 = unsafeSet [] (i, j) pid' 136 | | otherwise = pid' 137 | 138 | nextInd 139 | | (i, j) == (n, n) = (k + 1, 1, 1 ) 140 | | j == n = (k, i + 1, 1 ) 141 | | otherwise = (k, i, j + 1) 142 | 143 | reindexCycles :: Bimap Int Int -> [EdgeList e] -> [EdgeList e] 144 | reindexCycles reindex = fmap reindexCycle 145 | where 146 | reindexCycle :: EdgeList e -> EdgeList e 147 | reindexCycle = toListOf $ traverse . to (over _1 (reindex !>) . over _2 (reindex !>)) 148 | 149 | cartesianProduct :: Eq a => [a] -> [a] -> (a -> a -> Bool) -> (a -> a -> b) -> [b] 150 | cartesianProduct xs ys f g = [ g x y | x <- xs, y <- ys, f x y ] 151 | -------------------------------------------------------------------------------- /test/Isomorphism.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | 5 | module Main where 6 | 7 | import Control.Arrow ((***)) 8 | import qualified Data.Array as A 9 | import Data.List (sort) 10 | import Data.Map.Strict (Map) 11 | import qualified Data.Map.Strict as M 12 | import Math.Grads.Graph (fromList, toList) 13 | import Test.Hspec 14 | 15 | import Math.Grads.Algo.Isomorphism (GComparable (..), isIsoSub) 16 | import qualified Math.Grads.Algo.Isomorphism.RI as RI 17 | import qualified Math.Grads.Algo.Isomorphism.Ullman as UI 18 | import Math.Grads.GenericGraph (GenericGraph, gIndex, 19 | getEdge) 20 | 21 | instance GComparable GenericGraph Int Int GenericGraph Int Int where 22 | vComparator g1 g2 ind1 ind2 = gIndex g1 A.! ind1 == gIndex g2 A.! ind2 23 | eComparator _ _ (_, _, t) (_, _, t') = t == t' 24 | 25 | pathToGraphs :: FilePath 26 | pathToGraphs = "data/Graphs.txt" 27 | 28 | testMap :: IO (Map String (GenericGraph Int Int)) 29 | testMap = do 30 | graphsInLines <- lines <$> readFile pathToGraphs 31 | let graphsInWords = fmap words graphsInLines 32 | 33 | let forMap = fmap (\(x : y : _) -> (x, fromList (read y))) graphsInWords 34 | return (M.fromList forMap) 35 | 36 | bigSubGraph :: GenericGraph Int Int 37 | bigSubGraph = fromList ( [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] 38 | , [ (0, 1, 1), (0, 26, 1), (1, 2, 1), (2, 3, 1), (3, 4, 1), (3, 25, 1), (4, 5, 1), (4, 11, 1), (5, 6, 1) 39 | , (6, 7, 1), (7, 8, 1), (7, 10, 1), (8, 9, 1), (9, 10, 1), (11, 12, 1), (11, 24, 1), (12, 13, 1), (13, 14, 1) 40 | , (13, 18, 1), (14, 15, 1), (15, 16, 1), (16, 17, 1), (17, 18, 1), (18, 19, 1), (19, 20, 1), (19, 24, 1) 41 | , (20, 21, 1), (21, 22, 1), (22, 23, 1), (23, 24, 1), (25, 26, 1) 42 | ] 43 | ) 44 | 45 | pathGraph :: GenericGraph Int Int 46 | pathGraph = fromList ([0, 0, 0, 0, 0, 0, 0], [(0, 1, 1), (0, 2, 1), (0, 3, 1), (0, 4, 1), (4, 5, 1), (4, 6, 1)]) 47 | 48 | conjugatedCycles :: GenericGraph Int Int 49 | conjugatedCycles = fromList ( [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] 50 | , [ (0, 1, 1), (0, 2, 1), (1, 3, 1), (2, 4, 1), (4, 5, 1), (3, 5, 1), (3, 6, 1), (5, 7, 1) 51 | , (6, 8, 1), (7, 9, 1), (8, 9, 1), (1, 10, 1), (6, 11, 1), (10, 12, 1), (11, 12, 1) 52 | ] 53 | ) 54 | 55 | connectedCycles :: GenericGraph Int Int 56 | connectedCycles = fromList ( [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] 57 | , [ (0, 1, 1), (0, 2, 1), (1, 3, 1), (2, 4, 1), (4, 5, 1), (3, 5, 1), (3, 6, 1), (6, 7, 1) 58 | , (6, 8, 1), (7, 9, 1), (8, 10, 1), (9, 11, 1), (10, 11, 1), (8, 12, 1) 59 | ] 60 | ) 61 | 62 | cycleAndTriangle :: GenericGraph Int Int 63 | cycleAndTriangle = fromList ( [0, 0, 0, 0, 0, 0, 0, 0, 0, 0] 64 | , [ (0, 1, 1), (0, 2, 1), (1, 3, 1), (2, 4, 1), (3, 4, 1), (4, 5, 1), (5, 6, 1), (6, 7, 1) 65 | , (7, 8, 1), (7, 9, 1), (8, 9, 1) 66 | ] 67 | ) 68 | 69 | triangleAndTriangle :: GenericGraph Int Int 70 | triangleAndTriangle = fromList ( [0, 0, 0, 0, 0, 0, 0] 71 | , [(0, 1, 1), (0, 2, 1), (1, 2, 1), (1, 3, 1), (3, 4, 1), (3, 5, 1), (4, 5, 1)] 72 | ) 73 | 74 | testIsIsoSub :: SpecWith () 75 | testIsIsoSub = describe "Check whether subgraph isomorphism algorithm is working correctly" $ do 76 | it "Path" $ do 77 | graph <- fmap (M.! "only_path") testMap 78 | graph `shouldSatisfy` isIsoSub pathGraph 79 | uiIsoEqRiIso pathGraph graph 80 | it "Conjugated cycles" $ do 81 | graph <- fmap (M.! "only_cycles") testMap 82 | graph `shouldSatisfy` isIsoSub conjugatedCycles 83 | uiIsoEqRiIso conjugatedCycles graph 84 | it "Connected cycles" $ do 85 | graph <- fmap (M.! "simple_drawing") testMap 86 | graph `shouldSatisfy` isIsoSub connectedCycles 87 | uiIsoEqRiIso connectedCycles graph 88 | it "Conjugated cycles again" $ do 89 | graph <- fmap (M.! "hard_drawing") testMap 90 | graph `shouldSatisfy` isIsoSub conjugatedCycles 91 | uiIsoEqRiIso conjugatedCycles graph 92 | it "Cycle and triangle" $ do 93 | graph <- fmap (M.! "paths_through_conjugated_cycles") testMap 94 | graph `shouldSatisfy` isIsoSub cycleAndTriangle 95 | uiIsoEqRiIso cycleAndTriangle graph 96 | it "Big graph" $ do 97 | graph <- fmap (M.! "takes_long_if_done_wrong") testMap 98 | graph `shouldSatisfy` isIsoSub bigSubGraph 99 | uiIsoEqRiIso bigSubGraph graph 100 | it "Triangle and triangle. No match" $ do 101 | graph <- fmap (M.! "paths_through_conjugated_cycles") testMap 102 | graph `shouldNotSatisfy` isIsoSub triangleAndTriangle 103 | uiIsoEqRiIso triangleAndTriangle graph 104 | it "Cycle and triangle. No match" $ do 105 | graph <- fmap (M.! "simple_drawing") testMap 106 | graph `shouldNotSatisfy` isIsoSub cycleAndTriangle 107 | uiIsoEqRiIso cycleAndTriangle graph 108 | 109 | uiIsoEqRiIso :: GenericGraph Int Int -> GenericGraph Int Int -> Expectation 110 | uiIsoEqRiIso query target = do 111 | mapM_ (`shouldSatisfy` isValidIso query target) uiIsos 112 | mapM_ (`shouldSatisfy` isValidIso query target) riIsos 113 | length uiIsos `shouldBe` length riIsos 114 | toIsoList uiIsos `shouldBe` toIsoList riIsos 115 | where 116 | uiIsos = UI.getMultiIso query target 117 | riIsos = RI.getMultiIso query target 118 | 119 | toIsoList = sort . fmap (sort . M.toList) 120 | 121 | isValidIso :: GenericGraph Int Int -> GenericGraph Int Int -> Map Int Int -> Bool 122 | isValidIso query target iso = vsEq && esEq 123 | where 124 | (queryVs, queryEs) = toList query 125 | targetVs = fst $ toList target 126 | 127 | vsEq = all (uncurry (==) . ((queryVs !!) *** (targetVs !!))) $ M.toList iso 128 | esEq = all (\(v1, v2, t) -> t == getEdge target (iso M.! v1) (iso M.! v2)) queryEs 129 | 130 | 131 | main :: IO () 132 | main = hspec testIsIsoSub 133 | -------------------------------------------------------------------------------- /src/Math/Grads/Drawing/Internal/CyclesPathsAlignment.hs: -------------------------------------------------------------------------------- 1 | -- | Module that is responsible for linking systems of conjugated cycles in graph 2 | -- with paths between them. 3 | -- 4 | module Math.Grads.Drawing.Internal.CyclesPathsAlignment 5 | ( alignCyclesAndPaths 6 | , bondsToAlignTo 7 | , bondsToAlignToExtreme 8 | ) where 9 | 10 | import Control.Arrow (first, second, (***)) 11 | import Data.Either (partitionEithers) 12 | import Data.List (find) 13 | import Data.Maybe (catMaybes, listToMaybe) 14 | import Linear.Matrix ((!*)) 15 | import Linear.Metric (dot, norm) 16 | import Linear.V2 (V2 (..)) 17 | import Linear.Vector (negated, (*^)) 18 | import Math.Grads.Algo.Paths (findBeginnings) 19 | import Math.Grads.Angem (alignmentFunc, rotation2D) 20 | import Math.Grads.Drawing.Internal.Coords (bondLength) 21 | import Math.Grads.Drawing.Internal.Utils (Coord, CoordList, 22 | cleanCoordList, 23 | tupleToList) 24 | import Math.Grads.Graph (EdgeList) 25 | 26 | type CoordsEnds e = (CoordList e, EdgeList e) 27 | 28 | -- | Given cycles and paths between them unites everything into one structure if possible. 29 | -- 30 | alignCyclesAndPaths :: Eq e => [CoordList e] -> [CoordList e] -> Maybe (CoordList e) 31 | alignCyclesAndPaths paths cycles = greedyAlignmentOfCyclesAndPaths (cyclesWithRestoredEnds ++ pathsWithRestoredEnds) 32 | where 33 | cyclesWithRestoredEnds = fmap linksForCycle cycles 34 | pathsWithRestoredEnds = fmap linksForPath paths 35 | 36 | linksForCycle :: CoordList e -> (CoordList e, EdgeList e) 37 | linksForCycle thisCycle = (thisCycle, findBondsToFind (fmap fst thisCycle)) 38 | 39 | linksForPath :: CoordList e -> (CoordList e, EdgeList e) 40 | linksForPath thisPath = (thisPath, helper' (fmap fst thisPath)) 41 | 42 | helper' :: EdgeList e -> EdgeList e 43 | helper' pathBondList = if length pathBondList == 1 then pathBondList 44 | else findBondsToFind pathBondList 45 | 46 | greedyAlignmentOfCyclesAndPaths :: Eq e => [(CoordList e, EdgeList e)] -> Maybe (CoordList e) 47 | greedyAlignmentOfCyclesAndPaths [] = Nothing 48 | greedyAlignmentOfCyclesAndPaths [x] = Just (fst x) 49 | greedyAlignmentOfCyclesAndPaths (thisPart : otherParts) = if not (null toAdd) then res 50 | else Nothing 51 | where 52 | theseCoords = fst thisPart 53 | bondsToFind = snd thisPart 54 | alignedNeighbors = fmap (detectAndAlignNeighbors bondsToFind theseCoords) otherParts 55 | 56 | (toAdd, leftParts) = first concat (partitionEithers alignedNeighbors) 57 | 58 | newTheseCoords = cleanCoordList (toAdd ++ theseCoords) [] 59 | 60 | edgeList = fmap fst newTheseCoords 61 | newBondsToFind = findBondsToFind edgeList 62 | 63 | res = greedyAlignmentOfCyclesAndPaths ((newTheseCoords, newBondsToFind) : leftParts) 64 | 65 | detectAndAlignNeighbors :: Eq e => EdgeList e -> CoordList e -> CoordsEnds e -> Either (CoordList e) (CoordsEnds e) 66 | detectAndAlignNeighbors bondsToFind theseCoords theseCoordsEnds = maybe (Right theseCoordsEnds) Left neighsOrLeft 67 | where 68 | neighsOrLeft = detectAndAlignNeighborsM bondsToFind theseCoords theseCoordsEnds 69 | 70 | detectAndAlignNeighborsM :: Eq e => EdgeList e -> CoordList e -> CoordsEnds e -> Maybe (CoordList e) 71 | detectAndAlignNeighborsM bondsToFind theseCoords (coords, ends) = do 72 | let found' = catMaybes (fmap (\x -> find (== x) bondsToFind) ends) 73 | found <- listToMaybe found' 74 | 75 | let findBondToAlign = find (\(a, _) -> a == found) 76 | 77 | alignCoords <- coordToList <$> findBondToAlign theseCoords 78 | toAlignCoords <- coordToList <$> findBondToAlign coords 79 | 80 | let alignFunc = alignmentFunc alignCoords toAlignCoords 81 | 82 | Just (fmap (second (alignFunc *** alignFunc)) coords) 83 | where 84 | coordToList :: Coord e -> [V2 Float] 85 | coordToList = tupleToList . snd 86 | 87 | findBondsToFind :: EdgeList e -> EdgeList e 88 | findBondsToFind bonds = catMaybes ((\ind -> find (\(a, b, _) -> a == ind || b == ind) bonds) <$> findBeginnings bonds) 89 | 90 | -- | Constructs edge that will be used to align to cycle containing given 'Coord's. 91 | -- 92 | bondsToAlignTo :: Coord e -> Coord e -> Int -> [(V2 Float, V2 Float)] 93 | bondsToAlignTo ((a, b, _), (pointA, pointB)) ((a', b', _), (pointA', pointB')) number = resultingVectors 94 | where 95 | coordA = pointB - pointA 96 | coordB = pointB' - pointA' 97 | ((vecA, vecB), linkingPoint) | a == a' = ((negated coordA, negated coordB), pointA) 98 | | a == b' = ((negated coordA, coordB), pointA) 99 | | b == a' = ((coordA, negated coordB), pointB) 100 | | otherwise = ((coordA, coordB), pointB) 101 | 102 | direction' = vecA + vecB 103 | direction = (bondLength / norm direction') *^ direction' 104 | toTopAngle = (180.0 - 180.0 * acos (dot vecA vecB / (norm vecA * norm vecB)) / pi) / 2.0 105 | angle' = 180.0 / fromIntegral number 106 | startingAngle = (180.0 - (fromIntegral number - 1.0) * angle') / 2.0 107 | 108 | dirA = dot (start (toTopAngle + startingAngle)) direction 109 | dirB = dot (start (-(toTopAngle + startingAngle))) direction 110 | startingPoint | dirA >= 0 && dirB >= 0 && dirA > dirB = start (toTopAngle + startingAngle) 111 | | dirA >= 0 && dirB >= 0 = start (-(toTopAngle + startingAngle)) 112 | | dirA >= 0 = start (toTopAngle + startingAngle) 113 | | otherwise = start (-(toTopAngle + startingAngle)) 114 | 115 | mult = if dot (start (toTopAngle + startingAngle)) direction > 0 then 1 else (-1) 116 | resultingVectors = (\x -> (linkingPoint, linkingPoint + x)) <$> getDirections startingPoint 1 angle' number mult 117 | 118 | start :: Float -> V2 Float 119 | start angle = rotation2D angle !* ((bondLength / norm vecA) *^ negated vecA) 120 | 121 | -- | If we have complicated situation where we need to calculate bonds to align to 122 | -- for vertex in cycle that has more then 2 neighbors then we pass direction in 123 | -- which we want to place neighbors and use bondsToAlignToExtreme function. 124 | -- Otherwise we use bondsToAlignTo function. 125 | -- 126 | bondsToAlignToExtreme :: (V2 Float, V2 Float) -> Int -> [(V2 Float, V2 Float)] 127 | bondsToAlignToExtreme (beg, end) number = resultingVectors 128 | where 129 | direction = end - beg 130 | startingPointComplicated = rotation2D (-40.0) !* ((bondLength / norm direction) *^ direction) 131 | resultingVectors = (\x -> (beg, beg + x)) <$> getDirections startingPointComplicated 1 47.0 number 1 132 | 133 | getDirections :: V2 Float -> Int -> Float -> Int -> Float -> [V2 Float] 134 | getDirections prev counter angle number mult = if counter < number then prev : getDirections new (counter + 1) angle number mult 135 | else [prev] 136 | where 137 | new = rotation2D (mult * angle) !* prev 138 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/Cycles.hs: -------------------------------------------------------------------------------- 1 | -- | Module that provides functions for analysis of graph's cycles. 2 | -- 3 | module Math.Grads.Algo.Cycles 4 | ( findCycles 5 | , findSimpleCycles 6 | , findLocalCycles 7 | , getCyclic 8 | , isEdgeInCycle 9 | ) where 10 | 11 | import Control.Monad.State (State, runState) 12 | import Control.Monad.State.Class (get, modify) 13 | import Data.List (partition, sort, union, (\\)) 14 | import Data.Map.Strict (Map) 15 | import qualified Data.Map.Strict as M (keys, (!)) 16 | import Data.Set (Set) 17 | import qualified Data.Set as S (empty, fromList, insert, 18 | member) 19 | import Math.Grads.Algo.Interaction (edgeListToMap, getEnds, 20 | getIndices, getOtherEnd, 21 | getVertexIncident, haveSharedEdge, 22 | matchEdges) 23 | import Math.Grads.Algo.Paths (dfsAllPaths) 24 | import Math.Grads.GenericGraph (GenericGraph, safeIdx) 25 | import Math.Grads.Graph (EdgeList, GraphEdge, vCount) 26 | 27 | -- | Takes 'EdgeList' and finds non-redundant set of conjugated simple cycles. 28 | -- Cycles sharing in common one edge are considered to be one cycle. 29 | -- BondList must obey rule (b, e, _) b < e. 30 | -- 31 | findCycles :: Ord e => EdgeList e -> [EdgeList e] 32 | findCycles bonds = sort <$> conjRings redundantCycles 33 | where 34 | redundantCycles = findCyclesR bonds 35 | 36 | findCyclesR :: Ord e => EdgeList e -> [EdgeList e] 37 | findCyclesR bs = let (result, taken) = stateCycles bs in 38 | if sort taken == sort bs then result 39 | else result ++ findCyclesR (bs \\ taken) 40 | 41 | stateCycles :: Ord e => EdgeList e -> ([EdgeList e], EdgeList e) 42 | stateCycles bs = runState (cyclesHelper bs [] (minimum (getIndices bs))) [] 43 | 44 | conjRings :: Ord e => [EdgeList e] -> [EdgeList e] 45 | conjRings (b : bs) = 46 | let 47 | (shd, rest) = partition (haveSharedEdge b) bs 48 | in 49 | case shd of 50 | [] -> b : conjRings rest 51 | _ -> conjRings $ foldr union b shd : rest 52 | conjRings b = b 53 | 54 | takeCycle :: EdgeList e -> GraphEdge e -> EdgeList e 55 | takeCycle [] _ = [] 56 | takeCycle bl@((aPop, bPop, _) : _) bn@(aNow, bNow, _) = bn : takeWhile cond bl ++ take 1 (dropWhile cond bl) 57 | where 58 | theB | bPop == aNow = bNow 59 | | bPop == bNow = aNow 60 | | aPop == bNow = aNow 61 | | otherwise = bNow 62 | cond :: GraphEdge e -> Bool 63 | cond (a', b', _) = theB /= a' && theB /= b' 64 | 65 | cyclesHelper :: Eq e => EdgeList e -> EdgeList e -> Int -> State (EdgeList e) [EdgeList e] 66 | cyclesHelper bs trc n = do 67 | curSt <- get 68 | let adjBonds = filter (`notElem` curSt) $ getVertexIncident bs n 69 | 70 | let visited = concatMap getEnds curSt 71 | let curBondClosures = filter (\b -> getOtherEnd b n `elem` visited) adjBonds 72 | let furtherBonds = filter (`notElem` curBondClosures) adjBonds 73 | 74 | let procBnd bnd = cyclesHelper bs (bnd : trc) (getOtherEnd bnd n) 75 | restBondClosures <- mapM (\b -> modify (b:) >>= const (procBnd b)) furtherBonds 76 | 77 | return $ (takeCycle trc <$> curBondClosures) ++ concat restBondClosures 78 | 79 | -- | Checks that edge with given index in 'EdgeList' is contained in any cycle. 80 | -- 81 | isEdgeInCycle :: Ord e => EdgeList e -> Int -> Bool 82 | isEdgeInCycle bs n = any ((bs !! n) `elem`) $ findCycles bs 83 | 84 | -- | Finds all cycles of minimal length contained in system of conjugated cycles. 85 | -- 86 | findLocalCycles :: Eq e => EdgeList e -> [EdgeList e] 87 | findLocalCycles bonds = if null cycles then [] 88 | else helperFilter (tail res) [head res] 89 | where 90 | -- TODO: We need to remove this filter. 91 | cycles = filter (\x -> length x < 21) (findSimpleCycles bonds) 92 | res = filter (`filterBigCycles` cycles) cycles 93 | 94 | -- | Finds all simple cycles in fused cycles system. 95 | -- 96 | findSimpleCycles :: Eq e => EdgeList e -> [EdgeList e] 97 | findSimpleCycles bonds = concatMap (\(a, b, _) -> dfsAllPaths bonds a b) cycleBonds 98 | where 99 | stBonds = dfsSt bonds 100 | cycleBonds = bonds \\ stBonds 101 | 102 | dfsSt :: EdgeList e -> EdgeList e 103 | dfsSt bs = matchEdges bs bondsInd 104 | where 105 | graph = edgeListToMap bs 106 | bondsInd = dfsSt' graph (M.keys graph) [] [] 107 | 108 | dfsSt' :: Map Int [Int] -> [Int] -> [Int] -> [(Int, Int)] -> [(Int, Int)] 109 | dfsSt' _ [] _ bs = bs 110 | dfsSt' graph (current : toVisit) visited bs | current `elem` visited = dfsSt' graph toVisit visited bs 111 | | otherwise = dfsSt' graph toVisitModified (current:visited) visitedBonds 112 | where 113 | visitedBonds = bs ++ if not (null visited) then [found | snd found /= -1] else [] 114 | found = findRib graph visited current 115 | 116 | toVisitModified = (graph M.! current) ++ toVisit 117 | 118 | findRib :: Map Int [Int] -> [Int] -> Int -> (Int, Int) 119 | findRib graph visited current = (current, if not (null found) then head found else -1) 120 | where 121 | found = filter (`elem` visited) (graph M.! current) 122 | 123 | filterBigCycles :: Eq e => EdgeList e -> [EdgeList e] -> Bool 124 | filterBigCycles currentCycle cycles = not (foldl (\x y -> x || currentCycle /= y && length currentCycle > length y && length (filter (`elem` currentCycle) y) > 1) False cycles) 125 | 126 | helperFilter :: Eq e => [EdgeList e] -> [EdgeList e] -> [EdgeList e] 127 | helperFilter [] ready = ready 128 | helperFilter (x:xs) ready = if exists x ready then helperFilter xs ready else helperFilter xs (x:ready) 129 | where 130 | exists a1 = any (\x' -> length a1 == length x' && all (\(a, b, t) -> (a, b, t) `elem` x' || (b, a, t) `elem` x') a1) 131 | 132 | -- | Checks whether or not given vertex belongs to any cycle. 133 | -- 134 | isCyclic :: GenericGraph v e -> Int -> Int -> (Bool, Set Int) -> Int -> (Bool, Set Int) 135 | isCyclic graph target previous (result, visited) current | result = (result, visited) 136 | | (previous /= (-1)) && (current == target) = (True, visited) 137 | | current `S.member` visited = (result, visited) 138 | | otherwise = foldl foldFunc (result, updatedVis) next 139 | where 140 | next :: [Int] 141 | next = filter (/= previous) $ graph `safeIdx` current 142 | 143 | updatedVis :: Set Int 144 | updatedVis = current `S.insert` visited 145 | 146 | foldFunc :: (Bool, Set Int) -> Int -> (Bool, Set Int) 147 | foldFunc = isCyclic graph target current 148 | 149 | -- | Returns the set of all vertices which belong to any cycle. 150 | -- 151 | getCyclic :: GenericGraph v e -> Set Int 152 | getCyclic graph = S.fromList . map fst . filter snd $ zip indices cyclic 153 | where 154 | indices :: [Int] 155 | indices = [0 .. vCount graph - 1] 156 | 157 | cyclic :: [Bool] 158 | cyclic = map (\ix -> fst $ isCyclic graph ix (-1) (False, S.empty) ix) indices 159 | -------------------------------------------------------------------------------- /src/Math/Grads/GenericGraph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | -- | Module that provides abstract implementation of graph-like data structure 6 | -- 'GenericGraph' and many helpful functions for interaction with 'GenericGraph'. 7 | -- 8 | module Math.Grads.GenericGraph 9 | ( GenericGraph (..) 10 | , addEdges 11 | , addVertices 12 | , applyG 13 | , applyV 14 | , getVertices 15 | , getEdge 16 | , isConnected 17 | , removeEdges 18 | , removeVertices 19 | , safeAt 20 | , safeIdx 21 | , subgraph, subgraphWithReindex 22 | , sumGraphs 23 | , typeOfEdge 24 | ) where 25 | 26 | import Control.Arrow (first) 27 | import Data.Aeson (FromJSON (..), ToJSON (..), defaultOptions, 28 | genericParseJSON, genericToJSON) 29 | import Data.Array (Array) 30 | import qualified Data.Array as A 31 | import Data.Bimap (Bimap) 32 | import qualified Data.Bimap as BM 33 | import Data.List (find, groupBy, sortBy) 34 | import Data.Map.Strict (Map, mapKeys, member, (!)) 35 | import qualified Data.Map.Strict as M 36 | import Data.Maybe (fromJust, fromMaybe, isJust) 37 | import qualified Data.Set as S 38 | import GHC.Generics (Generic) 39 | import Math.Grads.Graph (Graph (..)) 40 | 41 | 42 | -- | Generic undirected graph which stores elements of type v in its vertices (e.g. labels, atoms, states etc) 43 | -- and elements of type e in its edges (e.g. weights, bond types, functions over states etc). 44 | -- Note that loops and multiple edges between two vertices are allowed. 45 | -- 46 | data GenericGraph v e = GenericGraph { gIndex :: Array Int v -- ^ 'Array' that contains vrtices of graph 47 | , gRevIndex :: Map v Int -- ^ 'Map' that maps vertices to their indices 48 | , gAdjacency :: Array Int [(Int, e)] -- ^ adjacency 'Array' of graph 49 | } 50 | deriving (Generic) 51 | 52 | instance (Ord v, Eq e, ToJSON v, ToJSON e) => ToJSON (GenericGraph v e) where 53 | toJSON (toList -> l) = genericToJSON defaultOptions l 54 | 55 | instance (Ord v, Eq e, FromJSON v, FromJSON e) => FromJSON (GenericGraph v e) where 56 | parseJSON v = fromList <$> genericParseJSON defaultOptions v 57 | 58 | instance Graph GenericGraph where 59 | fromList :: (Ord v, Eq v) => ([v], [(Int, Int, e)]) -> GenericGraph v e 60 | fromList (vertices, edges) = GenericGraph idxArr revMap adjArr 61 | where 62 | count = length vertices 63 | idxArr = A.listArray (0, count - 1) vertices 64 | revMap = M.fromList $ zip vertices [0..] 65 | indices = concatMap insertFunc edges 66 | insertFunc (at, other, b) | at == other = [(at, (other, b))] 67 | | otherwise = [(at, (other, b)), (other, (at, b))] 68 | adjArr = A.accumArray (flip (:)) [] (0, count - 1) indices 69 | 70 | toList :: (Ord v, Eq v) => GenericGraph v e -> ([v], [(Int, Int, e)]) 71 | toList (GenericGraph idxArr _ adjArr) = (snd <$> A.assocs idxArr, edges) 72 | where 73 | edges = distinct . concatMap toEdges . A.assocs $ adjArr 74 | toEdges (k, v) = map (toAscending k) v 75 | toAscending k (a, b) | k > a = (a, k, b) 76 | | otherwise = (k, a, b) 77 | compare3 (at1, other1, _) (at2, other2, _) = compare (at1, other1) (at2, other2) 78 | eq3 v1 v2 = compare3 v1 v2 == EQ 79 | distinct = map head . groupBy eq3 . sortBy compare3 80 | 81 | vCount :: GenericGraph v e -> Int 82 | vCount (GenericGraph idxArr _ _) = length idxArr 83 | 84 | (!>) :: (Ord v, Eq v) => GenericGraph v e -> v -> [(v, e)] 85 | (GenericGraph idxArr revMap adjArr) !> at = first (idxArr A.!) <$> adjacent 86 | where 87 | idx = revMap ! at 88 | adjacent = adjArr A.! idx 89 | 90 | (?>) :: (Ord v, Eq v) => GenericGraph v e -> v -> Maybe [(v, e)] 91 | gr@(GenericGraph _ revMap _) ?> at | at `member` revMap = Just (gr !> at) 92 | | otherwise = Nothing 93 | 94 | 95 | (!.) :: GenericGraph v e -> Int -> [(Int, e)] 96 | (!.) (GenericGraph _ _ adjArr) = (adjArr A.!) 97 | 98 | (?.) :: GenericGraph v e -> Int -> Maybe [(Int, e)] 99 | gr@(GenericGraph _ _ adjArr) ?. idx | idx `inBounds` A.bounds adjArr = Just (gr !. idx) 100 | | otherwise = Nothing 101 | where 102 | -- | Check whether or not given value is betwen bounds. 103 | -- 104 | inBounds :: Ord a => a -> (a, a) -> Bool 105 | inBounds i (lo, hi) = (i >= lo) && (i <= hi) 106 | 107 | 108 | instance (Ord v, Eq v, Show v, Show e) => Show (GenericGraph v e) where 109 | show gr = unlines . map fancyShow . filter (\(a, b, _) -> a < b) . snd . toList $ gr 110 | where 111 | idxArr = gIndex gr 112 | fancyShow (at, other, bond) = concat [show $ idxArr A.! at, "\t", show bond, "\t", show $ idxArr A.! other] 113 | 114 | instance Functor (GenericGraph v) where 115 | fmap f (GenericGraph idxArr revMap adjArr) = GenericGraph idxArr revMap (((f <$>) <$>) <$> adjArr) 116 | 117 | instance Ord v => Semigroup (GenericGraph v e) where 118 | (<>) = sumGraphs 119 | 120 | instance (Ord v, Eq v) => Monoid (GenericGraph v e) where 121 | mempty = fromList ([], []) 122 | 123 | -- | 'fmap' which acts on adjacency lists of each vertex. 124 | -- 125 | applyG :: ([(Int, e1)] -> [(Int, e2)]) -> GenericGraph v e1 -> GenericGraph v e2 126 | applyG f (GenericGraph idxArr revMap adjArr) = GenericGraph idxArr revMap (f <$> adjArr) 127 | 128 | -- | 'fmap' which acts on vertices. 129 | -- 130 | applyV :: Ord v2 => (v1 -> v2) -> GenericGraph v1 e -> GenericGraph v2 e 131 | applyV f (GenericGraph idxArr revMap adjArr) = GenericGraph (f <$> idxArr) (mapKeys f revMap) adjArr 132 | 133 | -- | Get all vertices of the graph. 134 | -- 135 | getVertices :: GenericGraph v e -> [v] 136 | getVertices (GenericGraph idxArr _ _) = map snd $ A.assocs idxArr 137 | 138 | -- | Get subgraph on given vertices. Note that indexation will be CHANGED. 139 | -- Be careful with !. and ?. operators. 140 | -- 141 | subgraph :: Ord v => GenericGraph v e -> [Int] -> GenericGraph v e 142 | subgraph graph = snd . subgraphWithReindex graph 143 | 144 | -- | Get subgraph on given vertices and mapping from old `toKeep` indices to 145 | -- new indices of resulting subgraph. 146 | -- 147 | subgraphWithReindex :: Ord v => GenericGraph v e -> [Int] -> (Bimap Int Int, GenericGraph v e) 148 | subgraphWithReindex graph toKeep = (vMap, fromList (newVertices, newEdges)) 149 | where 150 | vSet :: S.Set Int 151 | vSet = S.fromList toKeep 152 | 153 | eRemain :: (Int, Int, e) -> Bool 154 | eRemain (at, other, _) = (at `S.member` vSet) && (other `S.member` vSet) 155 | 156 | (oldVertices, edges) = filter eRemain <$> toList graph 157 | (newVertices, oldIdx) = unzip . filter (\(_, ix) -> ix `S.member` vSet) $ zip oldVertices [0..] 158 | 159 | vMap :: Bimap Int Int 160 | vMap = BM.fromList $ zip oldIdx [0 ..] 161 | 162 | newEdges = map (\(at, other, bond) -> (vMap BM.! at, vMap BM.! other, bond)) edges 163 | 164 | -- | Add given vertices to graph. 165 | -- 166 | addVertices :: Ord v => GenericGraph v e -> [v] -> GenericGraph v e 167 | addVertices graph toAdd = fromList (first (++ toAdd) (toList graph)) 168 | 169 | -- | Remove given vertices from the graph. Note that indexation will be CHANGED. 170 | -- Be careful with !. and ?. operators. 171 | -- 172 | removeVertices :: Ord v => GenericGraph v e -> [Int] -> GenericGraph v e 173 | removeVertices graph toRemove = fromList (newVertices, newEdges) 174 | where 175 | vSet :: S.Set Int 176 | vSet = S.fromList toRemove 177 | 178 | eRemove :: (Int, Int, e) -> Bool 179 | eRemove (at, other, _) = (at `S.notMember` vSet) && (other `S.notMember` vSet) 180 | 181 | (oldVertices, edges) = filter eRemove <$> toList graph 182 | (newVertices, oldIdx) = unzip . filter ((`S.notMember` vSet) . snd) $ zip oldVertices [0..] 183 | 184 | vMap :: Map Int Int 185 | vMap = M.fromList $ zip oldIdx [0 ..] 186 | 187 | newEdges = map (\(at, other, bond) -> (vMap ! at, vMap ! other, bond)) edges 188 | 189 | -- | Remove given edges from the graph. Note that isolated vertices are allowed. 190 | -- This will NOT affect indexation. 191 | -- 192 | removeEdges :: Ord v => GenericGraph v e -> [(Int, Int)] -> GenericGraph v e 193 | removeEdges graph toRemove = fromList (vertices, edges) 194 | where 195 | eSet :: S.Set (Int, Int) 196 | eSet = S.fromList toRemove 197 | 198 | (vertices, edges) = filter eRemove <$> toList graph 199 | 200 | eRemove (at, other, _) = ((at, other) `S.notMember` eSet) && ((other, at) `S.notMember` eSet) 201 | 202 | -- | Add given edges to the graph. 203 | -- 204 | addEdges :: Ord v => GenericGraph v e -> [(Int, Int, e)] -> GenericGraph v e 205 | addEdges (GenericGraph inds rinds edges) toAdd = GenericGraph inds rinds res 206 | where 207 | accumList = foldl (\x (a, b, t) -> x ++ [(a, (b, t)), (b, (a, t))]) [] toAdd 208 | res = A.accum (flip (:)) edges accumList 209 | 210 | -- | Returns type of edge with given starting and ending indices. 211 | -- 212 | typeOfEdge :: Ord v => GenericGraph v e -> Int -> Int -> e 213 | typeOfEdge graph fromInd toInd = res 214 | where 215 | neighbors = gAdjacency graph A.! fromInd 216 | res = snd (fromJust (find ((== toInd) . fst) neighbors)) 217 | 218 | -- | Safe extraction from the graph. If there is no requested key in it, 219 | -- empty list is returned. 220 | -- 221 | safeIdx :: GenericGraph v e -> Int -> [Int] 222 | safeIdx graph = map fst . fromMaybe [] . (graph ?.) 223 | 224 | -- | Safe extraction from the graph. If there is no requested key in it, 225 | -- empty list is returned. 226 | -- 227 | safeAt :: GenericGraph v e -> Int -> [(Int, e)] 228 | safeAt graph = fromMaybe [] . (graph ?.) 229 | 230 | -- | Get edge from graph, which starting and ending indices match 231 | -- given indices. 232 | -- 233 | getEdge :: GenericGraph v e -> Int -> Int -> e 234 | getEdge graph from to = found 235 | where 236 | neighbors = graph !. from 237 | found = snd (fromJust (find ((== to) . fst) neighbors)) 238 | 239 | -- | Check that two vertices with given indexes have edge between them. 240 | -- 241 | isConnected :: GenericGraph v e -> Int -> Int -> Bool 242 | isConnected g fInd tInd = isJust $ find ((==) tInd . fst) $ safeAt g fInd 243 | 244 | -- | Returns graph that is the sum of two given graphs assuming that they are disjoint. 245 | -- 246 | sumGraphs :: Ord v => GenericGraph v e -> GenericGraph v e -> GenericGraph v e 247 | sumGraphs graphA graphB = res 248 | where 249 | (vertA, edgeA) = toList graphA 250 | (vertB, edgeB) = toList graphB 251 | renameMapB = M.fromList (zip [0..length vertB - 1] [length vertA..length vertA + length vertB - 1]) 252 | renameFunc = (renameMapB M.!) 253 | 254 | newVertices = vertA ++ vertB 255 | newEdges = edgeA ++ fmap (\(a, b, t) -> (renameFunc a, renameFunc b, t)) edgeB 256 | 257 | res = fromList (newVertices, newEdges) 258 | -------------------------------------------------------------------------------- /src/Math/Grads/Algo/Isomorphism/Ullman.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Math.Grads.Algo.Isomorphism.Ullman 6 | ( getMultiIso 7 | ) where 8 | 9 | import Control.Arrow (second, (&&&), (***)) 10 | import qualified Data.Array as A 11 | import Data.List (delete, sortOn) 12 | import Data.Map (Map) 13 | import qualified Data.Map.Strict as M 14 | import Data.Matrix (Matrix (..), getElem, 15 | getRow, mapRow, matrix, 16 | multStd, ncols, nrows, 17 | setElem, transpose) 18 | import Data.Tuple (swap) 19 | import qualified Data.Vector as V 20 | 21 | import Math.Grads.Algo.Isomorphism.Types (EComparator, 22 | GComparable (..), 23 | VComparator) 24 | import Math.Grads.GenericGraph (GenericGraph (..)) 25 | import Math.Grads.Graph (GraphEdge, changeIndsEdge, 26 | fromList, incidentIdx, 27 | toList, vCount, (!.)) 28 | import Math.Grads.Utils (nub) 29 | 30 | 31 | type GenericGraphIso v e = GenericGraph Int e 32 | 33 | getMultiIso :: (Ord v1, Ord v2, GComparable GenericGraph v1 e1 GenericGraph v2 e2, Eq e1, Eq e2) 34 | => GenericGraph v1 e1 -- ^ queryGraph 35 | -> GenericGraph v2 e2 -- ^ targetGraph 36 | -> [Map Int Int] 37 | getMultiIso queryGraph' targetGraph' = matches 38 | where 39 | ((queryGraph, queryGraphWI), fromIsoToOldQ) = second inverseMap $ graphToGraphIso queryGraph' 40 | ((targetGraph, targetGraphWI), fromIsoToOldT) = second inverseMap $ graphToGraphIso targetGraph' 41 | 42 | vComp = vComparator queryGraphWI targetGraphWI 43 | eComp = eComparator queryGraphWI targetGraphWI 44 | 45 | isos = isoGraph vComp eComp queryGraph targetGraph 46 | matches = fmap (\x -> getMatchMap x fromIsoToOldQ fromIsoToOldT) isos 47 | 48 | inverseMap :: Map Int Int -> Map Int Int 49 | inverseMap = M.fromList . (swap <$>) . M.toList 50 | 51 | getMatchMap :: Matrix Int -> Map Int Int -> Map Int Int -> Map Int Int 52 | getMatchMap isoMatrix fromIsoToOldQ fromIsoToOldT = res 53 | where 54 | forMap = fmap (getMatchRow isoMatrix) [0 .. nrows isoMatrix - 1] 55 | res = M.fromList (fmap ((fromIsoToOldQ M.!) *** (fromIsoToOldT M.!)) forMap) 56 | 57 | getMatchRow :: Matrix Int -> Int -> (Int, Int) 58 | getMatchRow isoMatrix ind = (ind, helper 0) 59 | where 60 | row = getRow (ind + 1) isoMatrix 61 | 62 | helper :: Int -> Int 63 | helper counter = if row V.! counter == 1 then counter 64 | else helper (counter + 1) 65 | 66 | isoGraph :: (Eq e1, Eq e2) => VComparator v1 v2 67 | -> EComparator e1 e2 68 | -> GenericGraphIso v1 e1 69 | -> GenericGraphIso v2 e2 70 | -> [Matrix Int] 71 | isoGraph vComp eComp queryGraph targetGraph = res 72 | where 73 | queryGraphEdges = (fst <$>) <$> gAdjacency queryGraph 74 | sizeOfQueryGraph = vCount queryGraph 75 | pMatrix = matrix sizeOfQueryGraph sizeOfQueryGraph (\(i, j) -> if i - 1 `elem` queryGraphEdges A.! (j - 1) then 1 else 0) 76 | 77 | targetGraphEdges = (fst <$>) <$> gAdjacency targetGraph 78 | sizeOfTargetGraph = vCount targetGraph 79 | gMatrix = matrix sizeOfTargetGraph sizeOfTargetGraph (\(i, j) -> if i - 1 `elem` targetGraphEdges A.! (j - 1) then 1 else 0) 80 | 81 | mMatrix = matrix sizeOfQueryGraph sizeOfTargetGraph (\(i, j) -> if fits vComp eComp queryGraph targetGraph i j then 1 else 0) 82 | 83 | currentRow = 0 84 | unusedColumns = [1 .. ncols mMatrix] 85 | 86 | res = recurse eComp queryGraph targetGraph unusedColumns currentRow gMatrix pMatrix mMatrix 87 | 88 | fits :: (Eq e1, Eq e2) => VComparator v1 v2 89 | -> EComparator e1 e2 90 | -> GenericGraphIso v1 e1 91 | -> GenericGraphIso v2 e2 92 | -> Int 93 | -> Int 94 | -> Bool 95 | fits vComp eComp queryGraph targetGraph i j = res 96 | where 97 | (vertex, edges) = (gIndex queryGraph A.! (i - 1), incidentIdx queryGraph $ i - 1) 98 | (vertex', edges') = (gIndex targetGraph A.! (j - 1), incidentIdx targetGraph $ j - 1) 99 | res = length edges <= length edges' && canBeSubset eComp edges edges' && vertex `vComp` vertex' 100 | 101 | canBeSubset :: forall e1 e2. EComparator e1 e2 -> [GraphEdge e1] -> [GraphEdge e2] -> Bool 102 | canBeSubset eComp query target = uniqueSeq maps 103 | where 104 | bondsInd = zip [0 ..] target 105 | maps = findMatches <$> query 106 | 107 | findMatches :: GraphEdge e1 -> [Int] 108 | findMatches thisEdge = fst <$> filter (\(_, otherEdge) -> eComp thisEdge otherEdge) bondsInd 109 | 110 | uniqueSeq :: [[Int]] -> Bool 111 | uniqueSeq maps = res 112 | where 113 | seqs = sequence maps 114 | 115 | res = any (\x -> length x == length (nub x)) seqs 116 | 117 | -- | Converts input graph into graph in which vertices with most amount of edges have lowest indices. 118 | -- 119 | graphToGraphIso :: (Ord v) => GenericGraph v e 120 | -> ((GenericGraphIso v e, GenericGraph v e), M.Map Int Int) 121 | graphToGraphIso graph = res 122 | where 123 | (vertices, edges) = toList graph 124 | vArr = gIndex graph 125 | 126 | indsWithNCount = fmap (id &&& (length . (graph !.))) [0 .. length vertices - 1] 127 | sortedInds = fst <$> sortOn (\x -> - (snd x)) indsWithNCount 128 | changesMap = M.fromList (zip sortedInds [0 ..]) 129 | 130 | sortedV = fmap (vArr A.!) sortedInds 131 | changedEdges = fmap (changeIndsEdge (changesMap M.!)) edges 132 | 133 | forGraphWI = (sortedV, changedEdges) 134 | forGraph = ([0 .. length sortedV - 1], changedEdges) 135 | 136 | res = ((fromList forGraph, fromList forGraphWI), changesMap) 137 | 138 | -- | Ullmann's subgraph isomorphism algorithm itself. 139 | -- 140 | recurse :: (Eq e1, Eq e2) => EComparator e1 e2 141 | -> GenericGraphIso v1 e1 142 | -> GenericGraphIso v2 e2 143 | -> [Int] 144 | -> Int 145 | -> Matrix Int 146 | -> Matrix Int 147 | -> Matrix Int 148 | -> [Matrix Int] 149 | recurse eComp queryGraph targetGraph unusedColumns currentRow gMatrix pMatrix mMatrix = res 150 | where 151 | prunedM = prune eComp queryGraph targetGraph mMatrix currentRow 152 | 153 | recs = concatMap pruneNext unusedColumns 154 | 155 | res | hasEmptyRow mMatrix = [] 156 | | currentRow == nrows mMatrix && isIsomorphism gMatrix pMatrix mMatrix = [mMatrix] 157 | | not (hasEmptyRow prunedM) = recs 158 | | otherwise = [] 159 | 160 | pruneNext :: Int -> [Matrix Int] 161 | pruneNext x = recurse eComp queryGraph targetGraph newColumns newRow gMatrix pMatrix changedMatrix 162 | where 163 | newColumns = delete x unusedColumns 164 | newRow = currentRow + 1 165 | changedMatrix = changeRow prunedM newRow x 166 | 167 | prune :: (Eq e1, Eq e2) => EComparator e1 e2 168 | -> GenericGraphIso v1 e1 169 | -> GenericGraphIso v2 e2 170 | -> Matrix Int 171 | -> Int 172 | -> Matrix Int 173 | prune eComp queryGraph targetGraph mMatrix currentRow | null indicesToChange = mMatrix 174 | | hasEmptyRow mMatrix = mMatrix 175 | | otherwise = res 176 | where 177 | numberOfMRows = nrows mMatrix 178 | numberOfMColumns = ncols mMatrix 179 | pairsOfindices = [(i, j) | i <- [1.. numberOfMRows], j <- [1.. numberOfMColumns], getElem i j mMatrix == 1] 180 | 181 | suitPair :: Int -> Int -> Bool 182 | suitPair = hasSuitableNeighbors eComp queryGraph targetGraph mMatrix 183 | 184 | indicesToChange = filter (not . uncurry suitPair) pairsOfindices 185 | changedMMatrix = foldl (flip (setElem 0)) mMatrix indicesToChange 186 | 187 | res = prune eComp queryGraph targetGraph changedMMatrix currentRow 188 | 189 | -- | Returns True if we can map all neighbors of query vertex to neighbors of target vertex in mMatrix. 190 | -- 191 | hasSuitableNeighbors :: forall v1 v2 e1 e2. (Eq e1, Eq e2) => EComparator e1 e2 192 | -> GenericGraphIso v1 e1 193 | -> GenericGraphIso v2 e2 194 | -> Matrix Int 195 | -> Int 196 | -> Int 197 | -> Bool 198 | hasSuitableNeighbors eComp queryGraph targetGraph mMatrix query target = doesSatisfy 199 | where 200 | iQ = query - 1 201 | iT = target - 1 202 | 203 | neighborsOfQ = (\(i, e) -> (iQ, i, e)) <$> queryGraph !. iQ 204 | neighborsOfT = (\(i, e) -> (iT, i, e)) <$> targetGraph !. iT 205 | 206 | hasProperNeighbor :: GraphEdge e1 -> Bool 207 | hasProperNeighbor edge = any (\edge' -> getProperElem edge edge' == 1 && eComp edge edge') neighborsOfT 208 | 209 | getProperElem :: GraphEdge e1 -> GraphEdge e2 -> Int 210 | getProperElem (_, b, _) (_, b', _) = getElem (b + 1) (b' + 1) mMatrix 211 | 212 | doesSatisfy = all hasProperNeighbor neighborsOfQ 213 | 214 | -- | Checks whether mMatrix encodes an isomorphism between pMatrix and gMatrix. 215 | -- 216 | isIsomorphism :: Matrix Int -- ^ gMatrix 217 | -> Matrix Int -- ^ pMatrix 218 | -> Matrix Int -- ^ mMatrix 219 | -> Bool 220 | isIsomorphism gMatrix pMatrix mMatrix = leqMatrices pMatrix check 221 | where 222 | check = multStd mMatrix (transpose (multStd mMatrix gMatrix)) 223 | 224 | -- | Componentwise "less or equal" operation for matrices. 225 | -- 226 | leqMatrices :: Matrix Int -> Matrix Int -> Bool 227 | leqMatrices matrixA matrixB = nrows matrixA * ncols matrixA <= nrows matrixB * ncols matrixB && helper elems 228 | where 229 | numOfRows = nrows matrixA 230 | numOfColumns = ncols matrixB 231 | elems = [(i, j) | i <- [1..numOfRows], j <- [1..numOfColumns]] 232 | helper = foldr (\x -> (&&) (uncurry getElem x matrixA <= uncurry getElem x matrixB)) True 233 | 234 | -- | Replace all elements in row with 0 apart from chosen one. 235 | -- 236 | changeRow :: Matrix Int -> Int -> Int -> Matrix Int 237 | changeRow mMatrix row column = mapRow helper row mMatrix 238 | where helper column' a = if column' /= column then 0 else a 239 | 240 | hasEmptyRow :: Matrix Int -> Bool 241 | hasEmptyRow prunedMatrix = cond 242 | where 243 | numberOfRows = nrows prunedMatrix 244 | cond = any (\x -> all (== 0) (getRow x prunedMatrix)) [1 .. numberOfRows] 245 | -------------------------------------------------------------------------------- /src/Math/Grads/Drawing/Internal/Cycles.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | Module that calculates coordinates of systems of conjugated cycles in graph. 4 | -- 5 | module Math.Grads.Drawing.Internal.Cycles 6 | ( getCoordsOfGlobalCycle 7 | ) where 8 | 9 | import qualified Data.Array as A 10 | import Data.List (find, 11 | groupBy, nub, 12 | sortOn) 13 | import qualified Data.Map.Strict as M 14 | import Data.Maybe (catMaybes, 15 | fromJust, 16 | isJust, 17 | mapMaybe) 18 | import Linear.Metric (distance, 19 | norm) 20 | import Linear.V2 (V2 (..)) 21 | import Linear.Vector ((*^), (^/)) 22 | import Math.Grads.Algo.Cycles (findLocalCycles) 23 | import Math.Grads.Algo.Interaction (getEnds, 24 | getIndices) 25 | import Math.Grads.Algo.Paths (findBeginnings) 26 | import Math.Grads.Algo.Traversals (dfsCycle) 27 | import Math.Grads.Angem (alignmentFunc) 28 | import Math.Grads.Drawing.Internal.Coords (Link, 29 | bondLength) 30 | import Math.Grads.Drawing.Internal.CyclesPathsAlignment (bondsToAlignTo, 31 | bondsToAlignToExtreme) 32 | import Math.Grads.Drawing.Internal.Utils (Coord, 33 | CoordList, 34 | centroid, 35 | cleanCoordList, 36 | cleanListOfCoordLists, 37 | compareCoords, 38 | findIncidentCoords, 39 | reflectCycle, 40 | tupleToList) 41 | import Math.Grads.GenericGraph (gAdjacency, 42 | gIndex) 43 | import Math.Grads.Graph (EdgeList, 44 | GraphEdge, 45 | fromList, 46 | vCount) 47 | import Math.Grads.Utils (uniter) 48 | 49 | -- | Calculates coordinates of system of cycles and coordinates of edges that are adjacent to it. 50 | -- 51 | getCoordsOfGlobalCycle :: Eq e => [CoordList e] -> EdgeList e -> Maybe (CoordList e) 52 | getCoordsOfGlobalCycle paths globalCycle = if not (null localCycles) && isJust alignedM then Just res 53 | else Nothing 54 | where 55 | localCycles = findLocalCycles globalCycle 56 | 57 | localCyclesWithCoords = sortOn (\x -> - (length x)) (fmap getCoordsOfLocalCycle localCycles) 58 | alignedM = greedyAlignmentOfLocalCycles [head localCyclesWithCoords] (tail localCyclesWithCoords) 59 | 60 | aligned = fromJust alignedM 61 | cleanAligned = cleanCoordList (concat aligned) [] 62 | 63 | res = restoreEndsForCycle cleanAligned paths aligned 64 | 65 | getCoordsOfLocalCycle :: EdgeList e -> CoordList e 66 | getCoordsOfLocalCycle thisCycle = matchBonds thisCycle (getCoordsOfPolygon (length thisCycle)) 67 | 68 | getCoordsOfPolygon :: Int -> [(V2 Float, V2 Float)] 69 | getCoordsOfPolygon number = let coords = fmap getPoint [0..number - 1] in (last coords, head coords) : uniter coords 70 | where 71 | angle = 2 * pi / fromIntegral number 72 | radius = bondLength / sin (angle / 2) / 2 73 | 74 | getPoint :: Int -> V2 Float 75 | getPoint step = V2 (radius * cos (fromIntegral step * angle)) (radius * sin (fromIntegral step * angle)) 76 | 77 | uniteLocalCyclesOnBond :: Coord e -> Coord e -> CoordList e -> CoordList e 78 | uniteLocalCyclesOnBond (_, coords) (_, coords') toTransformCoords = transformFuncCoord <$> toTransformCoords 79 | where 80 | transformFunc' = alignmentFunc (tupleToList coords) (tupleToList coords') 81 | transformFuncCoord (bond, (a, b)) = (bond, (transformFunc' a, transformFunc' b)) 82 | 83 | matchBonds :: EdgeList e -> [(V2 Float, V2 Float)] -> CoordList e 84 | matchBonds bonds coords = matchBonds' bonds (zip bondsInd coords) 85 | where 86 | vertices = nub $ concatMap getEnds bonds 87 | index = M.fromList (zip vertices [0..]) 88 | graph = fromList (vertices, fmap (\(a, b, t) -> (index M.! a, index M.! b, t)) bonds) 89 | graphArray = fmap fst <$> gAdjacency graph 90 | 91 | inds = (gIndex graph A.!) <$> dfsCycle graphArray [0 .. (vCount graph - 1)] [] 92 | bondsInd = uniter inds ++ [(last inds, head inds)] 93 | 94 | matchBonds' :: EdgeList e -> [((Int, Int), (V2 Float, V2 Float))] -> CoordList e 95 | matchBonds' bonds match = fmap (changeCoords match) bonds 96 | 97 | changeCoords :: [((Int, Int), (V2 Float, V2 Float))] -> GraphEdge e -> Coord e 98 | changeCoords [] _ = error "No matching coords in changeCoords function." 99 | changeCoords (((a', b'), (left, right)) : xs) bond@(a, b, _) | a == a' && b == b' = (bond, (left, right)) 100 | | a == b' && b == a' = (bond, (right, left)) 101 | | otherwise = changeCoords xs bond 102 | 103 | greedyAlignmentOfLocalCycles :: forall e. Eq e => [CoordList e] -> [CoordList e] -> Maybe [CoordList e] 104 | greedyAlignmentOfLocalCycles mainCycles [] = Just mainCycles 105 | greedyAlignmentOfLocalCycles mainCycles xs = if isJust idOfNeighborM then res 106 | else Nothing 107 | where 108 | neighborExists = fmap checkForNeighbor xs 109 | idOfNeighborM = helper neighborExists 0 110 | 111 | idOfNeighbor = fromJust idOfNeighborM 112 | neighbor = (xs !! idOfNeighbor) 113 | 114 | x = concat mainCycles 115 | matches = catMaybes (concatMap findMatchingBond x) 116 | (coordsA, coordsB) = head matches 117 | 118 | reflectedIfNeeded = reflectIfIntersects (uniteLocalCyclesOnBond coordsA coordsB neighbor) mainCycles (snd coordsA) 119 | finalCycle = correctLeftMatches (snd <$> tail matches) reflectedIfNeeded x 120 | 121 | res = greedyAlignmentOfLocalCycles (finalCycle : mainCycles) (take idOfNeighbor xs ++ drop (idOfNeighbor + 1) xs) 122 | 123 | findMatchingBond :: Coord e -> [Maybe (Coord e, Coord e)] 124 | findMatchingBond thisBond = fmap (hasMatch thisBond) neighbor 125 | 126 | hasMatch :: Coord e -> Coord e -> Maybe (Coord e, Coord e) 127 | hasMatch thisBond otherBond = if compareCoords thisBond otherBond then Just (thisBond, otherBond) 128 | else Nothing 129 | 130 | checkForNeighbor :: CoordList e -> Bool 131 | checkForNeighbor = any (\otherCoord -> any (compareCoords otherCoord) x) 132 | 133 | helper :: [Bool] -> Int -> Maybe Int 134 | helper [] _ = Nothing -- No neighbors for cycle in one conjugated cycle with it. 135 | -- Theoretically it is impossible, but due to the nature of our findLocalCycles function this can happen 136 | helper (y : ys) counter = if y then Just counter else helper ys (counter + 1) 137 | 138 | reflectIfIntersects :: CoordList e -> [CoordList e] -> (V2 Float, V2 Float) -> CoordList e 139 | reflectIfIntersects thisCycle allCycles (coordA, coordB) = if intersects then reflectCycle thisCycle (coordA, coordB) 140 | else thisCycle 141 | where 142 | thisCentroid = centroid thisCycle 143 | otherCentroids = centroid <$> allCycles 144 | intersects = any (\x -> distance x thisCentroid <= bondLength) otherCentroids 145 | 146 | correctLeftMatches :: forall e. Eq e => [Coord e] -> CoordList e -> CoordList e -> CoordList e 147 | correctLeftMatches [] thisCycle _ = thisCycle 148 | correctLeftMatches ((bond@(beg, end, _), _) : xs) thisCycle mainCycles = correctLeftMatches xs thisCycleUpdated mainCycles 149 | where 150 | thisCycleUpdated = catMaybes (fmap correctMatch thisCycle) 151 | 152 | correctMatch :: Coord e -> Maybe (Coord e) 153 | correctMatch coord@(bond'@(a, b, t'), (coordA, coordB)) | bond == bond' = Nothing 154 | | beg == a || end == a = Just ((a, b, t'), (substitute coordA a, coordB)) 155 | | beg == b || end == b = Just ((a, b, t'), (coordA, substitute coordB b)) 156 | | otherwise = Just coord 157 | 158 | substitute :: V2 Float -> Int -> V2 Float 159 | substitute varCoord endToFix = 160 | let 161 | x = mapMaybe (helper endToFix) mainCycles 162 | in if not (null x) then head x 163 | else varCoord 164 | 165 | helper :: Int -> Coord e -> Maybe (V2 Float) 166 | helper endToFix ((a', b', _), (coordA', coordB')) | a' == endToFix = Just coordA' 167 | | b' == endToFix = Just coordB' 168 | | otherwise = Nothing 169 | 170 | restoreEndsForCycle :: Eq e => CoordList e -> [CoordList e] -> [CoordList e] -> CoordList e 171 | restoreEndsForCycle thisCycle [[]] _ = thisCycle 172 | restoreEndsForCycle thisCycle paths localCycles = thisCycle ++ concat neighbors 173 | where 174 | verticesOfCycle = getIndices (fmap fst thisCycle) 175 | cycleLinkingCoords = mapMaybe (findLinks verticesOfCycle) paths 176 | counted = countNeighbors' cycleLinkingCoords 177 | neighbors = fmap (getLinksWithCoords thisCycle localCycles) counted 178 | 179 | countNeighbors' :: [(Int, GraphEdge e)] -> [(Int, EdgeList e)] 180 | countNeighbors' list = (\x -> let (a, b) = unzip x in (head a, b)) <$> groupBy (\a b -> fst a == fst b) list 181 | 182 | findLinks :: [Int] -> CoordList e -> Maybe (Link e) 183 | findLinks verticesOfCycle path = if not (null found) then Just (foundVertex, fst (fromJust bond)) 184 | else Nothing 185 | where 186 | found = filter (`elem` verticesOfCycle) (findBeginnings (fmap fst path)) 187 | foundVertex = head found 188 | bond = find (\((a, b, _), _) -> a == foundVertex || b == foundVertex) path 189 | 190 | getLinksWithCoords :: forall e. Eq e => CoordList e -> [CoordList e] -> (Int, EdgeList e) -> CoordList e 191 | getLinksWithCoords thisCycle localCycles (ind, bonds) = res 192 | where 193 | found = findAdjacentBondsCycles thisCycle localCycles ind 194 | 195 | bondsLength = length bonds 196 | alignedBonds = either (\(f, s) -> bondsToAlignTo f s bondsLength) (flip bondsToAlignToExtreme bondsLength) found 197 | 198 | res = assignCoords bonds alignedBonds ind 199 | 200 | assignCoords :: EdgeList e -> [(V2 Float, V2 Float)] -> Int -> CoordList e 201 | assignCoords [] _ _ = [] 202 | assignCoords (x@(a, _, _) : xs) (y@(left, right) : ys) start = if a == start then (x, y) : assignCoords xs ys start 203 | else (x, (right, left)) : assignCoords xs ys start 204 | assignCoords _ _ _ = error "Can not assign coords while restoring ends for cycle." 205 | 206 | findAdjacentBondsCycles :: forall e. Eq e => CoordList e -> [CoordList e] -> Int -> Either (Coord e, Coord e) (V2 Float, V2 Float) 207 | findAdjacentBondsCycles bondsOfCycle cycles ind = if length neighbors == 2 then Left (leftNeighbor, rightNeighbor) 208 | else Right (beginning, beginning + bondLength *^ direction ^/ norm direction) 209 | where 210 | neighbors = findIncidentCoords ind bondsOfCycle 211 | 212 | [leftNeighbor, rightNeighbor] = take 2 neighbors 213 | 214 | cyclesInPlay = cleanListOfCoordLists (filter (\x -> any (`elem` x) neighbors) cycles) [] 215 | beginning = findCommonVertexCoord leftNeighbor rightNeighbor 216 | direction = (beginning - centroid (head cyclesInPlay)) + (beginning - centroid (last cyclesInPlay)) 217 | 218 | findCommonVertexCoord :: Coord e -> Coord e -> V2 Float 219 | findCommonVertexCoord ((a, b, _), (coordA, coordB)) ((a', b', _), _) | a == a' = coordA 220 | | a == b' = coordA 221 | | b == a' = coordB 222 | | otherwise = coordB 223 | -------------------------------------------------------------------------------- /src/Math/Grads/Drawing/Internal/Paths.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | Module that calculates coordinates of paths between systems of conjugated cycles in graph. 4 | -- 5 | module Math.Grads.Drawing.Internal.Paths 6 | ( findPaths 7 | , getCoordsOfPath 8 | ) where 9 | 10 | import Data.List (delete, find, 11 | intersect, 12 | maximumBy, 13 | union, (\\)) 14 | import Data.Map.Strict (fromList, 15 | (!)) 16 | import Data.Maybe (catMaybes, 17 | fromJust, 18 | isJust) 19 | import Data.Ord (comparing) 20 | import Linear.V2 (V2 (..)) 21 | import Math.Grads.Algo.Interaction (getIndices, getSharedVertex, 22 | getVertexIncident, 23 | isIncident) 24 | import Math.Grads.Algo.Paths (dfsSearch, findBeginnings) 25 | import Math.Grads.Algo.Traversals (dfs) 26 | import Math.Grads.Angem (alignmentFunc) 27 | import Math.Grads.Drawing.Internal.Coords (Link, 28 | bondLength) 29 | import Math.Grads.Drawing.Internal.CyclesPathsAlignment (bondsToAlignTo) 30 | import Math.Grads.Drawing.Internal.Utils (Coord, 31 | CoordList, 32 | findIncidentCoords, 33 | tupleToList) 34 | import Math.Grads.Graph (EdgeList, 35 | GraphEdge) 36 | type BondV2 = (V2 Float, V2 Float) 37 | 38 | type PathWithLinks e = (CoordList e, [Link e]) 39 | 40 | data Path e = Path { 41 | pStart :: Int, 42 | pFinish :: Int, 43 | pBonds :: EdgeList e 44 | } 45 | 46 | -- | Calculates coordinates of path. 47 | -- 48 | getCoordsOfPath :: forall e. Eq e => EdgeList e -> CoordList e 49 | getCoordsOfPath bonds = fst (greedy pathWithCoords) 50 | where 51 | paths = splitPathIntoLongest bonds [] 52 | pathsWithCoords = fmap (\Path { pBonds=bonds' } -> pathToCoords bonds') paths 53 | pathWithCoords = zip pathsWithCoords (getLinks paths []) 54 | 55 | getLinks :: [Path e] -> [Int] -> [[Link e]] 56 | getLinks (x : xs) taken = 57 | let 58 | links = findLinkingPoints x taken xs 59 | in links : getLinks xs (taken `union` fmap fst (countNeighbors links)) 60 | getLinks _ _ = error "No links for path." 61 | 62 | greedy :: [PathWithLinks e] -> PathWithLinks e 63 | greedy [x] = x 64 | greedy (x : xs) = greedy (uniteOnLinkingBonds x xs : filter (helper' x) xs) 65 | greedy _ = error "Greedy function on an empty list." 66 | 67 | helper' :: PathWithLinks e -> PathWithLinks e -> Bool 68 | helper' x' y' = null $ (snd <$> snd x') `intersect` (fst <$> fst y') 69 | 70 | -- | Takes path, list of vertices which have been processed and returns links for each path. 71 | -- 72 | findLinkingPoints :: forall e. Path e -> [Int] -> [Path e] -> [Link e] 73 | findLinkingPoints Path { pBonds=list } taken = helper 74 | where 75 | getInc :: Int -> EdgeList e 76 | getInc n = filter (`isIncident` n) list 77 | 78 | couldTake :: Int -> Bool 79 | couldTake n = n `notElem` taken && (not . null $ getInc n) 80 | 81 | helper :: [Path e] -> [Link e] 82 | helper [] = [] 83 | helper (Path beg end list' : xs) | couldTake beg = wrapResult beg list' : helper xs 84 | | couldTake end = wrapResult end list' : helper xs 85 | | otherwise = helper xs 86 | 87 | wrapResult :: Int -> EdgeList e -> Link e 88 | wrapResult n l = (fromJust $ getSharedVertex b1 b2, b2) 89 | where 90 | b1 = head $ getInc n 91 | b2 = head $ getVertexIncident l n 92 | 93 | splitPathIntoLongest :: Eq e => EdgeList e -> [Int] -> [Path e] 94 | splitPathIntoLongest [] _ = [] 95 | splitPathIntoLongest bonds taken = firstPath : splitPathIntoLongest restBonds newTaken 96 | where 97 | ends' = findBeginnings bonds 98 | ends = filter (`notElem` taken) ends' 99 | 100 | startEnds = if not (null taken) then taken else ends' 101 | 102 | allPaths = filter (not . null) ((\(x, y) -> maybe [] fst (dfsSearch bonds x y)) <$> allPairs startEnds ends) 103 | allPathsTrue = concatMap (\x -> maybe [x] (splitOnPoint x) (findPointsToSplit x taken)) allPaths 104 | 105 | longestPath = maximumBy (comparing length) allPathsTrue 106 | [start, finish] = findBeginnings longestPath 107 | 108 | restBonds = bonds \\ longestPath 109 | firstPath = Path { pStart=start, pFinish=finish, pBonds=longestPath } 110 | newTaken = taken `union` getIndices longestPath 111 | 112 | pathToCoords :: forall e. EdgeList e -> CoordList e 113 | pathToCoords bonds = matchBondsOfPath coords bonds 114 | where 115 | angle = pi / 6.0 116 | radius = bondLength 117 | allPoints = getPoint <$> concat (repeat [1.0, -1.0]) 118 | dfsRes = dfs bonds (head (findBeginnings bonds)) 119 | coords = zip (getIndicesEdges dfsRes) (buildPath allPoints) 120 | 121 | getPoint :: Float -> V2 Float 122 | getPoint m = V2 (radius * cos (m * angle)) (radius * sin (m * angle)) 123 | 124 | getIndicesEdges :: EdgeList e -> [Int] 125 | getIndicesEdges [] = error "Get indices edges on empy list." 126 | getIndicesEdges [(a, b, _)] = [a, b] 127 | getIndicesEdges (bnd@(a, b, _) : bnd'@(a', b', _) : xs) = if a == a' || a == b' then b : a : helper (bnd' : xs) bnd 128 | else a : b : helper (bnd' : xs) bnd 129 | 130 | helper :: EdgeList e -> GraphEdge e -> [Int] 131 | helper [] _ = error "Get indices edges helper on empty list." 132 | helper [(a', b', _)] (a, b, _) = if a' == a || a' == b then [b'] 133 | else [a'] 134 | helper (bnd@(a, b, _) : bnd'@(a', b', _) : xs) _ = if a == a' || a == b' then a : helper (bnd' : xs) bnd 135 | else b : helper (bnd' : xs) bnd 136 | 137 | buildPath :: [V2 Float] -> [V2 Float] 138 | buildPath [] = [] 139 | buildPath (y : ys) = V2 0.0 0.0 : y : helper ys y 140 | where 141 | helper :: [V2 Float] -> V2 Float -> [V2 Float] 142 | helper [] _ = [] 143 | helper (b:xs) b' = let newCoords = b + b' in newCoords : helper xs newCoords 144 | 145 | matchBondsOfPath :: forall e. [(Int, V2 Float)] -> EdgeList e -> CoordList e 146 | matchBondsOfPath matches = helper 147 | where 148 | mapOfCoords = fromList matches 149 | 150 | helper :: EdgeList e -> CoordList e 151 | helper [] = [] 152 | helper (bond@(a, b, _) : xs) = (bond, (mapOfCoords ! a, mapOfCoords ! b)) : helper xs 153 | 154 | uniteOnLinkingBonds :: forall e. PathWithLinks e -> [PathWithLinks e] -> PathWithLinks e 155 | uniteOnLinkingBonds (mainPath, uniteThis) otherPaths = pathUniter coordsToAdd (mainPath, []) 156 | where 157 | counted = countNeighbors uniteThis 158 | neighbors = fmap getCoordsOfLinks counted 159 | 160 | coordsToAdd = concatMap align neighbors 161 | 162 | align :: (Int, [BondV2]) -> [PathWithLinks e] 163 | align (ind, toAlignBonds) = alignOnBonds <$> zip toAlignBonds (findNeighbors otherPaths ind) 164 | 165 | getCoordsOfLinks :: (Int, Int) -> (Int, [BondV2]) 166 | getCoordsOfLinks (ind, counts) = 167 | let 168 | (leftBond, rightBond) = findAdjacent mainPath ind 169 | in (ind, bondsToAlignTo leftBond rightBond counts) 170 | 171 | pathUniter :: [PathWithLinks e] -> PathWithLinks e -> PathWithLinks e 172 | pathUniter [] res = res 173 | pathUniter ((a, b) : xs) (resA, resB) = pathUniter xs (resA ++ a, resB ++ b) 174 | 175 | countNeighbors :: forall e. [Link e] -> [(Int, Int)] 176 | countNeighbors list = zip allInds (fmap (numberOfNeighbors list 0) allInds) 177 | where 178 | allInds = linkingIndices list [] 179 | 180 | linkingIndices :: [Link e] -> [Int] -> [Int] 181 | linkingIndices [] res = res 182 | linkingIndices (x : xs) res = if fst x `elem` res then linkingIndices xs res 183 | else linkingIndices xs (fst x : res) 184 | 185 | numberOfNeighbors :: [Link e] -> Int -> Int -> Int 186 | numberOfNeighbors [] acc _ = acc 187 | numberOfNeighbors (x : xs) acc ind = if fst x == ind then numberOfNeighbors xs (acc + 1) ind 188 | else numberOfNeighbors xs acc ind 189 | 190 | splitOnMultiplePoints :: forall e. Eq e => EdgeList e -> [Int] -> [EdgeList e] 191 | splitOnMultiplePoints bonds cut = helper [bonds] cut [] 192 | where 193 | helper :: [EdgeList e] -> [Int] -> [EdgeList e] -> [EdgeList e] 194 | helper [] _ _ = error "Split on multiple points helper on empty list." 195 | helper lastCut [] res = res ++ lastCut 196 | helper (x : xs) (y : ys) res = if y `elem` getIndices x then helper (splitOnPoint x y ++ xs) ys res 197 | else helper xs (y : ys) (x : res) 198 | 199 | splitOnPoint :: forall e. Eq e => EdgeList e -> Int -> [EdgeList e] 200 | splitOnPoint list point = filter (not . null) foundNeighbors 201 | where 202 | foundNeighbors = fmap splitter list 203 | 204 | splitter :: GraphEdge e -> EdgeList e 205 | splitter bond@(a, b, _) | a == point = bond : dfs (delete bond list) b 206 | | b == point = bond : dfs (delete bond list) a 207 | | otherwise = [] 208 | 209 | allPairs :: [Int] -> [Int] -> [(Int, Int)] 210 | allPairs starts ends = concatMap (\start -> fmap (\end -> (start, end)) ends) starts 211 | 212 | -- This function is used for splitting one path into substantial pieces during calculation of coordinates of this path 213 | findPointsToSplit :: forall e. EdgeList e -> [Int] -> Maybe Int 214 | findPointsToSplit _ [] = Nothing 215 | findPointsToSplit [] _ = Nothing 216 | findPointsToSplit [_] _ = Nothing 217 | findPointsToSplit list taken = helper ((tail . init) list) 218 | where 219 | helper :: EdgeList e -> Maybe Int 220 | helper [] = Nothing 221 | helper ((a, b, _) : xs) | a `elem` taken = Just a 222 | | b `elem` taken = Just b 223 | | otherwise = helper xs 224 | 225 | -- This function is used for splitting one path into several paths if one vertex of path belongs to cycle 226 | findPointsToSplitHard :: forall e. Eq e => EdgeList e -> [Int] -> [Int] 227 | findPointsToSplitHard _ [] = [] 228 | findPointsToSplitHard [] _ = [] 229 | findPointsToSplitHard [_] _ = [] 230 | findPointsToSplitHard list taken = helper list [] 231 | where 232 | helper :: EdgeList e -> [Int] -> [Int] 233 | helper [] acc = acc 234 | helper (x@(a, b, _) : xs) acc | a `notElem` acc && a `elem` taken && hasNeighbor a x = helper xs (a : acc) 235 | | b `notElem` acc && b `elem` taken && hasNeighbor b x = helper xs (b : acc) 236 | | otherwise = helper xs acc 237 | 238 | hasNeighbor :: Int -> GraphEdge e -> Bool 239 | hasNeighbor ind x = isJust (find (\bond -> bond /= x && isIncident bond ind) list) 240 | 241 | -- | Finds all paths between cycles in graph. 242 | -- 243 | findPaths :: Eq e => EdgeList e -> [Int] -> [EdgeList e] 244 | findPaths [] _ = [] 245 | findPaths bonds [] = [bonds] 246 | findPaths bonds taken = allPathsTrue 247 | where 248 | paths = findPaths' bonds 249 | allPathsTrue = concatMap (\x -> let cut = findPointsToSplitHard x taken in splitOnMultiplePoints x cut) paths 250 | 251 | findPaths' :: Eq e => EdgeList e -> [EdgeList e] 252 | findPaths' [] = [] 253 | findPaths' bonds@(x : _) = newPath : findPaths' (filter (`notElem` newPath) bonds) 254 | where 255 | newPath = findPath bonds bonds [x] x 256 | 257 | findPath :: Eq e => EdgeList e -> EdgeList e -> EdgeList e -> GraphEdge e -> EdgeList e 258 | findPath [] _ found _ = found 259 | findPath (x@(a, b, _) : xs) bonds found pathFrom@(src, dst, _) = if cond then findPath xs bonds newFound pathFrom 260 | else findPath xs bonds found pathFrom 261 | where 262 | cond = (a == dst || b == src || a == src || b == dst) && (x `notElem` found) 263 | newFound = findPath bonds bonds (found ++ [x]) x 264 | 265 | alignOnBonds :: (BondV2, (BondV2, PathWithLinks e)) -> PathWithLinks e 266 | alignOnBonds (coordsA, (coordsB, (list, toSave))) = (resCoords, toSave) 267 | where 268 | align = alignmentFunc (tupleToList coordsA) (tupleToList coordsB) 269 | resCoords = fmap (\(bond, (coordA', coordB')) -> (bond, (align coordA', align coordB'))) list 270 | 271 | findNeighbors :: [PathWithLinks e] -> Int -> [(BondV2, PathWithLinks e)] 272 | findNeighbors [] _ = [] 273 | findNeighbors (x : xs) ind = if not (null found) then (head found, x) : findNeighbors xs ind 274 | else findNeighbors xs ind 275 | where 276 | found = catMaybes (fmap coordsOfAdjacentBond (fst x)) 277 | 278 | coordsOfAdjacentBond :: Coord e -> Maybe BondV2 279 | coordsOfAdjacentBond ((a, b, _), (coordsA, coordsB)) | a == ind = Just (coordsA, coordsB) 280 | | b == ind = Just (coordsB, coordsA) 281 | | otherwise = Nothing 282 | 283 | findAdjacent :: CoordList e -> Int -> (Coord e, Coord e) 284 | findAdjacent list ind = (leftNeighbor, rightNeighbor) 285 | where 286 | [leftNeighbor, rightNeighbor] = take 2 (findIncidentCoords ind list) 287 | -------------------------------------------------------------------------------- /data/GraphsGHC9.txt: -------------------------------------------------------------------------------- 1 | only_path ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(1,2,1),(2,3,1),(3,4,1),(3,5,1),(3,20,1),(5,6,1),(6,7,1),(7,8,1),(7,14,1),(8,9,1),(9,10,1),(10,11,1),(10,12,1),(12,13,1),(14,15,1),(14,17,1),(15,16,1),(17,18,1),(17,19,1),(20,21,1),(20,22,1),(22,23,1),(22,24,1),(22,26,1),(24,25,1),(26,27,1)]) fromList[(0,(351.73364,20.501846)),(1,(413.86658,98.85684)),(2,(377.07568,191.84302)),(3,(278.1518,206.47415)),(4,(263.52063,107.55028)),(5,(317.8878,298.24045)),(6,(417.2277,309.7112)),(7,(456.96368,401.47754)),(8,(397.35974,481.77304)),(9,(437.09567,573.5393)),(10,(377.49173,653.83484)),(11,(417.22766,745.6011)),(12,(278.1518,642.36414)),(13,(238.41579,550.59796)),(14,(556.3036,412.9483)),(15,(596.03955,504.7146)),(16,(536.4356,585.0101)),(17,(615.90753,332.6529)),(18,(576.1716,240.8866)),(19,(715.2475,344.12357)),(20,(178.81187,195.00336)),(21,(139.0759,103.237076)),(22,(119.20792,275.29886)),(23,(82.416916,368.285)),(24,(212.19409,312.08984)),(25,(290.54907,249.95697)),(26,(19.867989,263.8281)),(27,(-39.735962,344.1236))] 2 | only_cycles ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,31,1),(1,2,1),(2,3,1),(2,49,1),(3,4,1),(3,46,1),(4,5,1),(5,6,1),(6,7,1),(7,8,1),(7,46,1),(8,9,1),(9,10,1),(9,44,1),(10,11,1),(11,12,1),(11,50,1),(12,13,1),(13,14,1),(13,52,1),(14,15,1),(15,16,1),(16,17,1),(17,18,1),(17,52,1),(18,19,1),(18,39,1),(19,20,1),(20,21,1),(21,22,1),(21,38,1),(22,23,1),(23,24,1),(24,25,1),(24,37,1),(25,26,1),(26,27,1),(26,35,1),(27,28,1),(28,29,1),(28,33,1),(29,30,1),(30,31,1),(31,32,1),(32,33,1),(32,49,1),(33,34,1),(34,35,1),(34,48,1),(35,36,1),(36,37,1),(36,41,1),(37,38,1),(38,39,1),(39,40,1),(40,41,1),(40,51,1),(41,42,1),(42,43,1),(42,48,1),(43,44,1),(43,50,1),(44,45,1),(45,46,1),(45,47,1),(47,48,1),(47,49,1),(50,51,1),(51,52,1)]) fromList[(0,(403.5895,571.94006)),(1,(445.5209,481.15594)),(2,(387.86526,399.45023)),(3,(429.79666,308.66608)),(4,(529.3837,299.58768)),(5,(571.3152,208.80348)),(6,(513.6594,127.09785)),(7,(414.0723,136.17632)),(8,(356.41666,54.47058)),(9,(256.8297,63.54894)),(10,(199.17412,-18.156782)),(11,(99.58706,-9.07839)),(12,(41.931416,-90.78412)),(13,(-57.655647,-81.70573)),(14,(-115.31131,-163.41145)),(15,(-214.89836,-154.33304)),(16,(-256.82974,-63.54891)),(17,(-199.17412,18.156805)),(18,(-241.10568,108.9409)),(19,(-340.69272,118.01934)),(20,(-382.62408,208.80348)),(21,(-324.9684,290.5092)),(22,(-366.89978,381.2934)),(23,(-309.24402,462.99915)),(24,(-209.65697,453.9205)),(25,(-152.00133,535.62634)),(26,(-52.414257,526.5479)),(27,(5.241503,608.25366)),(28,(104.828545,599.17523)),(29,(162.48398,680.8808)),(30,(262.071,671.8024)),(31,(304.00244,581.0185)),(32,(246.3468,499.31274)),(33,(146.75992,508.39108)),(34,(89.10421,426.68536)),(35,(-10.482858,435.76373)),(36,(-68.13858,354.05807)),(37,(-167.72563,363.1365)),(38,(-225.38132,281.4308)),(39,(-183.44992,190.64664)),(40,(-83.86286,181.56824)),(41,(-26.20719,263.274)),(42,(73.37986,254.19557)),(43,(115.31127,163.41145)),(44,(214.8983,154.33307)),(45,(272.554,236.03879)),(46,(372.141,226.96039)),(47,(230.62254,326.8229)),(48,(131.03549,335.90134)),(49,(288.2782,408.52863)),(50,(57.655643,81.70573)),(51,(-41.9314,90.78413)),(52,(-99.58706,9.078399))] 3 | simple_drawing ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,41,1),(1,2,1),(2,3,1),(3,4,1),(3,40,1),(4,5,1),(4,33,1),(5,6,1),(5,12,1),(6,7,1),(6,11,1),(7,8,1),(8,9,1),(9,10,1),(10,11,1),(12,13,1),(12,19,1),(13,14,1),(13,18,1),(14,15,1),(15,16,1),(16,17,1),(17,18,1),(19,20,1),(19,26,1),(20,21,1),(20,25,1),(21,22,1),(22,23,1),(23,24,1),(24,25,1),(26,27,1),(26,33,1),(27,28,1),(27,32,1),(28,29,1),(29,30,1),(30,31,1),(31,32,1),(33,34,1),(34,35,1),(34,39,1),(35,36,1),(36,37,1),(37,38,1),(38,39,1),(40,41,1)]) fromList[(0,(100.00002,346.41016)),(1,(50.00002,259.80762)),(2,(100.000015,173.20508)),(3,(200.00002,173.20506)),(4,(250.0,86.60252)),(5,(200.0,-1.9153093e-5)),(6,(99.999985,-8.62287e-6)),(7,(50.000004,86.60255)),(8,(-50.0,86.60254)),(9,(-100.0,-2.0267553e-6)),(10,(-50.0,-86.60255)),(11,(49.999985,-86.60255)),(12,(250.0,-86.602554)),(13,(199.99998,-173.2051)),(14,(99.99997,-173.20508)),(15,(49.99998,-259.80762)),(16,(99.99999,-346.41016)),(17,(199.99998,-346.41016)),(18,(249.99998,-259.80765)),(19,(350.0,-86.602554)),(20,(400.0,-173.20511)),(21,(349.99997,-259.80765)),(22,(399.99997,-346.4102)),(23,(499.99997,-346.4102)),(24,(550.0,-259.80765)),(25,(500.0,-173.20511)),(26,(400.0,-2.1140044e-5)),(27,(500.0,-2.022617e-5)),(28,(550.0,-86.60257)),(29,(650.0,-86.602554)),(30,(700.0,-2.0267553e-6)),(31,(650.0,86.60253)),(32,(550.0,86.60252)),(33,(350.0,86.60251)),(34,(400.0,173.20503)),(35,(500.0,173.205)),(36,(550.0,259.80753)),(37,(500.00006,346.4101)),(38,(400.0001,346.4101)),(39,(350.00006,259.8076)),(40,(250.00002,259.8076)),(41,(200.00005,346.41016))] 4 | hard_drawing ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(1,2,1),(1,6,1),(2,3,1),(2,6,1),(3,4,1),(3,5,1),(4,5,1),(6,7,1),(7,8,1),(7,47,1),(8,9,1),(8,45,1),(9,10,1),(9,14,1),(10,11,1),(10,14,1),(11,12,1),(11,13,1),(12,13,1),(14,15,1),(15,16,1),(15,17,1),(16,17,1),(17,18,1),(18,19,1),(18,37,1),(19,20,1),(19,40,1),(20,21,1),(21,22,1),(22,23,1),(23,24,1),(23,40,1),(24,25,1),(25,26,1),(25,41,1),(26,27,1),(27,28,1),(28,29,1),(28,42,1),(29,30,1),(30,31,1),(31,32,1),(31,43,1),(32,33,1),(33,34,1),(34,35,1),(34,44,1),(35,36,1),(36,37,1),(37,38,1),(38,39,1),(38,44,1),(39,40,1),(39,41,1),(41,42,1),(42,43,1),(43,44,1),(45,46,1),(46,47,1),(46,139,1),(47,48,1),(48,49,1),(48,138,1),(49,50,1),(50,51,1),(50,137,1),(51,52,1),(51,129,1),(52,53,1),(53,54,1),(54,55,1),(54,130,1),(55,56,1),(55,62,1),(56,57,1),(56,61,1),(57,58,1),(58,59,1),(59,60,1),(60,61,1),(62,63,1),(62,136,1),(63,64,1),(64,65,1),(65,66,1),(65,135,1),(66,67,1),(66,120,1),(67,68,1),(67,76,1),(68,69,1),(68,76,1),(69,70,1),(69,71,1),(70,71,1),(71,72,1),(72,73,1),(72,75,1),(73,74,1),(74,75,1),(76,77,1),(77,78,1),(77,79,1),(78,79,1),(79,80,1),(80,81,1),(80,83,1),(81,82,1),(82,83,1),(83,84,1),(84,85,1),(84,107,1),(85,86,1),(85,98,1),(86,87,1),(86,89,1),(87,88,1),(88,89,1),(89,90,1),(90,91,1),(90,97,1),(91,92,1),(92,93,1),(92,97,1),(93,94,1),(93,96,1),(94,95,1),(95,96,1),(98,99,1),(98,107,1),(99,100,1),(99,106,1),(100,101,1),(101,102,1),(101,106,1),(102,103,1),(102,105,1),(103,104,1),(104,105,1),(107,108,1),(108,109,1),(108,111,1),(109,110,1),(110,111,1),(111,112,1),(112,113,1),(112,119,1),(113,114,1),(114,115,1),(114,119,1),(115,116,1),(115,118,1),(116,117,1),(117,118,1),(120,121,1),(121,122,1),(121,134,1),(122,123,1),(123,124,1),(124,125,1),(124,133,1),(125,126,1),(126,127,1),(127,128,1),(127,132,1),(128,129,1),(129,130,1),(130,131,1),(131,132,1),(131,136,1),(132,133,1),(133,134,1),(134,135,1),(135,136,1),(137,138,1),(138,139,1),(139,140,1),(140,141,1),(140,144,1),(140,166,1),(141,142,1),(142,143,1),(143,144,1),(144,145,1),(144,164,1),(145,146,1),(146,147,1),(146,159,1),(147,148,1),(148,149,1),(149,150,1),(150,151,1),(150,155,1),(151,152,1),(151,155,1),(152,153,1),(152,154,1),(153,154,1),(155,156,1),(156,157,1),(156,158,1),(157,158,1),(159,160,1),(160,161,1),(161,162,1),(161,163,1),(162,163,1),(164,165,1),(165,166,1)]) fromList[(0,(-662.99316,527.0142)),(1,(-568.1117,495.4309)),(2,(-470.15027,515.5197)),(3,(-395.35748,581.8977)),(4,(-297.39612,601.9866)),(5,(-363.77423,676.77924)),(6,(-501.73358,420.63824)),(7,(-481.6448,322.67685)),(8,(-549.08936,248.8443)),(9,(-648.46405,260.01047)),(10,(-740.10803,219.99332)),(11,(-799.4655,139.51552)),(12,(-891.1097,99.49839)),(13,(-810.6317,40.140945)),(14,(-728.9418,319.36792)),(15,(-768.9589,411.01196)),(16,(-757.7926,510.38666)),(17,(-849.43665,470.36957)),(18,(-948.81134,481.5356)),(19,(-1008.16895,401.05783)),(20,(-968.1519,309.41397)),(21,(-1027.5094,228.93607)),(22,(-1126.884,240.10219)),(23,(-1166.9011,331.74634)),(24,(-1266.2756,342.91263)),(25,(-1306.2927,434.55658)),(26,(-1405.6676,445.72247)),(27,(-1445.6844,537.36676)),(28,(-1386.3271,617.8446)),(29,(-1426.3444,709.48865)),(30,(-1366.9866,789.96643)),(31,(-1267.6118,778.8002)),(32,(-1208.2543,859.2782)),(33,(-1108.8798,848.11206)),(34,(-1068.8627,756.4679)),(35,(-969.48804,745.30176)),(36,(-929.4708,653.6577)),(37,(-988.8285,573.17975)),(38,(-1088.203,584.34595)),(39,(-1147.5605,503.86804)),(40,(-1107.5437,412.22406)),(41,(-1246.9353,515.0343)),(42,(-1286.9524,606.67834)),(43,(-1227.5946,687.15625)),(44,(-1128.2202,675.99005)),(45,(-499.712,161.88528)),(46,(-401.7506,181.97412)),(47,(-390.58444,281.34875)),(48,(-292.62305,301.4376)),(49,(-225.17853,375.27008)),(50,(-134.1182,333.94205)),(51,(-47.15911,383.31934)),(52,(39.082447,332.69928)),(53,(126.04152,382.0766)),(54,(126.75896,482.07404)),(55,(213.71805,531.4515)),(56,(299.9597,480.83142)),(57,(386.91876,530.2089)),(58,(473.1603,479.5888)),(59,(472.4429,379.59137)),(60,(385.48383,330.214)),(61,(299.24234,380.8341)),(62,(214.43549,631.44885)),(63,(301.39456,680.8263)),(64,(302.112,780.82367)),(65,(215.87035,831.4437)),(66,(216.58781,931.44116)),(67,(303.54684,980.8186)),(68,(354.16693,1067.0602)),(69,(354.8844,1167.0575)),(70,(405.50427,1253.2991)),(71,(305.5069,1254.0165)),(72,(219.26501,1304.6365)),(73,(122.489334,1279.4476)),(74,(97.300674,1376.2234)),(75,(194.07639,1401.412)),(76,(403.5443,980.1011)),(77,(489.78586,929.4811)),(78,(539.16364,842.52234)),(79,(589.78326,928.76355)),(80,(676.742,978.14105)),(81,(703.3163,1074.5458)),(82,(799.7205,1047.9716)),(83,(773.1465,951.56683)),(84,(822.5239,864.60846)),(85,(918.92865,838.0337)),(86,(1005.88763,887.4114)),(87,(1032.4615,983.8159)),(88,(1128.8662,957.2418)),(89,(1102.2916,860.8374)),(90,(1151.6693,773.87805)),(91,(1248.0739,747.30414)),(92,(1221.4998,650.8998)),(93,(1270.8773,563.941)),(94,(1244.3032,467.5361)),(95,(1340.7083,440.96338)),(96,(1367.2816,537.3667)),(97,(1125.0953,677.47406)),(98,(892.35455,741.62976)),(99,(941.73175,654.67053)),(100,(1038.1362,628.0969)),(101,(1011.5624,531.69196)),(102,(1060.9397,444.7329)),(103,(1157.3439,418.159)),(104,(1130.77,321.75494)),(105,(1034.3655,348.32874)),(106,(915.15796,558.26636)),(107,(795.9498,768.2039)),(108,(708.99097,718.8265)),(109,(612.5863,745.40094)),(110,(586.01245,648.9961)),(111,(682.41656,622.4219)),(112,(731.7939,535.46326)),(113,(705.2197,439.05905)),(114,(801.62463,412.4848)),(115,(851.00214,325.52646)),(116,(824.4283,229.12172)),(117,(920.8327,202.54712)),(118,(947.4063,298.9523)),(119,(828.1986,508.8892)),(120,(130.3462,982.0612)),(121,(43.38719,932.6838)),(122,(-42.854477,983.3039)),(123,(-129.81346,933.92645)),(124,(-130.53087,833.92896)),(125,(-217.4899,784.5516)),(126,(-218.20734,684.55414)),(127,(-131.96573,633.93414)),(128,(-132.68317,533.9368)),(129,(-46.441612,483.3168)),(130,(40.517395,532.6941)),(131,(41.234894,632.6916)),(132,(-45.00673,683.3116)),(133,(-44.28926,783.30896)),(134,(42.669724,832.68634)),(135,(128.91136,782.06635)),(136,(128.1939,682.0689)),(137,(-145.28423,234.56735)),(138,(-243.24565,214.47856)),(139,(-310.69022,140.6461)),(140,(-290.60135,42.68468)),(141,(-192.24767,24.61361)),(142,(-179.04134,-74.510315)),(143,(-269.23288,-117.70154)),(144,(-338.18076,-45.27102)),(145,(-318.09204,-143.23239)),(146,(-392.8846,-209.61069)),(147,(-487.76614,-178.02736)),(148,(-507.85498,-80.06591)),(149,(-602.7364,-48.482666)),(150,(-677.52905,-114.86073)),(151,(-775.4906,-134.94969)),(152,(-870.37195,-103.36638)),(153,(-936.75024,-28.573715)),(154,(-968.3335,-123.455414)),(155,(-709.1125,-209.74236)),(156,(-689.02356,-307.70364)),(157,(-622.64526,-382.4962)),(158,(-720.60657,-402.5853)),(159,(-372.79587,-307.57196)),(160,(-277.9144,-339.15527)),(161,(-203.12175,-272.7773)),(162,(-105.160255,-252.68863)),(163,(-171.53839,-177.89594)),(164,(-436.5345,-27.200035)),(165,(-449.7409,71.92412)),(166,(-359.54932,115.11525))] 5 | paths_through_conjugated_cycles ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(1,2,1),(1,29,1),(1,32,1),(1,46,1),(2,3,1),(3,4,1),(4,5,1),(4,8,1),(5,6,1),(5,7,1),(6,7,1),(8,9,1),(8,26,1),(9,10,1),(10,11,1),(10,19,1),(10,22,1),(10,25,1),(11,12,1),(12,13,1),(13,14,1),(13,18,1),(14,15,1),(15,16,1),(16,17,1),(17,18,1),(19,20,1),(20,21,1),(21,22,1),(22,23,1),(23,24,1),(24,25,1),(26,27,1),(26,28,1),(27,28,1),(29,30,1),(29,31,1),(30,31,1),(32,33,1),(32,49,1),(33,34,1),(34,35,1),(35,36,1),(36,37,1),(36,49,1),(37,38,1),(38,39,1),(39,40,1),(39,48,1),(40,41,1),(41,42,1),(42,43,1),(42,47,1),(43,44,1),(44,45,1),(45,46,1),(46,47,1),(47,48,1),(48,49,1)]) fromList[(0,(-144.56487,375.90143)),(1,(-177.34793,281.42767)),(2,(-111.9228,205.79996)),(3,(-13.714699,224.64581)),(4,(51.71037,149.01802)),(5,(18.927296,54.54438)),(6,(-56.700478,-10.880676)),(7,(37.773186,-43.66371)),(8,(149.91846,167.86389)),(9,(182.70152,262.33755)),(10,(280.9096,281.18338)),(11,(200.14886,340.15543)),(12,(210.83972,439.5822)),(13,(130.07907,498.55435)),(14,(140.76997,597.9812)),(15,(60.009262,656.95337)),(16,(-31.442535,616.49835)),(17,(-42.133423,517.0715)),(18,(38.62741,458.09955)),(19,(300.22546,379.3002)),(20,(399.50897,391.2495)),(21,(441.55368,300.51776)),(22,(368.2553,232.49323)),(23,(348.93945,134.37643)),(24,(249.65598,122.42721)),(25,(207.61124,213.15886)),(26,(215.34352,92.23614)),(27,(309.8172,59.453033)),(28,(234.18939,-5.9720078)),(29,(-79.13976,300.2736)),(30,(-3.512024,365.6986)),(31,(15.33387,267.49054)),(32,(-210.13089,186.95404)),(33,(-144.7058,111.326256)),(34,(-177.4888,16.8526)),(35,(-275.69687,-1.9932556)),(36,(-341.12204,73.63444)),(37,(-439.33017,54.788574)),(38,(-504.75516,130.4163)),(39,(-471.97226,224.88998)),(40,(-537.3974,300.5178)),(41,(-504.61426,394.9914)),(42,(-406.40613,413.83737)),(43,(-373.6231,508.31097)),(44,(-275.41507,527.1569)),(45,(-209.98996,451.5291)),(46,(-242.773,357.05548)),(47,(-340.98102,338.2096)),(48,(-373.76404,243.7359)),(49,(-308.33902,168.10812))] 6 | takes_long_if_done_wrong ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,5,1),(1,2,1),(2,3,1),(3,4,1),(3,42,1),(4,5,1),(4,6,1),(6,7,1),(7,8,1),(7,37,1),(8,9,1),(8,15,1),(9,10,1),(10,11,1),(11,12,1),(11,14,1),(12,13,1),(13,14,1),(15,16,1),(15,32,1),(16,17,1),(17,18,1),(18,19,1),(18,33,1),(19,20,1),(20,21,1),(20,35,1),(21,22,1),(22,23,1),(23,24,1),(24,25,1),(24,35,1),(25,26,1),(26,27,1),(26,36,1),(27,28,1),(28,29,1),(29,30,1),(30,31,1),(30,36,1),(31,32,1),(32,33,1),(33,34,1),(34,35,1),(34,36,1),(37,38,1),(37,42,1),(38,39,1),(39,40,1),(40,41,1),(41,42,1)]) fromList[] 7 | too_big_cycle ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,33,1),(1,2,1),(2,3,1),(3,4,1),(4,5,1),(5,6,1),(6,7,1),(7,8,1),(7,13,1),(8,9,1),(9,10,1),(10,11,1),(10,12,1),(11,12,1),(13,14,1),(14,15,1),(15,16,1),(16,17,1),(17,18,1),(18,19,1),(19,20,1),(20,21,1),(21,22,1),(21,23,1),(22,23,1),(23,24,1),(24,25,1),(25,26,1),(25,27,1),(26,27,1),(27,28,1),(28,29,1),(29,30,1),(30,31,1),(31,32,1),(32,33,1)]) fromList[] 8 | bad_conjugated_cycle ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,21,1),(1,2,1),(2,3,1),(3,4,1),(4,5,1),(5,6,1),(6,7,1),(7,8,1),(8,9,1),(9,10,1),(9,31,1),(10,11,1),(11,12,1),(11,32,1),(12,13,1),(13,14,1),(14,15,1),(14,22,1),(15,16,1),(16,17,1),(17,18,1),(18,19,1),(19,20,1),(20,21,1),(22,23,1),(22,32,1),(23,24,1),(24,25,1),(25,26,1),(26,27,1),(26,31,1),(27,28,1),(27,31,1),(28,29,1),(28,30,1),(29,30,1)]) fromList[] 9 | disappearing_cycle ([0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,2,1),(1,3,1),(2,4,1),(3,5,1),(4,5,1),(4,6,1),(6,7,1),(7,8,1),(8,9,1),(9,10,1),(10,11,1),(11,12,1),(3,12,1)]) fromList[] 10 | -------------------------------------------------------------------------------- /data/Graphs.txt: -------------------------------------------------------------------------------- 1 | only_path ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(1,2,1),(2,3,1),(3,4,1),(3,5,1),(3,20,1),(5,6,1),(6,7,1),(7,8,1),(7,14,1),(8,9,1),(9,10,1),(10,11,1),(10,12,1),(12,13,1),(14,15,1),(14,17,1),(15,16,1),(17,18,1),(17,19,1),(20,21,1),(20,22,1),(22,23,1),(22,24,1),(22,26,1),(24,25,1),(26,27,1)]) fromList[(0,(-318.8334,149.94052)),(1,(-410.84003,110.76418)),(2,(-422.91565,11.4959755)),(3,(-342.98462,-48.595875)),(4,(-282.89273,31.335163)),(5,(-421.71655,-110.25041)),(6,(-514.4769,-72.893814)),(7,(-593.20886,-134.54834)),(8,(-685.96924,-97.19175)),(9,(-699.9977,1.8192978)),(10,(-792.758,39.175972)),(11,(-806.78625,138.18713)),(12,(-871.49,-22.478302)),(13,(-964.25024,14.878464)),(14,(-579.1805,-233.55948)),(15,(-657.91235,-295.214)),(16,(-750.6728,-257.85742)),(17,(-486.42,-270.91608)),(18,(-472.3916,-369.92722)),(19,(-407.6881,-209.2615)),(20,(-250.22426,-85.95247)),(21,(-236.19583,-184.9636)),(22,(-171.49231,-24.297937)),(23,(-79.48572,14.878442)),(24,(-132.31593,-116.304535)),(25,(-192.40778,-196.23557)),(26,(-185.52074,74.713196)),(27,(-278.2811,112.069786))] 2 | only_cycles ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,31,1),(1,2,1),(2,3,1),(2,49,1),(3,4,1),(3,46,1),(4,5,1),(5,6,1),(6,7,1),(7,8,1),(7,46,1),(8,9,1),(9,10,1),(9,44,1),(10,11,1),(11,12,1),(11,50,1),(12,13,1),(13,14,1),(13,52,1),(14,15,1),(15,16,1),(16,17,1),(17,18,1),(17,52,1),(18,19,1),(18,39,1),(19,20,1),(20,21,1),(21,22,1),(21,38,1),(22,23,1),(23,24,1),(24,25,1),(24,37,1),(25,26,1),(26,27,1),(26,35,1),(27,28,1),(28,29,1),(28,33,1),(29,30,1),(30,31,1),(31,32,1),(32,33,1),(32,49,1),(33,34,1),(34,35,1),(34,48,1),(35,36,1),(36,37,1),(36,41,1),(37,38,1),(38,39,1),(39,40,1),(40,41,1),(40,51,1),(41,42,1),(42,43,1),(42,48,1),(43,44,1),(43,50,1),(44,45,1),(45,46,1),(45,47,1),(47,48,1),(47,49,1),(50,51,1),(51,52,1)]) fromList[(0,(403.5895,571.94006)),(1,(445.5209,481.15594)),(2,(387.86526,399.45023)),(3,(429.79666,308.66608)),(4,(529.3837,299.58768)),(5,(571.3152,208.8035)),(6,(513.6594,127.097855)),(7,(414.0723,136.17632)),(8,(356.41666,54.470585)),(9,(256.8297,63.548943)),(10,(199.17412,-18.156778)),(11,(99.58706,-9.078388)),(12,(41.931416,-90.78412)),(13,(-57.655647,-81.70573)),(14,(-115.31131,-163.41145)),(15,(-214.89836,-154.33304)),(16,(-256.82974,-63.548912)),(17,(-199.17412,18.156801)),(18,(-241.10568,108.940895)),(19,(-340.69272,118.01933)),(20,(-382.62408,208.80348)),(21,(-324.9684,290.5092)),(22,(-366.89978,381.2934)),(23,(-309.24402,462.99915)),(24,(-209.65697,453.9205)),(25,(-152.00134,535.62634)),(26,(-52.414265,526.5479)),(27,(5.241493,608.25366)),(28,(104.82854,599.17523)),(29,(162.48396,680.8808)),(30,(262.071,671.8024)),(31,(304.00244,581.0185)),(32,(246.34679,499.31274)),(33,(146.7599,508.39108)),(34,(89.1042,426.68536)),(35,(-10.482864,435.76373)),(36,(-68.13859,354.05807)),(37,(-167.72563,363.1365)),(38,(-225.38132,281.4308)),(39,(-183.44992,190.64664)),(40,(-83.86286,181.56824)),(41,(-26.207193,263.274)),(42,(73.37985,254.19557)),(43,(115.31127,163.41145)),(44,(214.8983,154.33307)),(45,(272.554,236.03879)),(46,(372.141,226.96039)),(47,(230.62254,326.8229)),(48,(131.03549,335.90134)),(49,(288.2782,408.52863)),(50,(57.655643,81.70573)),(51,(-41.9314,90.78413)),(52,(-99.58706,9.078397))] 3 | simple_drawing ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,41,1),(1,2,1),(2,3,1),(3,4,1),(3,40,1),(4,5,1),(4,33,1),(5,6,1),(5,12,1),(6,7,1),(6,11,1),(7,8,1),(8,9,1),(9,10,1),(10,11,1),(12,13,1),(12,19,1),(13,14,1),(13,18,1),(14,15,1),(15,16,1),(16,17,1),(17,18,1),(19,20,1),(19,26,1),(20,21,1),(20,25,1),(21,22,1),(22,23,1),(23,24,1),(24,25,1),(26,27,1),(26,33,1),(27,28,1),(27,32,1),(28,29,1),(29,30,1),(30,31,1),(31,32,1),(33,34,1),(34,35,1),(34,39,1),(35,36,1),(36,37,1),(37,38,1),(38,39,1),(40,41,1)]) fromList[(0,(100.00002,346.41016)),(1,(50.00002,259.80762)),(2,(100.000015,173.20508)),(3,(200.00002,173.20506)),(4,(250.0,86.60252)),(5,(200.0,-1.9153093e-5)),(6,(99.999985,-8.62287e-6)),(7,(50.000004,86.60255)),(8,(-50.0,86.60254)),(9,(-100.0,-2.0267548e-6)),(10,(-50.0,-86.60255)),(11,(49.999985,-86.60255)),(12,(250.0,-86.602554)),(13,(199.99998,-173.2051)),(14,(99.99997,-173.20508)),(15,(49.99998,-259.80762)),(16,(99.99999,-346.41016)),(17,(199.99998,-346.41016)),(18,(249.99998,-259.80765)),(19,(350.0,-86.602554)),(20,(400.0,-173.20511)),(21,(349.99997,-259.80765)),(22,(399.99997,-346.4102)),(23,(499.99997,-346.4102)),(24,(550.0,-259.80765)),(25,(500.0,-173.20511)),(26,(400.0,-2.1140046e-5)),(27,(500.0,-2.0226173e-5)),(28,(550.0,-86.60257)),(29,(650.0,-86.602554)),(30,(700.0,-2.026758e-6)),(31,(650.0,86.60253)),(32,(550.0,86.60252)),(33,(350.0,86.60251)),(34,(400.0,173.20503)),(35,(500.0,173.205)),(36,(550.0,259.80753)),(37,(500.00006,346.4101)),(38,(400.0001,346.4101)),(39,(350.00006,259.8076)),(40,(250.00002,259.8076)),(41,(200.00005,346.41016))] 4 | hard_drawing ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(1,2,1),(1,6,1),(2,3,1),(2,6,1),(3,4,1),(3,5,1),(4,5,1),(6,7,1),(7,8,1),(7,47,1),(8,9,1),(8,45,1),(9,10,1),(9,14,1),(10,11,1),(10,14,1),(11,12,1),(11,13,1),(12,13,1),(14,15,1),(15,16,1),(15,17,1),(16,17,1),(17,18,1),(18,19,1),(18,37,1),(19,20,1),(19,40,1),(20,21,1),(21,22,1),(22,23,1),(23,24,1),(23,40,1),(24,25,1),(25,26,1),(25,41,1),(26,27,1),(27,28,1),(28,29,1),(28,42,1),(29,30,1),(30,31,1),(31,32,1),(31,43,1),(32,33,1),(33,34,1),(34,35,1),(34,44,1),(35,36,1),(36,37,1),(37,38,1),(38,39,1),(38,44,1),(39,40,1),(39,41,1),(41,42,1),(42,43,1),(43,44,1),(45,46,1),(46,47,1),(46,139,1),(47,48,1),(48,49,1),(48,138,1),(49,50,1),(50,51,1),(50,137,1),(51,52,1),(51,129,1),(52,53,1),(53,54,1),(54,55,1),(54,130,1),(55,56,1),(55,62,1),(56,57,1),(56,61,1),(57,58,1),(58,59,1),(59,60,1),(60,61,1),(62,63,1),(62,136,1),(63,64,1),(64,65,1),(65,66,1),(65,135,1),(66,67,1),(66,120,1),(67,68,1),(67,76,1),(68,69,1),(68,76,1),(69,70,1),(69,71,1),(70,71,1),(71,72,1),(72,73,1),(72,75,1),(73,74,1),(74,75,1),(76,77,1),(77,78,1),(77,79,1),(78,79,1),(79,80,1),(80,81,1),(80,83,1),(81,82,1),(82,83,1),(83,84,1),(84,85,1),(84,107,1),(85,86,1),(85,98,1),(86,87,1),(86,89,1),(87,88,1),(88,89,1),(89,90,1),(90,91,1),(90,97,1),(91,92,1),(92,93,1),(92,97,1),(93,94,1),(93,96,1),(94,95,1),(95,96,1),(98,99,1),(98,107,1),(99,100,1),(99,106,1),(100,101,1),(101,102,1),(101,106,1),(102,103,1),(102,105,1),(103,104,1),(104,105,1),(107,108,1),(108,109,1),(108,111,1),(109,110,1),(110,111,1),(111,112,1),(112,113,1),(112,119,1),(113,114,1),(114,115,1),(114,119,1),(115,116,1),(115,118,1),(116,117,1),(117,118,1),(120,121,1),(121,122,1),(121,134,1),(122,123,1),(123,124,1),(124,125,1),(124,133,1),(125,126,1),(126,127,1),(127,128,1),(127,132,1),(128,129,1),(129,130,1),(130,131,1),(131,132,1),(131,136,1),(132,133,1),(133,134,1),(134,135,1),(135,136,1),(137,138,1),(138,139,1),(139,140,1),(140,141,1),(140,144,1),(140,166,1),(141,142,1),(142,143,1),(143,144,1),(144,145,1),(144,164,1),(145,146,1),(146,147,1),(146,159,1),(147,148,1),(148,149,1),(149,150,1),(150,151,1),(150,155,1),(151,152,1),(151,155,1),(152,153,1),(152,154,1),(153,154,1),(155,156,1),(156,157,1),(156,158,1),(157,158,1),(159,160,1),(160,161,1),(161,162,1),(161,163,1),(162,163,1),(164,165,1),(165,166,1)]) fromList[(0,(-285.28656,154.6171)),(1,(-185.95885,166.19312)),(2,(-94.15051,126.5544)),(3,(-34.46147,46.322105)),(4,(57.346863,6.6834164)),(5,(-22.885447,-53.00559)),(6,(-105.72655,225.88211)),(7,(-66.08784,317.69043)),(8,(-117.06327,403.72247)),(9,(-216.62723,413.0508)),(10,(-298.188,470.91138)),(11,(-339.89136,561.8004)),(12,(-421.45212,619.66095)),(13,(-330.56302,661.3643)),(14,(-307.51627,371.3474)),(15,(-365.37683,289.78665)),(16,(-374.70514,190.22269)),(17,(-456.26587,248.08325)),(18,(-555.8298,257.41153)),(19,(-597.5333,348.30066)),(20,(-539.6728,429.8613)),(21,(-581.3762,520.75037)),(22,(-680.9402,530.0786)),(23,(-738.8007,448.51785)),(24,(-838.36475,457.84616)),(25,(-896.2252,376.28546)),(26,(-995.78906,385.61374)),(27,(-1053.6497,304.053)),(28,(-1011.9462,213.16385)),(29,(-1069.8068,131.60309)),(30,(-1028.1033,40.71408)),(31,(-928.53937,31.385742)),(32,(-886.83594,-59.503265)),(33,(-787.272,-68.83151)),(34,(-729.41144,12.729248)),(35,(-629.8474,3.4009094)),(36,(-571.98694,84.96175)),(37,(-613.6904,175.85081)),(38,(-713.2544,185.17908)),(39,(-754.95776,276.06808)),(40,(-697.0973,357.6289)),(41,(-854.52167,285.39636)),(42,(-912.3823,203.83557)),(43,(-870.67883,112.94656)),(44,(-771.11487,103.61832)),(45,(-50.994232,478.7883)),(46,(40.814087,439.14954)),(47,(31.485733,339.5856)),(48,(123.29404,299.94684)),(49,(174.26944,213.9148)),(50,(271.84296,235.8099)),(51,(346.9088,169.74088)),(52,(327.22424,71.69743)),(53,(402.29004,5.628357)),(54,(497.04047,37.6028)),(55,(572.1063,-28.466248)),(56,(552.4219,-126.50975)),(57,(457.67145,-158.48418)),(58,(437.98697,-256.52765)),(59,(513.05286,-322.59668)),(60,(607.8032,-290.6222)),(61,(627.48773,-192.57877)),(62,(666.8567,3.5081482)),(63,(741.9226,-62.560852)),(64,(836.673,-30.586456)),(65,(856.35754,67.45706)),(66,(951.10785,99.43146)),(67,(1026.1738,33.362488)),(68,(1058.1483,-61.38788)),(69,(1038.4639,-159.4313)),(70,(972.395,-234.49728)),(71,(1070.4385,-254.18167)),(72,(1145.5044,-320.25058)),(73,(1151.8663,-420.04803)),(74,(1251.6638,-413.68616)),(75,(1245.3019,-313.8887)),(76,(1124.2173,13.678101)),(77,(1218.9677,45.652466)),(78,(1317.0111,25.96814)),(79,(1285.0366,120.718506)),(80,(1304.7211,218.76193)),(81,(1249.3129,302.00803)),(82,(1332.559,357.41635)),(83,(1387.9672,274.17026)),(84,(1486.0105,254.48584)),(85,(1569.2566,309.8941)),(86,(1588.941,407.9376)),(87,(1672.186,463.34607)),(88,(1616.7777,546.59216)),(89,(1533.5327,491.18372)),(90,(1435.4893,510.86807)),(91,(1352.2422,455.4614)),(92,(1296.8351,538.7073)),(93,(1198.7916,558.3917)),(94,(1115.5426,502.9828)),(95,(1060.1359,586.23)),(96,(1143.3809,641.6383)),(97,(1380.0801,594.11566)),(98,(1624.6648,226.64795)),(99,(1722.7083,206.96356)),(100,(1805.9543,262.37183)),(101,(1861.3625,179.12567)),(102,(1959.406,159.44122)),(103,(2014.8156,76.19623)),(104,(2098.0615,131.60315)),(105,(2042.6536,214.8504)),(106,(1778.1165,123.71735)),(107,(1541.4187,171.23969)),(108,(1521.7344,73.19629)),(109,(1438.4882,17.788025)),(110,(1493.895,-65.45801)),(111,(1577.1414,-10.049744)),(112,(1675.185,-29.734253)),(113,(1730.593,-112.98071)),(114,(1813.8395,-57.57245)),(115,(1911.8828,-77.2569)),(116,(1967.2913,-160.50311)),(117,(2050.537,-105.09497)),(118,(1995.129,-21.848694)),(119,(1758.4312,25.673767)),(120,(970.7925,197.47498)),(121,(895.72656,263.54395)),(122,(915.411,361.58746)),(123,(840.34515,427.65643)),(124,(745.59485,395.682)),(125,(670.5289,461.75098)),(126,(575.77856,429.77658)),(127,(556.094,331.73306)),(128,(461.34375,299.7587)),(129,(441.65924,201.71527)),(130,(516.725,135.64624)),(131,(611.4754,167.62064)),(132,(631.1599,265.66412)),(133,(725.9103,297.6385)),(134,(800.97614,231.56953)),(135,(781.2916,133.52603)),(136,(686.54126,101.551636)),(137,(281.1714,335.37387)),(138,(189.3631,375.01263)),(139,(138.38768,461.04465)),(140,(178.02649,552.85297)),(141,(277.99863,550.49255)),(142,(311.1366,644.8423)),(143,(231.64487,705.51404)),(144,(149.37827,648.6615)),(145,(189.01703,740.46985)),(146,(129.3281,820.7023)),(147,(30.000366,809.1262)),(148,(-29.68869,889.35846)),(149,(9.950012,981.1669)),(150,(-49.739014,1061.3992)),(151,(-61.315125,1160.727)),(152,(-21.676575,1252.5354)),(153,(-33.252747,1351.863)),(154,(58.555237,1312.2241)),(155,(-141.54742,1101.0378)),(156,(-240.87503,1089.4617)),(157,(-332.68326,1129.1002)),(158,(-321.10727,1029.7725)),(159,(168.96686,912.5105)),(160,(268.2945,924.08655)),(161,(327.98355,843.85425)),(162,(419.79193,804.21545)),(163,(339.55963,744.5265)),(164,(49.406128,651.022)),(165,(16.268158,556.67224)),(166,(95.7599,496.00046))] 5 | paths_through_conjugated_cycles ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(1,2,1),(1,29,1),(1,32,1),(1,46,1),(2,3,1),(3,4,1),(4,5,1),(4,8,1),(5,6,1),(5,7,1),(6,7,1),(8,9,1),(8,26,1),(9,10,1),(10,11,1),(10,19,1),(10,22,1),(10,25,1),(11,12,1),(12,13,1),(13,14,1),(13,18,1),(14,15,1),(15,16,1),(16,17,1),(17,18,1),(19,20,1),(20,21,1),(21,22,1),(22,23,1),(23,24,1),(24,25,1),(26,27,1),(26,28,1),(27,28,1),(29,30,1),(29,31,1),(30,31,1),(32,33,1),(32,49,1),(33,34,1),(34,35,1),(35,36,1),(36,37,1),(36,49,1),(37,38,1),(38,39,1),(39,40,1),(39,48,1),(40,41,1),(41,42,1),(42,43,1),(42,47,1),(43,44,1),(44,45,1),(45,46,1),(46,47,1),(47,48,1),(48,49,1)]) fromList[(0,(230.58554,-330.19867)),(1,(239.7278,-230.61751)),(2,(158.0591,-172.9094)),(3,(67.24809,-214.78252)),(4,(-14.420623,-157.07445)),(5,(-5.2783027,-57.493233)),(6,(52.429756,24.17548)),(7,(-47.151455,33.31776)),(8,(-105.23163,-198.94757)),(9,(-186.90034,-141.2395)),(10,(-277.7113,-183.11267)),(11,(-246.40247,-88.14029)),(12,(-148.49954,-67.768364)),(13,(-117.190674,27.204012)),(14,(-183.78474,101.8045)),(15,(-152.47581,196.77687)),(16,(-54.572884,217.14877)),(17,(12.021134,142.54828)),(18,(-19.287748,47.575935)),(19,(-350.55386,-114.60014)),(20,(-438.22275,-162.70593)),(21,(-419.56256,-260.9495)),(22,(-320.36108,-273.56155)),(23,(-247.51855,-342.0741)),(24,(-159.8497,-293.96826)),(25,(-178.50989,-195.72473)),(26,(-114.37393,-298.5288)),(27,(-72.5008,-389.33978)),(28,(-172.08203,-380.19742)),(29,(148.91682,-272.4906)),(30,(91.208725,-354.1594)),(31,(49.33562,-263.34833)),(32,(248.87009,-131.03625)),(33,(167.2013,-73.32818)),(34,(176.34355,26.25306)),(35,(267.15457,68.12624)),(36,(348.8233,10.418238)),(37,(439.63434,52.29142)),(38,(521.3031,-5.416523)),(39,(512.16077,-104.99786)),(40,(593.8296,-162.70593)),(41,(584.6873,-262.28714)),(42,(493.87622,-304.16037)),(43,(484.73404,-403.74152)),(44,(393.9231,-445.61475)),(45,(312.25433,-387.90668)),(46,(321.39655,-288.3255)),(47,(412.20755,-246.4523)),(48,(421.34982,-146.87103)),(49,(339.68106,-89.16299))] 6 | takes_long_if_done_wrong ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,5,1),(1,2,1),(2,3,1),(3,4,1),(3,42,1),(4,5,1),(4,6,1),(6,7,1),(7,8,1),(7,37,1),(8,9,1),(8,15,1),(9,10,1),(10,11,1),(11,12,1),(11,14,1),(12,13,1),(13,14,1),(15,16,1),(15,32,1),(16,17,1),(17,18,1),(18,19,1),(18,33,1),(19,20,1),(20,21,1),(20,35,1),(21,22,1),(22,23,1),(23,24,1),(24,25,1),(24,35,1),(25,26,1),(26,27,1),(26,36,1),(27,28,1),(28,29,1),(29,30,1),(30,31,1),(30,36,1),(31,32,1),(32,33,1),(33,34,1),(34,35,1),(34,36,1),(37,38,1),(37,42,1),(38,39,1),(39,40,1),(40,41,1),(41,42,1)]) fromList[] 7 | too_big_cycle ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,33,1),(1,2,1),(2,3,1),(3,4,1),(4,5,1),(5,6,1),(6,7,1),(7,8,1),(7,13,1),(8,9,1),(9,10,1),(10,11,1),(10,12,1),(11,12,1),(13,14,1),(14,15,1),(15,16,1),(16,17,1),(17,18,1),(18,19,1),(19,20,1),(20,21,1),(21,22,1),(21,23,1),(22,23,1),(23,24,1),(24,25,1),(25,26,1),(25,27,1),(26,27,1),(27,28,1),(28,29,1),(29,30,1),(30,31,1),(31,32,1),(32,33,1)]) fromList[] 8 | bad_conjugated_cycle ([0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,21,1),(1,2,1),(2,3,1),(3,4,1),(4,5,1),(5,6,1),(6,7,1),(7,8,1),(8,9,1),(9,10,1),(9,31,1),(10,11,1),(11,12,1),(11,32,1),(12,13,1),(13,14,1),(14,15,1),(14,22,1),(15,16,1),(16,17,1),(17,18,1),(18,19,1),(19,20,1),(20,21,1),(22,23,1),(22,32,1),(23,24,1),(24,25,1),(25,26,1),(26,27,1),(26,31,1),(27,28,1),(27,31,1),(28,29,1),(28,30,1),(29,30,1)]) fromList[] 9 | disappearing_cycle ([0,0,0,0,0,0,0,0,0,0,0,0,0,0],[(0,1,1),(0,2,1),(1,3,1),(2,4,1),(3,5,1),(4,5,1),(4,6,1),(6,7,1),(7,8,1),(8,9,1),(9,10,1),(10,11,1),(11,12,1),(3,12,1)]) fromList[] 10 | --------------------------------------------------------------------------------