Find the longest permutations of integers from 1..k such that all neighbouring pairs sum to a square

Question

OEIS A090461 details the ‘numbers k for which there exists a permutation of the numbers 1 to k such that the sum of adjacent numbers is a square’. This has also been the subject of Matt Parker’s Numberphile and Alex Bellos’ Monday puzzle.

This code-golf challenge is related to the square sum problem above and asks you to find the longest permutations of integers from 1 to k that have all of the neighbouring pairs sum to squares. Repetition is not allowed, but not all of the integers need to be used where this is impossible.

For example, when provided with the argument of 15, the program should output [[8, 1, 15, 10, 6, 3, 13, 12, 4, 5, 11, 14, 2, 7, 9], [9, 7, 2, 14, 11, 5, 4, 12, 13, 3, 6, 10, 15, 1, 8]]. When provided with an argument of 8, it should output [[6, 3, 1, 8], [8, 1, 3, 6]] (for 8, the longest possible permutation is only 4 numbers). All possible longest permutations should be output, but the order in which they are provided does not matter.

To expand on this further, for 15, first permutation given above is valid because 8 + 1 = 9 (3²), 1 + 15 = 16 (4²), 15 + 10 = 25 (5²) and so forth.

The restricted-time tag has been included to slightly increase the challenge and make brute forcing an answer less attractive. A valid entry should be able to return an answer for any single input from 3 to 27 within 60 seconds when run on tio or an equivalent environment. Otherwise, standard code-golf rules apply. This includes the standard input-output rules.

Interestingly, the sequence of lengths of such maximum-length permutations does not seem to have been posted on OEIS yet. I may subsequently post this there.

Further examples below. In each case, I’ve only given the first permutation for each input for brevity, but all of the valid ones should be returned.

For inputs less than 3, there are no valid answers but this does not have to be handled by your program or function. (You can assume there is at least one valid permutation.)

Input -> Output
2 -> any output or an error (does not have to be handled by your program or function)
3 -> [3,1] and 1 further permutation
4 -> [3,1] and 1 further permutation
5 -> [5,4] and 3 further permutations
6 -> [6,3,1] and 1 further permutation
7 -> [6,3,1] and 1 further permutation
8 -> [8,1,3,6] and 1 further permutation
9 -> [8,1,3,6] and 1 further permutation
10 -> [10,6,3,1,8] and 1 further permutation
11 -> [10,6,3,1,8] and 1 further permutation
12 -> [10,6,3,1,8] and 1 further permutation
13 -> [11,5,4,12,13,3,6,10] and 3 further permutation
14 -> [10,6,3,13,12,4,5,11,14,2,7,9] and 3 further permutation
15 -> [9,7,2,14,11,5,4,12,13,3,6,10,15,1,8] and 1 further permutation
16 -> [16,9,7,2,14,11,5,4,12,13,3,6,10,15,1,8] and 1 further permutation
17 -> [17,8,1,15,10,6,3,13,12,4,5,11,14,2,7,9,16] and 1 further permutation
18 -> [17,8,1,15,10,6,3,13,12,4,5,11,14,2,7,9,16] and 1 further permutation
19 -> [19,17,8,1,15,10,6,3,13,12,4,5,11,14,2,7,9,16] and 7 further permutations
20 -> [20,16,9,7,2,14,11,5,4,12,13,3,6,19,17,8,1,15,10] and 15 further permutations
21 -> [21,15,10,6,19,17,8,1,3,13,12,4,5,20,16,9,7,2,14,11] and 7 further permutations
22 -> [18,7,9,16,20,5,11,14,22,3,13,12,4,21,15,10,6,19,17,8,1] and 17 further permutations
23 -> [22,3,1,8,17,19,6,10,15,21,4,12,13,23,2,14,11,5,20,16,9,7,18] and 5 further permutations
24 -> [24,12,13,23,2,14,22,3,1,8,17,19,6,10,15,21,4,5,20,16,9,7,18] and 77 further permutations
25 -> [23,2,14,22,3,13,12,4,21,15,10,6,19,17,8,1,24,25,11,5,20,16,9,7,18] and 19 further permutations
26 -> [26,23,2,14,22,3,13,12,4,21,15,10,6,19,17,8,1,24,25,11,5,20,16,9,7,18] and 23 further permutations
27 -> [27,22,14,2,23,26,10,15,21,4,12,13,3,6,19,17,8,1,24,25,11,5,20,16,9,7,18] and 69 further permutations

Answer 1

R, 139 bytes

