3
$\begingroup$

I have the code:

SquareEdges[n_Integer?Positive] := 
 Reap[Do[If[IntegerQ[Sqrt[Prime[i + 1] + Prime[j + 1]]], 
     Sow[{i, j}]], {i, n - 1}, {j, i + 1, n}]][[2, 1]]

results = {};
n = 13;
While[n < 10001, poss = SquareEdges[n];
 gr = Graph[poss, VertexLabels -> Automatic];
 numNodes = Length[Select[VertexOutDegree[gr], # < 1 &]];
 AppendTo[results, numNodes];
 n++]
Print[results]

It seems to be working quite slowly. How can I improve the speed of it?

$\endgroup$
3
  • 1
    $\begingroup$ What is SquareEdges? It seems to be undefined. $\endgroup$ Jan 7, 2023 at 9:41
  • $\begingroup$ thx henrik! I have edited it to contain the full code. It did not show it completeley for some reason $\endgroup$ Jan 7, 2023 at 10:05
  • 1
    $\begingroup$ See here for a faster way to check if an integer number is a perfect square (much faster than your If[IntegerQ[Sqrt[...]]]). $\endgroup$
    – Roman
    Jan 7, 2023 at 12:09

2 Answers 2

4
$\begingroup$
Clear[SquareEdges]
SquareEdges[n_Integer?Positive] :=
 Reap[Do[If[IntegerQ[Sqrt[Prime[i + 1] + Prime[j + 1]]], 
     Sow[{i, j}, ToString@n]], {i, n - 1}, {j, i + 1, n}]][[2, 1]]

You don't have to calculate these repeatedly as every iteration adds a few more entries. The following lookup takes 5.8s on my machine.

lut = SquareEdges[1001];

Now you can lookup from this table and Sow instead of Append:

n = 13;
Reap[While[n < 1001, poss = Select[lut, Last@# <= n &];
    gr = Graph[poss(*,VertexLabels\[Rule]Automatic*)];
    Sow[Length[Select[VertexOutDegree[gr], # < 1 &]]
     ];
    n++]][[2, 1]] // AbsoluteTiming

Result

{3.16412, {1, 2, 2, 2, 2, 2, 3, 3, 3, 4, 4, 4, 3, 3, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 6,
6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 6, 6, 6, 6, 6, 6, 8, 8, 8, 8,
8, 8, 8, 8, 9, 9, 10, 10, 10, 10, 10, 10, 8, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 6, 6, 6, 7, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 8, 8, 8, 8, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 6, 6,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 8, 8, 8, 8, 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10,
10, 10, 10, 10, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10,
11, 11, 11, 11, 11, 11, 12, 12, 12, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 11, 11, 12, 12, 11, 11, 11, 10, 10, 10, 10, 10, 10,
10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 12, 12,
12, 13, 12, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 10, 10, 8,
8, 8, 8, 8, 8, 8, 8, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8,
8, 8, 8, 8, 8, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 9, 9, 9, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 7, 7, 7, 7,
7, 7, 7, 7, 7, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 5, 5, 5, 5,
5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7, 7, 7, 7, 6, 5,
5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6,
6, 6, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 6, 6, 6, 6, 6, 6, 6}}

$\endgroup$
2
  • $\begingroup$ thanks for answering! Another question: Is ther anything I can do to get the estimated time of this code? cuz I am planning to run it for 1000000 numbers. $\endgroup$ Jan 7, 2023 at 16:04
  • 1
    $\begingroup$ My knowledge about Graphs is quite superficial. I would suggest that you follow the modifications suggested by Henrik Schumacher and post a fresh question when you have given it your best shot. $\endgroup$
    – Syed
    Jan 7, 2023 at 16:45
5
$\begingroup$

In addition to what Syed already pointed out, you can speed up the search for the restricted set of edges by using a SparseArray and by using Table instead of Sow and Reap. Moreover, I suggest to employ Count because it is more idiomatic (and also a bit faster because it does not have to create sets first):

A = SparseArray[lut -> _, {1001, 1001}];
result = Table[
  Count[VertexOutDegree[Graph[A[[1 ;; n, 1 ;; n]]["NonzeroPositions"]]], 0]
  , {n, 13, 1000}];

Originally, I meant to propose

AbsoluteTiming[
 A = SparseArray[lut -> _, {1001, 1001}];
 result = Table[
   Differences[A[[1 ;; n, 1 ;; n]]["RowPointers"]]
   , {n, 13, 1000}];
 ]

which is 10 times faster (because it avoid Graph altogether). But it gives a different result if not all vertices of from 1 to n appear in loss = A[[1 ;; n, 1 ;; n]]["NonzeroPositions"]. Not sure whether you want the one or the other...

The idea is that you use A[[1 ;; n, 1 ;; n]] (or rather its symmetrization) as the adjacency matrix of an undirected graph. Then rp = A[[1 ;; n, 1 ;; n]]["RowPointers"] contains the numbers of nonzeroes per row (== number of edges a vertex is attached to). More precisely, vertex i has rp[[i+1]] - rp[[i]] neighbors.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.