(Alternative title: "My undying love for .kv on lists")
Knuth's 'Facsicle 0a' starts with a kind of programmer's cliffhanger:
He moves on to other things without divulging what the unique solution for n = 4 might be. Reading this (on a bus carrying me between cities in Sweden), I flung open a terminal window to write a one-liner to solve the problem. Don't know if Knuth intended to have that effect on the reader, but that's what happened when I read it.
My one-liners are infamously long. Here's what I arrived at:
# Generate all possible permutations of the list @a. The list @prefix
# assists in the recursion, adding its elements before the reordered
# elements of @a.
sub all-possible-orderings(@a, @prefix=[]) {
return [@prefix] unless @a.elems;
return gather for @a.kv -> $k, $v {
my @others = @a[0..^$k, $k^..^*];
take all-possible-orderings(@others, [@prefix, $v]);
}
}
# Returns True if and only if the list @a satisfies the
# Langford property, i.e. each pair of numbers $n has
# exactly $n other numbers between them.
sub langford(@a) {
for 1..@a/2 -> $n {
for @a.kv -> $k1, $v1 {
if $v1 == $n {
for @a[$k1^..^*].kv -> $k2, $v2 {
return False if $v2 == $n != $k2;
}
}
}
}
return True;
}
.join.say for all-possible-orderings([1,1,2,2,3,3]).grep({ langford($_) }).uniq;
This code worked well for n = 3, but for n = 4 it just sat there. Kind of fitting, since the remainder of the Facsicle was about the futility of brute force, more or less. Kind of drove the point home, my PDF reader in the foreground saying things like "A single good idea can reduce the amount of computation by many orders of magnitude", while the perl6 process in a window behind it chewed up all my cycles and all my memory.
So I gave it another go.
# Generates a list of all permutations of the list @candidates
# satisfying the Langford property.
sub langford(@candidates, @slots = [0 xx 2*@candidates]) {
return [@slots] if all @slots;
my @found;
for @candidates -> $c {
for @slots[0..@slots-$c-2].kv -> $k, $v {
if !$v {
if !@slots[$k+$c+1] {
my @new-slots = @slots;
@new-slots[$k, $k+$c+1] = $c, $c;
push @found, langford( (grep { $_ != $c }, @candidates),
@new-slots );
}
last;
}
}
}
return @found;
}
.join.say for langford 1..4;
(moritz++ for the nice line return [@slots] if all @slots; where I had previously used a grep.)
Notice how this solution, besides being faster, is also shorter, simpler, and more fun at parties. It does the n = 4 case in a jiffy, and the n = 7 and n = 8 cases with some hesitation. It could probably easily go higher than that without blowing the stack, but time starts to become the limiting factor at this point.
Anyway, a fun afternoon experiment. It's 2009, and I'm solving combinatorics puzzles in Perl 6. Cool!
(Oh, and it's 23421314, in case you were wondering too.)
Use a function that takes a position and a set of as-yet-unplaced numbers. The position is the first slot that might be free. The function finds the first slot that really is free, and then for each unplaced number tries to place it (also trying to place its pair k+1 positions later). If there are additional unplaced numbers recurse, else you have a solution. (To eliminate the reversed pairs, only print the result if the first number is lower than the last.) You have to remove the the numbers that were placed before going on to the next attempt or returning to the caller.
I implemented that on the train last night (but then didn't bring it with me today). It found the unique solutions for 3 and 4, found that there were no solutions for 5 and 6, and found a dozen or two (I didn't count them) solutions for 7 - all of these cases came back with no noticeable delay.
Re:left-to-right recursive generation is very fast
masak on 2009-05-06T14:53:02
Use a function that takes a position and a set of as-yet-unplaced numbers. The position is the first slot that might be free. The function finds the first slot that really is free, and then for each unplaced number tries to place it (also trying to place its pair k+1 positions later). If there are additional unplaced numbers recurse, else you have a solution.
You've just described my second, non-bruteforce solution given in the post. Did you read it?
(To eliminate the reversed pairs, only print the result if the first number is lower than the last.)
Nice idea. Didn't think of that.
I implemented that on the train last night (but then didn't bring it with me today). It found the unique solutions for 3 and 4, found that there were no solutions for 5 and 6, and found a dozen or two (I didn't count them) solutions for 7 - all of these cases came back with no noticeable delay.
Then I conclude that your algorithm was not in Perl 6.
:) Re:left-to-right recursive generation is very fast
jmm on 2009-05-06T15:10:47
[...]
You've just described my second, non-bruteforce solution given in the post. Did you read it?
Well, I looked at it, but didn't figure out what it was doing.
[...] - all of these cases came back with no noticeable delay.
Then I conclude that your algorithm was not in Perl 6.
:) Nope Perl 5 (and that's probably why I didn't figure out what your solution was doing
:-) Re:left-to-right recursive generation is very fast
masak on 2009-05-06T15:36:15
[...]
You've just described my second, non-bruteforce solution given in the post. Did you read it?
Well, I looked at it, but didn't figure out what it was doing.
[...] - all of these cases came back with no noticeable delay.
Then I conclude that your algorithm was not in Perl 6.
:) Nope Perl 5 (and that's probably why I didn't figure out what your solution was doing
:-) If you find the tuits, it would be interesting to hear what you conclude from a comparison of our two approaches.
Of course, if some particular piece of strange syntax blocks such an endeavor, I'd be very happy to explain the syntax rather than have you trawl the synopses for enlightenment.
Re:left-to-right recursive generation is very fast
jmm on 2009-05-06T15:43:32
[...]
You've just described my second, non-bruteforce solution given in the post. Did you read it?
Well, I looked at it, but didn't figure out what it was doing.
[...] - all of these cases came back with no noticeable delay.
Then I conclude that your algorithm was not in Perl 6.
:) Nope Perl 5 (and that's probably why I didn't figure out what your solution was doing
:-) If you find the tuits, it would be interesting to hear what you conclude from a comparison of our two approaches.
Of course, if some particular piece of strange syntax blocks such an endeavor, I'd be very happy to explain the syntax rather than have you trawl the synopses for enlightenment.
The tuits will take a couple of days. I'll post my perl5 code then too for comparison.
Re:left-to-right recursive generation is very fast
jmm on 2009-05-08T14:27:39
Your solution does a lot of array copy/filter'ing that mine avoids. That's not a fault with Perl6, though.:-)
Also, I think yours is still algorithmically slower than mine. You try every number in every place. I try every number in the first place, then trying the remaining numbers in the remaining places (not all places).
So, the comparison here is not between Perl5 and Perl6, but coding with always using array ops, and sometimes using individual elements.
I have to go to 9 and 10 to get a user-noticeable elapsed time, but then it starts to take off. (From the size of the numbers, it is looking like the time is somewhat less than O(n**2), but definitely greater than O(n).
$ time./langford.pm 9
real 0m0.203s
user 0m0.200s
sys 0m0.000s
$ time./langford.pm 10
real 0m1.091s
user 0m1.088s
sys 0m0.000s
$ time./langford.pm 11 | tail -2
17791 10, 8, 5, 2, 9, 6, 2, 7, 5, 11, 8, 10, 6, 4, 9, 7, 3, 1, 4, 1, 3, 11
17792 10, 8, 5, 3, 7, 9, 6, 3, 5, 11, 8, 10, 7, 6, 4, 9, 1, 2, 1, 4, 2, 11
real 0m7.492s
user 0m7.488s
sys 0m0.012s
$ time./langford.pm 12 | tail -2
108143 11, 9, 6, 4, 2, 10, 8, 2, 4, 6, 12, 9, 11, 5, 7, 8, 10, 3, 1, 5, 1, 3, 7, 12
108144 11, 9, 6, 4, 2, 10, 8, 2, 4, 6, 12, 9, 11, 7, 5, 8, 10, 1, 3, 1, 5, 7, 3, 12
real 0m53.187s
user 0m53.155s
sys 0m0.048s
$ time./langford.pm 13 | tail -2
real 6m39.064s
user 6m38.705s
sys 0m0.044s
It's interesting that you can get a hundred thousand solutions for k==12, and none for k==13.
And here's my Perl 5 code:
#!/usr/bin/perl
use strict;
use warnings;
my $n = shift;
($n =~/^\d+$/) && $n > 2
or die "Usage: $0 <num> # num > 2\n";
my @result = ( 0 ) x (2*$n);
my $found = 0;
my $n2 = $n*2;
try( 0, 1..$n );
sub try {
my( $pos, @nums ) = @_;
while( $result[$pos] ) {
return if ++$pos == $n2;
}
my $tries = @nums;
while( $tries-- ) {
my $guess = shift @nums;
my $otherpos = $pos+$guess+1;
return if $otherpos >= $n2;
unless( $result[$otherpos] ) {
$result[$pos] = $result[$otherpos] = $guess;
if( @nums ) {
try( $pos+1, @nums );
}
elsif( $result[0] < $result[-1] ) {
print ++$found, "\t", join( ', ', @result ), "\n";
}
$result[$pos] = $result[$otherpos] = 0;
}
push @nums, $guess;
}
}