\(n,f=\(a,b,i=which(!(a+b[1])^.5%%1))`if`(sum(i),unlist(Map(\(i)f(a[-i],c(a[i],b)),i),F),list(b)))(a=f(1:n,{},1:n))[(l=lengths(a))==max(l)]

Attempt This Online!

Ungolfed

longest_perm_with_all_adjacent_squares=
function(n){

    # first define the recursive helper function f:
    f=function(a,b={}){
        # a is a vector of values that haven't been used yet, to choose the next value from;
        # b is the (initially empty) growing result containing only adjacent values that sum to squares 

        if(length(b)==0)i=seq(along=a) else i=which(sqrt(a+b[1])%%1==0)
        # i is the vector of indices of a that we can use at each step

        if(length(i)==0)return(list(b)) 
        # if we can't use any more values from a, then just return the result-so-far

        else return(unlist(lapply(i,function(i)f(a[-i],c(a[i],b))),recursive=F))
        # otherwise, prepent each valid value from a to b, and perform a recursive call
    }

    # launch the helper function with the sequence 1..n in a, and leaving b empty by default:
    ans=f(1:n)

    # finally, select only the results with maximum length:
    ans[lengths(ans)==max(lengths(ans))]
}

Answer 2

Jelly,  29  26 bytes

0ịịḟ⁸⁸;Ɱ
²€_Ɱf€RɓW€ç€Ẏ¥ƬṖṪ

A monadic Link that accepts a positive integer greater than \$2\$ and yields all possible sequences of maximal length.

Try it online!

How?

0ịịḟ⁸⁸;Ɱ - Link 1: list of ints, Sequence; list of lists of ints, Continuations
0ị       - last element of {Sequence}
  ị      - index into {Continuations} -> ints that will sum to a square
   ḟ⁸    - filter out elements of left argument (Sequence)
             -> removes those that would cause duplicates
     ⁸;Ɱ - concatenate each to left argument
             -> list of new, longer sequences (empty if none possible)

²€_Ɱf€RɓW€ç€Ẏ¥ƬṖṪ - Main Link: integer, k > 2
²€                - square each {[1..k]} -> [1, 4, 9, 16, ..., k²]
  _Ɱ              - subtract mapped across {[1..k]}
    f€R           - filter each keeping those in [1..k]
                      -> Continuations by current value:
                         [[3, 8, 15, ...], [2, 7, 14, ...], [1, 6, 13, ...], ...]
       ɓ          - start a new dyadic chain - f(k, ValidContinuations)
        W€        - wrap each of {[1..k]} -> [[1], [2], [3], ...]
              Ƭ   - start with Seqs=that and collect while distinct, applying:
             ¥    -   last two links as a dyad - f(Seqs, Continuations):
          ç€      -     call Link 1 as a dyad - f(Sequence, Continuations)
            Ẏ     -     tighten back to a list of sequences
               Ṗ  - pop -> removes the empty list found last 
                Ṫ - tail -> maximal length sequences

---

21 bytes (k=25)

Not brute force, but still times out for \$k=26\$:

W€;þẎ-.ịSƲƲƇQƑƇʋƬRṖṪ

Try it online!

Answer 3

APL (Dyalog APL), 37 bytes

{×≢n←⊃,/(⊂,¨⍺∩⊢~⍨(×⍨⍺)-⊢/)¨⍵:⍺∇n⋄⍵}⍨⍳

Attempt This Online!

Recursive approach, generates all results from 3 to 27 in a second.

Answer 4

Python3, 238 bytes:

def f(k):
 q=[([i],{*range(1,k+1)}-{i})for i in range(1,k+1)]
 D={}
 while q:
  s,r=q.pop(0)
  if len(s)>1:D[len(s)]=D.get(len(s),[])+[s]
  for i in range(1,int((2*k)**0.5)+1):
   if(K:=i**2-s[-1])in r:q+=[(s+[K],r-{K})]
 return D[max(D)]

Try it online!

Answer 5

Charcoal, 55 bytes

≔…·¹Ｎθ≔ＥθΦ⁻Ｘθ²ι№θληＵＭθ⟦ι⟧ＦθＦ⁻§η⊖↨ι⁰ι⊞θ⁺ι⟦κ⟧⪫Φθ⁼ＬιＬ§θ±¹¶

Try it online! Link is to verbose version of code. Program was originally more efficient but I slowed it down slightly in the name of code golf, but not so much that it can't easily solve n=27 on TIO. Explanation:

≔…·¹Ｎθ

Make a range from 1 to n.

≔ＥθΦ⁻Ｘθ²ι№θλη

For each element of that range, make a list of all valid adjacent numbers.

ＵＭθ⟦ι⟧

