16
\$\begingroup\$

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 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 (32), 1 + 15 = 16 (42), 15 + 10 = 25 (52) and so forth.

The 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 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
\$\endgroup\$
8
  • 2
    \$\begingroup\$ Would you add one or two more test cases? This challenge is a little bit hard to read right now, and I had to read it multiple times to understand it \$\endgroup\$
    – noodle man
    Sep 18, 2023 at 22:07
  • 1
    \$\begingroup\$ @noodleman is that better? I’ve also corrected the language to permutation since subsequence implies the order is kept constant \$\endgroup\$ Sep 18, 2023 at 22:28
  • 1
    \$\begingroup\$ @Arnauld "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.)" \$\endgroup\$
    – noodle man
    Sep 18, 2023 at 22:39
  • 1
    \$\begingroup\$ What brute-forcing are you trying to discourage? I assume just trying all possible lists? If so is it OK if our answer does not get all the way to 27? \$\endgroup\$ Sep 19, 2023 at 0:19
  • 3
    \$\begingroup\$ I have a non-bruteforce solution that runs up to 24 on TIO (~55 seconds), and times out for higher inputs. I’m sure it would run up to 27 on e.g. my personal computer (though I can’t test it right now). What constitutes an "equivalent environment" to TIO? \$\endgroup\$
    – Fatalize
    Sep 19, 2023 at 13:02

10 Answers 10

5
\$\begingroup\$

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))]
}
\$\endgroup\$
3
\$\begingroup\$

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!

\$\endgroup\$
3
\$\begingroup\$

APL (Dyalog APL), 37 bytes

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

Attempt This Online!

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

\$\endgroup\$
2
\$\begingroup\$

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!

\$\endgroup\$
2
  • \$\begingroup\$ If you change range(1,int((2*k)**0.5)+1) to range(int((2*k)**0.5)) and i**2 to ~i*~i you can save 3 bytes; if len(s)>1:D[len(s)]=D.get(len(s),[])+[s] can be if(l:=len(s))>1:D[l]=D.get(l,[])+[s] for another -6 bytes; and 0.5 can be .5 for another -1 byte. \$\endgroup\$ Sep 20, 2023 at 7:22
  • \$\begingroup\$ You don't need the if ...>1 check to not add the lists of length 1, since you use D[max(D)] at the end anyway. So the earlier suggested if(l:=len(s))>1:D[l]=D.get(l,[])+[s] can actually be D[l]=D.get((l:=len(s)),[])+[s]. And you can also make a variable for the duplicated range(1,k+1) and put q and D on the same line to save some more bytes: 215 bytes. \$\endgroup\$ Sep 20, 2023 at 7:49
2
\$\begingroup\$

Charcoal, 55 bytes

≔…·¹Nθ≔EθΦ⁻Xθ²ι№θληUMθ⟦ι⟧FθF⁻§η⊖↨ι⁰ι⊞θ⁺ι⟦κ⟧⪫Φθ⁼LιL§θ±¹¶

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:

≔…·¹Nθ

Make a range from 1 to n.

≔EθΦ⁻Xθ²ι№θλη

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

UMθ⟦ι⟧

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

Fθ

Loop over all potential permutations.

F⁻§η⊖↨ι⁰ι

Loop over all remaining next valid adjacent numbers.

⊞θ⁺ι⟦κ⟧

Add the new permutation to the list.

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

Output all permutations of maximal length.

\$\endgroup\$
2
\$\begingroup\$

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!

\$\endgroup\$
2
\$\begingroup\$

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
\$\endgroup\$
0
2
\$\begingroup\$

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.

\$\endgroup\$
2
\$\begingroup\$

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!

\$\endgroup\$
2
\$\begingroup\$

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!

\$\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.