Longest arrangement of n-digit square numbers s.t. last digit equals first digit of next

Question

I have this problem: consider all the square numbers with exactly n digits, I want to arrange them such that the last digit of a square is equal to first digit of the next square and find the longest arrangement, how many elements contain and possibly how many of those longest arrangement are possible. Of course some squares will be sorted out, eg.

For n=2 the squares are {16, 25, 36, 49, 64, 81}. So the longest arrangement is {81, 16, 64, 49} with s=4 elements

For n=3 there are s=12 elements and one of the possible arrangements is

{841, 121, 144, 484, 441, 169, 961, 196, 676, 625, 529, 900}

Of course there are some criteria (at most 1 number can start with {2,3,7,8} and if so, must be in the 1st position; at most 1 with 0 as last digit)

I have found something similar here https://www.geeksforgeeks.org/arrange-array-elements-such-that-last-digit-of-an-element-is-equal-to-first-digit-of-the-next-element/ but if I insert multiple numbers with same first and last digit it gives me an error.

Maybe would be easier to construct a number like this: naming the squares with n digits {a₁, a₂, a₃,..., aₖ} (values of k for each n https://oeis.org/A049415)

P = aₕ+aᵢ10ⁿ+aⱼ10²ⁿ+...+ aₘ*10⁽ˢ⁻¹⁾ⁿ

h, I, j,...,m < k

and find the biggest possible number P, but I don't know how to set it up

Answer 1

Define a function to give the n digit squares

range[n_] := Range[Ceiling[Sqrt[10^(n - 1)]], Floor[Sqrt[10^n - 1]]]^2
range[3]
(* {100, 121, 144, 169, 196, 225, 256, 289, 324, 361, 400, 441, 484, \
529, 576, 625, 676, 729, 784, 841, 900, 961} *)

Define a function testing their adjacency

adjacent[x_, y_] := 
 Boole[Last[IntegerDigits[x]] == First[IntegerDigits[y]]]
{adjacent[10, 17], adjacent[12, 25], adjacent[25, 12]}
(* {0, 1, 0} *)

and create the adjacency matrix

adjacency[n_] := Outer[adjacent, #, #]&@range[n]

Use Mathematica's graph type

graph[n_] := 
 AdjacencyGraph[range[n], adjacency[n], VertexLabels -> Automatic]

graph[2]

Define a function to find all the paths between two end points

paths[{x_, y_}, g_Graph] := FindPath[g, x, y, Infinity, All]
paths[{324, 100}, graph[3]]
(* {{324, 441, 100}, {324, 484, 441, 100}, {324, 441, 121, 100}, {324, 
  484, 441, 121, 100}, {324, 441, 169, 961, 100}, {324, 484, 441, 169,
   961, 100}, {324, 441, 169, 961, 121, 100}, {324, 441, 121, 169, 
  961, 100}, {324, 484, 441, 169, 961, 121, 100}, {324, 484, 441, 121,
   169, 961, 100}, {324, 441, 196, 625, 529, 961, 100}, {324, 484, 
  441, 196, 625, 529, 961, 100}, {324, 441, 196, 676, 625, 529, 961, 
  100}, {324, 441, 196, 625, 529, 961, 121, 100}, {324, 441, 121, 196,
   625, 529, 961, 100}, {324, 484, 441, 196, 676, 625, 529, 961, 
  100}, {324, 484, 441, 196, 625, 529, 961, 121, 100}, {324, 484, 441,
   121, 196, 625, 529, 961, 100}, {324, 441, 196, 676, 625, 529, 961, 
  121, 100}, {324, 441, 121, 196, 676, 625, 529, 961, 100}, {324, 484,
   441, 196, 676, 625, 529, 961, 121, 100}, {324, 484, 441, 121, 196, 
  676, 625, 529, 961, 100}} *)

Define a helper function to extract the longest list from a list of lists

longest[u_List] := Module[{max = Max[Length /@ u]},
  SelectFirst[u, Length[#] == max &]]
longest[paths[{324, 100}, graph[3]]]
(* {324, 484, 441, 196, 676, 625, 529, 961, 121, 100} *)

Brute force search, trying every combination

globallongest[n_] := Module[{g = graph[n], r = range[n]},
  longest[Flatten[Outer[paths[{#1, #2}, g] &, r, r], 2]]]

We can easily see that this is the right answer for 2 digit squares

globallongest[2]
(* {81, 16, 64, 49} *)

As predicted the longest path for 3 digit squares has length 12

globallongest[3]
(* {225, 576, 676, 625, 529, 961, 144, 484, 441, 121, 169, 900} *)

Length[globallongest[3]]
(* 12 *)

For 4 digit squares, things slow down

globallongest[4]
(* Still not finished ... *)

I suspect that there is a better way to find the longest path than looking for all of them, but I'm not a graph theorist.

Answer 2

Another Graph approach but by constructing a cyclic directed graph and then using brute force by FindPath.

Using mikado squares function.

f[n_Integer?Positive] := Range[Ceiling[Sqrt[10^(n - 1)]], Floor[Sqrt[10^n - 1]]]^2

gives

vals = f[3]

{100, 121, 144, 169, 196, 225, 256, 289, 324, 361, 400, 441, 484,
 529, 576, 625, 676, 729, 784, 841, 900, 961}

A cyclic directed graph from last digit to first digit can be created by

intFirstLastGraph[nums_] :=
 Module[
  {digits = IntegerDigits[nums][[All, {1, -1}]]}
  , DeleteCases[a_ \[DirectedEdge] a_]@
   Flatten@
    MapIndexed[
     Thread[
       First@#2 \[DirectedEdge] 
        Flatten@Position[digits, {Last@#, _}]] &
     , digits
     ]
  ]

giving

Graph[g = intFirstLastGraph[vals]
 , VertexLabels -> Automatic
 , GraphLayout -> "CircularEmbedding"
 ]

Using FindPath and MaximalBy the longest paths can be extracted by brute force.

longestPathDCG[g_] :=
 Module[
  {vl = VertexList[g], paths}
  , paths = 
   Function[i, Flatten[FindPath[g, i, #, Infinity, All] & /@ vl, 1]] /@
     vl
  ; MaximalBy[Flatten[paths, 1], Length]
  ]

giving

longest = vals[[#]] & /@ longestPathDCG[g]

which gives 26 paths of length 12

{Length@longest, DeleteDuplicates[Length /@ longest]}

{26, {12}}

Hope this helps.