Two grid points with max n, avoid rotations and reflections

[Ed Pegg]

Doing a study of Beloch folds, I wanted pairs of integer grid points, avoiding rotations and reflections.  If I steadily move away from the origin, how many pairs are there?

Early punchline.  And it was the polynomial   -1 + 5 x + 4 x^3
Table[-1 + 5 x + 4 x^3, {x, 1, 20}] 
{8, 41, 122, 275, 524, 893, 1406, 2087, 2960, 4049, 5378, 6971, 8852, \
11045, 13574, 16463, 19736, 23417, 27530, 32099}


So, I used this clunky code to place all pairs into arrays, and then picked a canonical array for each pair, and then took the union.  Probably more efficient methods.  

tup = SortBy[Tuples[Range[21], {2}], N[Norm[# - 11]] &];
pairs = Subsets[tup, {2}];
unique = Monitor[Union[Table[Select[Position[
        Sort[
          ResourceFunction["ArrayRotations"][
           Normal[SparseArray[{{1, 1} -> 1, {21, 21} -> 1, {1, 21} ->
               1, {21, 1} -> 1, pairs[[k, 1]] -> 1,
              pairs[[k, 2]] -> 1}]]]][[1]], 1], 1 < Max[#] < 21 &] -
      11, {k, 1, Length[pairs]}]], k];
uniquepairs =
  Select[SortBy[
    unique, {Max[Abs[Flatten[#]]], Total[Abs[Flatten[#]]]} &],
   Length[#] == 2 &];
Length /@ SplitBy[uniquepairs, Max[Abs[Flatten[#]]] &]    

Avoiding rotations and reflections, there are 8 pairs of points with max(abs()) = 1, and 41 pairs with max(abs()) = 2

{{{{0,0},{1,0}},{{0,-1},{0,1}},{{0,0},{1,1}},{{0,1},{1,0}},{{0,1},{1,-1}},{{1,0},{1,1}},{{-1,1},{1,-1}},{{1,-1},{1,1}}},

{{{0,0},{2,0}},{{0,-1},{0,2}},{{0,0},{2,1}},{{0,2},{1,0}},{{1,0},{2,0}},{{0,-2},{0,2}},{{0,0},{2,2}},{{0,1},{1,-2}},{{0,1},{2,-1}},{{0,2},{1,-1}},{{0,2},{2,0}},{{1,0},{1,2}},{{1,0},{2,1}},{{1,1},{2,0}},{{-1,2},{1,-1}},{{0,1},{2,-2}},{{0,2},{1,-2}},{{0,2},{2,-1}},{{1,-1},{1,2}},{{1,0},{2,2}},{{1,1},{2,-1}},{{1,1},{2,1}},{{1,2},{2,0}},{{2,0},{2,1}},{{-1,1},{2,-2}},{{-1,2},{1,-2}},{{-1,2},{2,-1}},{{0,2},{2,-2}},{{1,-2},{1,2}},{{1,1},{2,-2}},{{1,1},{2,2}},{{1,2},{2,-1}},{{1,2},{2,1}},{{2,-1},{2,1}},{{2,0},{2,2}},{{-1,2},{2,-2}},{{1,2},{2,-2}},{{2,-1},{2,2}},{{2,1},{2,2}},{{-2,2},{2,-2}},{{2,-2},{2,2}}}}  

Continuing.... the number of pairs for max(abs())  =  n   is   -1 + 5 n + 4 n^3   

... which surprised me.    

[Ed Pegg]

If anyone is curious, the number of point triples is controlled by a quintic.  
Table[(3 - 11 n + 24 n^2 + 8 n^3 + 24 n^5)/3, {n, 1, 10}]  
{16, 303, 2078, 8477, 25516, 63051, 135738, 263993, 474952, 803431}  

From {-1,0,1}, there are sixteen canonical sets of 3 points, eliminating rotations and reflections.  
{{{0,-1},{0,0},{0,1}}, {{0,0},{0,1},{1,0}}, {{0,-1},{0,1},{1,0}}, {{0,0},{0,1},{1,-1}},
{{0,0},{1,0},{1,1}}, {{-1,1},{0,-1},{1,0}}, {{-1,1},{0,0},{1,-1}}, {{0,-1},{0,1},{1,1}},
{{0,0},{1,-1},{1,1}}, {{0,1},{1,-1},{1,0}}, {{0,1},{1,0},{1,1}}, {{-1,1},{0,-1},{1,1}},
{{-1,1},{1,-1},{1,0}}, {{0,1},{1,-1},{1,1}}, {{1,-1},{1,0},{1,1}}, {{-1,1},{1,-1},{1,1}}}  

Here is less clunky code for canonicalizing points.  

RotRefPoints[points_] := Module[{mirror, mirrors, reverses},
  mirror = Tuples[{-1, 1}, {2}];
  mirrors = Table[mirror[[a]] # & /@ points, {a, 1, 4}];
  reverses = Reverse[#] & /@ # & /@ mirrors;
  First[Sort[Sort[Union[#]] & /@ Join[mirrors, reverses]]]
  ]

--
You received this message because you are subscribed to the Google Groups "SeqFan" group.
To unsubscribe from this group and stop receiving emails from it, send an email to seqfan+un...@googlegroups.com.
To view this discussion visit https://groups.google.com/d/msgid/seqfan/c6bc270a-0596-4e0e-8628-245b337e3a02n%40googlegroups.com.

[Ed Pegg]

I submitted https://oeis.org/draft/A383854  

[Ed Pegg]

I have a first hack at a proof that the polynomial −1+5 n+4 n^3 is valid. 
I basically tallied how often each point got used in the canonical form.  
    
asymmetrySort[points_] := SortBy[points, {-Abs[#], #} &];  

DihedralCanonicalization[points_] :=
 Module[{mirror, asymmetry, mirrors, reverses},

  mirror = Tuples[{-1, 1}, {2}];

  asymmetry = asymmetrySort[Union[points]];
  mirrors = Table[mirror[[a]] # & /@ asymmetry, {a, 1, 4}];

  reverses = Reverse[#] & /@ # & /@ mirrors;

  First[Sort[asymmetrySort[#] & /@ Join[mirrors, reverses]]]
  ]

pairs = Subsets[Tuples[Range[-10, 10], {2}], {2}];
invariants = Union[DihedralCanonicalization /@ pairs];
gat = GatherBy[SortBy[invariants, Max[Abs[Flatten[#]]] &],
   Max[Abs[Flatten[#]]] &];
mat = Table[Normal[SparseArray[((#[[1]] + k + 1) -> #[[2]]) & /@ Tally[Flatten[gat2[[k]], 1]]]], {k, 1, 10}]

The first few matrices are as seen below.  The first row of each matrix is the interesting part.  

The first term  A014106   a(n) = n*(2*n + 3)    5, 14, 27, 44, 65, 90, 119
The second term  a(n) =  −4+4n+4n^2  .   4, 20, 44, 76, 116, 164, 220, 284, 356, 436

The middle term in each row is A005893  2*n^2+2   4, 10, 20, 34, 52, 74, 100, 130, 164, 202
The third term is the second term - 7 (until the middle row is reached)
The fourth term is the third term - 7 (until the middle row is reached)  
... and so on.
All other entries in the matrix are based on n.   

Sum up all the values in a matrix and divide by 2 to get −1+5 n+4 n^3  





{{{5,4,1},{1,2,1},{0,1,1}},
{{14,20,10,2,1},{1,3,3,2,2},{2,2,3,2,2},{0,2,2,2,2},{0,1,2,1,1}},
{{27,44,37,20,3,2,1},{1,4,4,4,3,3,2},{2,3,4,4,3,3,3},{3,3,3,4,3,3,3},{1,3,3,3,3,3,3},{0,3,3,3,2,3,2},{0,1,2,3,2,1,1}},
{{44,76,69,62,34,4,3,2,1},{1,5,5,5,5,4,4,4,2},{2,4,5,5,5,4,4,4,3},{3,4,4,5,5,4,4,4,4},{4,4,4,4,5,4,4,4,4},{2,4,4,4,4,4,4,4,4},{1,4,4,4,4,3,4,4,3},{0,4,4,4,4,3,3,4,2},{0,1,2,3,4,3,2,1,1}},

{{230,436,429,422,415,408,401,394,387,380,202,10,9,8,7,6,5,4,3,2,1},{1,11,11,11,11,11,11,11,11,11,11,10,10,10,10,10,10,10,10,10,2},{2,10,11,11,11,11,11,11,11,11,11,10,10,10,10,10,10,10,10,10,3},{3,10,10,11,11,11,11,11,11,11,11,10,10,10,10,10,10,10,10,10,4},{4,10,10,10,11,11,11,11,11,11,11,10,10,10,10,10,10,10,10,10,5},{5,10,10,10,10,11,11,11,11,11,11,10,10,10,10,10,10,10,10,10,6},{6,10,10,10,10,10,11,11,11,11,11,10,10,10,10,10,10,10,10,10,7},{7,10,10,10,10,10,10,11,11,11,11,10,10,10,10,10,10,10,10,10,8},{8,10,10,10,10,10,10,10,11,11,11,10,10,10,10,10,10,10,10,10,9},{9,10,10,10,10,10,10,10,10,11,11,10,10,10,10,10,10,10,10,10,10},{10,10,10,10,10,10,10,10,10,10,11,10,10,10,10,10,10,10,10,10,10},{8,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10},{7,10,10,10,10,10,10,10,10,10,10,9,10,10,10,10,10,10,10,10,9},{6,10,10,10,10,10,10,10,10,10,10,9,9,10,10,10,10,10,10,10,8},{5,10,10,10,10,10,10,10,10,10,10,9,9,9,10,10,10,10,10,10,7},{4,10,10,10,10,10,10,10,10,10,10,9,9,9,9,10,10,10,10,10,6},{3,10,10,10,10,10,10,10,10,10,10,9,9,9,9,9,10,10,10,10,5},{2,10,10,10,10,10,10,10,10,10,10,9,9,9,9,9,9,10,10,10,4},{1,10,10,10,10,10,10,10,10,10,10,9,9,9,9,9,9,9,10,10,3},{0,10,10,10,10,10,10,10,10,10,10,9,9,9,9,9,9,9,9,10,2},
{0,1,2,3,4,5,6,7,8,9,10,9,8,7,6,5,4,3,2,1,1}}}