This question is a follow-up to the question I asked earlier.
Using Mathematica, we can easily determine that the following two graphs are non-isomorphic.
G1 = Graph[
ImportString["W|tNHEpCKoh`@@Po_WHB@CKC?WGO{G?KKCB`?OMG?_y_?Sn",
"Graph6"], VertexLabels -> Automatic];
G2 = Graph[
ImportString["W|vJJEpCKo``P`?ocKG``?ECG[GGKGCEC@@p?CMG?G]_?H^",
"Graph6"], VertexLabels -> Automatic];
IsomorphicGraphQ[G1, G2]
(*Flase*)
I'd like to make it easy to see that these two graphs are non-isomorphic. And I tried the method in the answer of Szabolcs, and for these two graphs, it doesn't work.
sig[g_] := Module[{dm, diam}, dm = GraphDistanceMatrix[g];
diam = Max[dm];
Sort[Lookup[Counts[#], Range[diam], 0] & /@ dm]]
s1[G1]
(*{{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,\
10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{\
7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6}\
,{7,10,6}}*)
s2[G2]
(*{{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,\
10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{\
7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6},{7,10,6}\
,{7,10,6}}*)
So I came up with the following idea, but it could be very violent.
For two graphs $G_1$ and $G_2$, if $G_1$ has some subgraph $H$ and $G_2$ doesn't contain any subgraph isomorphic to $H$, then $G_1$ is not isomorphic to $G_2$.
Let $S$ be the set of non-isomophic subgraphs of $G$ such that $G_2$ does not contain any subgraph isomorphic to any one of $S$.
My goal is to find the graphs in $S$ such that
- (1) have the minimum number of vertices,
- (2) have the minimum of edges.
Note that filtered graphs prioritised to meet condition (1).
PS: choose ``the minimum` is for the sake of observation.
For example,
Then $S$ is the following graph set:
The goal graph is $g_1$ in $S$.
How can we do that with Mathematica.
Ps: One interesting thing is that these two graphs have different eigenvalues. But I prefer to look at a small subgraph $g$ in $G_1$ that $G_2$ does not contain $g$ (up to isomorphism).
Eigenvalues[AdjacencyMatrix[G1]]
(*{7, 1 + 2 Sqrt[3], 1 + 2 Sqrt[3], 1 + 2 Sqrt[3], -3, -3, -3,
1 - 2 Sqrt[3], 1 - 2 Sqrt[3],
1 - 2 Sqrt[3], -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1}*)
Eigenvalues[AdjacencyMatrix[G2]]
(*7, Root[25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 6, 0], \
Root[25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 6, 0], 1 +
2 Sqrt[3], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 1, 0], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 1, 0], -3, 1 -
2 Sqrt[3], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 2, 0], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 2, 0], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 3, 0], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 3, 0], -1, -1, \
-1, -1, -1, 1, 1, 1, Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 5, 0], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 5, 0], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 4, 0], Root[
25 + 50 # - 17 #^2 - 52 #^3 - 17 #^4 + 2 #^5 + #^6& , 4, 0]*)