1

I have a list of list of pairs of integer that for me represents a list of graphs with n nodes.
For example with n=5 I could have

graphs = {
{{1,2},{3,4},{3,5}},
{{1,2},{1,3},{1,4},{1,5},{2,3}},
{{2,3},{2,4}},
{{3,4},{3,5},{4,5}}
};

Now I'm interested in finding, for each pair of them, what is the number of way you can map the nodes of one onto the nodes of the other under a particular condition.
The condition is that if two nodes are connected in the starting graph, they can't be connected in the ending graph.
This is a first naive implementation

Table[
  Count[Intersection[graphs[[i]], #] & /@
    Map[Sort, 
      ReplaceAll[graphs[[j]], #] & /@ (MapThread[#1 -> #2 &, {Range@5, #}] & /@ Permutations@Range@5), 
    {2}],
  {}],
{i, Length@graphs}, {j, i}]

Imagine working with bigger and more graphs, it slows down very quickly and any kind of optimization is much needed.
I thought that it can be way better to precalculate one pure function for each graph instead of creating the list of replacement rules each time. I've done so

graphfunctions = Function /@ (Map[ToExpression["#" <> ToString@#] &, #, {2}] & /@ graphs);
searchspace = Permutations@Range@5;

Table[
  Count[Intersection[graphs[[i]], #] & /@
    Map[Sort, 
      graphfunctions[[j]] @@@ searchspace), 
    {2}],
  {}],
{i, Length@graphs}, {j, i}]

My questions are:

  • Given the fact that I'm interested in empty intersections can Intersection be properly short circuited? I've tried using AnyTrue with MemberQ but it isn't faster.
  • Is Sort still the fastest way to swap two element if they are in reverse order?
  • Do I really need to order the pairs or could there be a custom function that does "unordered" and short circuited intersection that is faster than Intersection and Sort?
  • How can Sort be put directly inside the pure graph functions? Maybe it would be slightly faster than mapping it later
  • Did I miss something that can be optimized?
Domenico Modica
  • 489
  • 2
  • 9

1 Answers1

1

I was fiddling around my first time with Mathematica compiler, trying a bunch of variations of graphfunctions, when I had a nice idea to bypass Sort and even unburden Intersection...
First, for this problem using one argument instead of many is better, both for the uncompiled and compiled function

graph = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}, {2, 5}, {3, 5}, {4, 5}, {4, 6}, {4, 7}, {5, 6}, {5, 7}, {6, 7}};
searchspace = Permutations@Range@7;
gf1 = {{#1, #2}, {#1, #3}, {#1, #4}, {#2, #3}, {#2, #4}, {#3, #4}, {#2, #5}, {#3, #5}, {#4, #5}, {#4, #6}, {#4, #7}, {#5, #6}, {#5, #7}, {#6, #7}} &;
gf2 = {{#[[1]], #[[2]]}, {#[[1]], #[[3]]}, {#[[1]], #[[4]]}, {#[[2]], #[[3]]}, {#[[2]], #[[4]]}, {#[[3]], #[[4]]}, {#[[2]], #[[5]]}, {#[[3]], #[[5]]}, {#[[4]], #[[5]]}, {#[[4]], #[[6]]}, {#[[4]], #[[7]]}, {#[[5]], #[[6]]}, {#[[5]], #[[7]]}, {#[[6]], #[[7]]}} &;
cgf1 = Compile[{{a, _Integer}, {b, _Integer}, {c, _Integer}, {d, _Integer}, {e, _Integer}, {f, _Integer}, {g, _Integer}}, {{a, b}, {a, c}, {a, d}, {b, c}, {b, d}, {c, d}, {b, e}, {c, e}, {d, e}, {d, f}, {d, g}, {e, f}, {e, g}, {f, g}}];
cgf2 = Compile[{{a, _Integer, 1}}, {{a[[1]], a[[2]]}, {a[[1]], a[[3]]}, {a[[1]], a[[4]]}, {a[[2]], a[[3]]}, {a[[2]], a[[4]]}, {a[[3]], a[[4]]}, {a[[2]],a[[5]]}, {a[[3]], a[[5]]}, {a[[4]], a[[5]]}, {a[[4]], a[[6]]}, {a[[4]], a[[7]]}, {a[[5]], a[[6]]}, {a[[5]], a[[7]]}, {a[[6]], a[[7]]}}];

gf1 @@@ searchspace; // RepeatedTiming // First
(*    0.010304    *)


gf2 /@ searchspace; // RepeatedTiming // First
(*    0.00741315    *)


cgf1 @@@ searchspace; // RepeatedTiming // First
(*    0.0049784    *)


cgf2 /@ searchspace; // RepeatedTiming // First
(*    0.00170199    *)

Enclosing Sort in the compiled function seems to be a bad move

Map[Sort, gf2 /@ searchspace, {2}]; // RepeatedTiming // First
(*    0.0170787    *)

Map[Sort, cgf2 /@ searchspace, {2}]; // RepeatedTiming // First
(*    0.0117649    *)


cgf2sort = Compile[{{a, _Integer, 1}}, Sort /@ {{a[[1]], a[[2]]}, {a[[1]], a[[3]]}, {a[[1]], a[[4]]}, {a[[2]], a[[3]]}, {a[[2]], a[[4]]}, {a[[3]], a[[4]]}, {a[[2]], a[[5]]}, {a[[3]], a[[5]]}, {a[[4]], a[[5]]}, {a[[4]], a[[6]]}, {a[[4]], a[[7]]}, {a[[5]], a[[6]]}, {a[[5]], a[[7]]}, {a[[6]], a[[7]]}}];
cgf2sort /@ searchspace; // RepeatedTiming // First
(*    0.0131931    *)

Also, how can this happen?

c2sort1 = Compile[{{a, _Integer}, {b, _Integer}}, If[a < b, {a, b}, {b, a}], CompilationTarget -> "C", RuntimeOptions -> "Speed"];
c2sort2 = Compile[{{x, _Integer, 1}}, If[x[[1]] < x[[2]], x, {x[[2]], x[[1]]}], CompilationTarget -> "C", RuntimeOptions -> "Speed"];

c2sort1 @@ {2, 1} // RepeatedTiming // First
(*    1.220510^-6    )


c2sort2@{2, 1} // RepeatedTiming // First
(*    9.7870710^-7    )


Sort@{2, 1} // RepeatedTiming // First
(*    1.5724210^-7    )

By the way we can do without Sort, the interesting idea is to take advantage of the "undirectionality" of the graphs I'm treating.
If I could encode unambiguously and in a commutative way the pair of nodes that subtend an edge, I can have a single number for that edge ready to be searched as is. Prime numbers are what immediately comes to mind...

gfprime = With[{p = {2, 3, 5, 7, 11, 13, 17}}, {p[[#[[1]]]]*p[[#[[2]]]], p[[#[[1]]]]*p[[#[[3]]]], p[[#[[1]]]]*p[[#[[4]]]], p[[#[[2]]]]*p[[#[[3]]]], p[[#[[2]]]]*p[[#[[4]]]], p[[#[[3]]]]*p[[#[[4]]]], p[[#[[2]]]]*p[[#[[5]]]], p[[#[[3]]]]*p[[#[[5]]]], p[[#[[4]]]]*p[[#[[5]]]], p[[#[[4]]]]*p[[#[[6]]]], p[[#[[4]]]]*p[[#[[7]]]], p[[#[[5]]]]*p[[#[[6]]]], p[[#[[5]]]]*p[[#[[7]]]], p[[#[[6]]]]*p[[#[[7]]]]}] &;
cgfprime = Compile[{{a, _Integer, 1}}, With[{p = {2, 3, 5, 7, 11, 13, 17}}, {p[[a[[1]]]]*p[[a[[2]]]], p[[a[[1]]]]*p[[a[[3]]]], p[[a[[1]]]]*p[[a[[4]]]], p[[a[[2]]]]*p[[a[[3]]]], p[[a[[2]]]]*p[[a[[4]]]], p[[a[[3]]]]*p[[a[[4]]]], p[[a[[2]]]]*p[[a[[5]]]], p[[a[[3]]]]*p[[a[[5]]]], p[[a[[4]]]]*p[[a[[5]]]], p[[a[[4]]]]*p[[a[[6]]]], p[[a[[4]]]]*p[[a[[7]]]], p[[a[[5]]]]*p[[a[[6]]]], p[[a[[5]]]]*p[[a[[7]]]], p[[a[[6]]]]*p[[a[[7]]]]}]];
graphprime = cgfprime@{1, 2, 3, 4, 5, 6, 7};

Count[Intersection[graph, #] & /@ Map[Sort, gf2 /@ searchspace, {2}], {}] // RepeatedTiming // First
(*    0.0372562    *)


Count[Intersection[graph, #] & /@ Map[Sort, cgf2 /@ searchspace, {2}], {}] // RepeatedTiming // First
(*    0.0311057    *)


Count[Intersection[graphprime, #] & /@ (gfprime /@ searchspace), {}] // RepeatedTiming // First
(*    0.019155    *)


Count[Intersection[graphprime, #] & /@ (cgfprime /@ searchspace), {}] // RepeatedTiming // First
(*    0.0121206    *)

Original approach - Top optimization

...but are primes necessary? Do we need to bring up multiplication? Maybe we can construct a sequence of integers for which the pairwise sums are all distinct

cgfMian = Compile[{{a, _Integer, 1}}, With[{p = {1, 2, 4, 8, 13, 21, 31}}, {p[[a[[1]]]] + p[[a[[2]]]], p[[a[[1]]]] + p[[a[[3]]]], p[[a[[1]]]] + p[[a[[4]]]], p[[a[[2]]]] + p[[a[[3]]]], p[[a[[2]]]] + p[[a[[4]]]], p[[a[[3]]]] + p[[a[[4]]]], p[[a[[2]]]] + p[[a[[5]]]], p[[a[[3]]]] + p[[a[[5]]]], p[[a[[4]]]] + p[[a[[5]]]], p[[a[[4]]]] + p[[a[[6]]]], p[[a[[4]]]] + p[[a[[7]]]], p[[a[[5]]]] + p[[a[[6]]]], p[[a[[5]]]] + p[[a[[7]]]], p[[a[[6]]]] + p[[a[[7]]]]}]];
graphMian = cgfMian@{1, 2, 3, 4, 5, 6, 7};

Count[Intersection[graph, #] & /@ Map[Sort, gf1 @@@ searchspace, {2}], {}] // RepeatedTiming // First
(*    0.0476533    *)


Count[Intersection[graphMian, #] & /@ (cgfMian /@ searchspace), {}] // RepeatedTiming // First
(*    0.0118117    *)

Of course each of these compiled function can be set Listable for parallelization.

My question on whether Intersection can be short circuited remains open although not as relevant.
Now my concern becomes: what's the Mathematica correct way of dynamically generete a list of cgfMian from a list of graphs?

Domenico Modica
  • 489
  • 2
  • 9