Wrap each element of that range in a list so that it can be the first element of a potential permutation.

Ｆθ

Loop over all potential permutations.

Ｆ⁻§η⊖↨ι⁰ι

Loop over all remaining next valid adjacent numbers.

⊞θ⁺ι⟦κ⟧

Add the new permutation to the list.

⪫Φθ⁼ＬιＬ§θ±¹¶

Output all permutations of maximal length.

Answer 6

Python 3.8, 127 bytes

f=lambda k,p=0:(r:=range(1,k+1))and(c:=[l+[v]for l in p or[[i]for i in r]for v in r if(l[-1]+v)**.5%1==(v in l)])and f(k,c)or p

Try it online!

Answer 7

JavaScript (ES7), 137 bytes

f=(n,k=n)=>(P=(a,...p)=>o=p[a.map(v=>(++v+p[0])**.5%1||P(a.filter(x=>v+~x),v,...p)),k]?[...o,p]:o)([...Array(n).keys(o=[])])+o?o:f(n,k-1)

Try it online!

Commented

f = (                 // f is a recursive function taking:
  n,                  //   n = input
  k = n               //   k = target permutation length (+1)
) => (                //
  P =                 // P is a recursive function taking:
      (a,             //   a[] = source array
          ...p) =>    //   p[] = permutation of a[]
  o = p[              //
    a.map(v =>        // for each value v in a[]:
      (++v +          //   increment v ([0..n-1] -> [1..n])
             p[0])    //   abort if v + p[0] ...
      ** .5 % 1 ||    //   ... is not a perfect square
      P(              //   otherwise, do a recursive call to P:
        a.filter(x => //     pass a copy of a[] ...
          v + ~x      //     ... where v is removed
        ),            //
        v, ...p       //     insert v at the beginning of p[]
      )               //   end of recursive call
    ),                // end of map()
    k                 // test p[k]
  ] ?                 // if it's defined:
    [...o, p]         //   append p[] to o[]
  :                   // else:
    o                 //   leave o[] unchanged
)([...Array(n).keys(  // initial call to P with a[] = [0..n-1]
  o = []              // and o[] initialized to an empty array
)]) + o ?             // if o[] is non-empty:
  o                   //   return it
:                     // else:
  f(n, k - 1)         //   try again with k - 1

Answer 8

Ruby, 120 bytes

->n{r=z=w=[*1..n];r,w=w,r.flat_map{|b|(z-[*b]).map{|a|[a,*b]}}.reject{|a|b=0;a.any?{|a|b*(b+b=a)**0.5%1>0}}while w[0];r}

Try it online!

Ruby, 96 bytes

f=->n,z=n{w=[*1..n].permutation(z).reject{|a|b=0;a.any?{|a|b*(b+b=a)**0.5%1>0}};w[0]?w:f[n,z-1]}

Try it online!

Super-slow, times out for n=11.

Answer 9

JavaScript (Node.js), 109 bytes

f=(n,s=[[]],t=[])=>s.map(x=>(g=n=>n&&g(n-1,(n+x[0])**.5%1||x.includes(n)||t.push([n,...x])))(n))|t<f?s:f(n,t)

Try it online!

JavaScript (Node.js), 106 bytes

n=>f=(s=[[]],t=[],i=n)=>i?s.map(x=>(i+x[0])**.5%1||x.includes(i)||t.push([i,...x]))&&f(s,t,--i):t<f?s:f(t)

Try it online!

Answer 10

R, 99 bytes

\(n){a=b=1:n;while(length(g<-unlist(Map(\(y)lapply(setdiff(b[!(b+y[1])^.5%%1],y),c,y),a),F)))a=g;a}

Attempt This Online!

Hopefully this is a suitable interval before posting my own answers to my challenge. This is an anonymous function that takes a single numeric argument n and returns a list of integer vectors.

Ungolfed

join_lists <- function(x) {
  unlist(x, recursive = FALSE)
}
find_max_ss_permutations <- function(n) {
  # Initialize two vectors a and b with numbers from 1 to n
  a <- b <- 1:n

  # Iterate while there are permutations with adjacent numbers summing to squares
  while ({
   g <- join_lists(lapply(a, function(y) {
    # Filter elements from b where adjacent numbers sum to squares
    filtered_b <- setdiff(b[!(b + y[1])^.5 %% 1], y)
    
    # Extend existing vector with filtered elements
    lapply(filtered_b, function(item) c(item, y))
    }))
    length(g)
  }) {
    # Update a with the new permutations
    a <- g
  }
  
  # Return the longest possible permutations satisfying the square sum condition
  return(a)
}

Attempt This Online!