PWC 382 Hamiltonian Cycle

It would be so easy to say that the musical selection for this week's challenges is the Hamilton soundtrack, but what came to mind is that these are search problems, so I'm reaching back fifty years to Chicago and "(I've Been) Searchin' So Long".

Task 1: Hamiltonian Cycles

You are given a target number. Write a script to arrange all the whole numbers from 1 up to the given target number into a circle so that every pair of side-by-side numbers adds up to a perfect square. Please make sure, the last number and the first must also add up to a square.

Example: for n=32, a cycle would be: 1, 8, 28, 21, 4, 32, 17, 19, 30, 6, 3, 13, 12, 24, 25, 11, 5, 31, 18, 7, 29, 20, 16, 9, 27, 22, 14, 2, 23, 26, 10, 15

Cogitation

Imagine that the numbers 1 through n are nodes in a graph. There's an edge from one node to another if their sum is a square (1 can go to 8 or 3 or 15, for example). The problem is to visit each node once in this graph, and end up back at the start node -- a Hamiltonian cycle. This is related to the traveling salesman problem, and is in the same NP-complete category of being potentially very difficult to solve in the general case.

Instead of explicitly building a representation of this graph, I took the approach of a breadth-first search. Let's start with 1 (any starting point will do, since it's a cycle), and queue up all the subsequent numbers that would work (1,3, 1,8, 1,15, 1,24). Then, from the remaining numbers, let's branch out to the next possibilities (1,3,6, 1,3,12, 1,3,21, 1,8,7, etc.), and continue evaluating each growing sequence until it either gets back to the start or runs out of square sums.

Implementation

The first thing I need to know is which square numbers are in play. The largest sum we can form is n+(n-1), so I want a list of squares that are less than 2n-1.

state @Square = map { $_*$_ } 2 .. floor(sqrt(2*$n - 1));

My breadth-first search is going to build up a queue of possible sequences, and the remaining available numbers excluding what's in the sequence. The seed sequence is [1], with the numbers from 2 to n available.

my @queue = ( [ [1], [ 2 .. $n] ] );

@queue is a list of pairs; each member of the pair is a list.

Now, while there are things in the queue, we want to try to extend each sequence with a number that adds up to a square. The basic structure of the loop will look like

    my @cycle;  # There can be more than one
    while ( @queue )
    {
        my ($sequence, $available) = shift(@queue)->@*;
        if ( @$available == 0 ) {
            # Used up all the numbers, is it a cycle?
        }
        else {
            my $j = $sequence->[-1]; # End of the sequence
            # Extend the sequence if possible, or drop it
        }
    }
    return \@cycle;

If we have a sequence that uses up all the numbers, we need to verify that it completes a cycle by adding the first and last numbers. If so, we can save the sequence as a possible return value. If not, oh well, we wasted time and we go on the next possibility in the queue.

        if ( @$available == 0 )
        {
            if ( any { $_ == $sequence->[0] + $sequence->[-1] } @Square )
            {
                push @cycle, $sequence;
            }
            else { next; }
        }

The first and last elements of the sequence are from indexes 0 and -1. I use List::Util::any to check if that sum exists in @Square, the short list of possible squares that we set up at the beginning.

The other possibility is that we can try to extend the sequence. Given the last number from the sequence (call it $j), we need to add a number to it to reach a square. The possibilities are all squares from @Square that are greater then $j. If those numbers are available, move the number from the $available list to the $sequence list, and then add that to the end of the queue.

my $j = $sequence->[-1];
for my $sq ( grep { $_ > $j } @Square )
{
    my $diff = $sq - $j;
    if ( (my $which = first_index { $_ == $diff } $available->@*) >= 0 )
    {
        my @avail = $available->@[0..$which-1, $which+1 .. $available->$#*];
        push @queue, [ [ $sequence->@*, $diff ], [ @avail ] ];
    }
}

Notes:

• The end of the list is right there at index [-1].
• The only possible squares we might form are ones that are bigger then $j and in the @Square list we helpfully formed earlier, so let's only consider that short list.
• I'm using List::MoreUtils::first_index to look up the number I need. It's a linear search but in a short list, so possible inefficiency doesn't bother me much.
• Having the index makes it possible to reduce my new available list by using an array slice to select the ranges before and after the element we want to delete.
• We can now push our new, longer sequence and our new, shorter available list to the end of the queue for consideration later.

Okay, finally all in one piece, this is what I have:

sub task($n)
{
    use List::AllUtils qw/any first_index/;
    # All the squares that might be sums of the available numbers.
    state @Square = map { $_*$_ } 2 .. floor(sqrt(2*$n - 1));

    my @queue = ( [ [1], [ 2 .. $n] ] );

    my @cycle = ();
    while ( @queue )
    {
        my ($sequence, $available) = shift(@queue)->@*;
        if ( @$available == 0 )
        {
            if ( any { $_ == $sequence->[0] + $sequence->[-1] } @Square )
            {
                push @cycle, $sequence;
            }
            else { next; }
        }

        my $j = $sequence->[-1];
        for my $sq ( grep { $_ > $j } @Square )
        {
            my $diff = $sq - $j;
            if ( (my $which = first_index { $_ == $diff } $available->@*) >= 0 )
            {
                my @avail = $available->@[0..$which-1, $which+1 .. $available->$#*];
                push @queue, [ [ $sequence->@*, $diff ], [ @avail ] ];
            }
        }
    }
    return \@cycle;
}

Surprise

So, with all the pieces in place, I run the program and the answer doesn't match the example. It turns out that there are multiple possible Hamiltonian cycles (2 for n=32, 22 for n=34, and 115 for n=35).