Re: The N-queens problem using pure regexes

[Abigail-II]

Since it's slow like hell (but I've some ideas to speed it up)

Speeding it up turned out to be easier than I thought it was. Below is reworked program that is dramatically faster that the original. But first a table comparing running times of three versions, the original, pure regex solution from the parent node, the faster (still pure regex) solution presented below, and the non-pure variant presented last year. The latter is still the faster solution though.

Timings (values in wall clock seconds):

  N    Original    Faster   Non-pure
 
  4       0.035     0.034      0.035
  5       0.045     0.036      0.036
  6       0.769     0.041      0.038
  7       4.833     0.042      0.038
  8                 0.082      0.049
  9                 0.072      0.044
 10                 0.113      0.056
 11                 3.504      0.051
 12                            0.096
 13                            0.071
 14                            0.577
 15                            0.467
 16                            3.864
 17                            2.289
 18                           19.630
 19                            1.324
 20                          117.227

Before giving the program, some sample output:

$ ./queens -p -n 4
';,a1,a2,a3,a4,
;,b1,b2,b3,b4,
b1:,a3,a4,
b2:,a4,
b3:,a1,
b4:,a1,a2,
;,c1,c2,c3,c4,
c1:,a2,a4,b3,b4,
c2:,a1,a3,b4,
c3:,a2,a4,b1,
c4:,a1,a3,b1,b2,
;,d1,d2,d3,d4,
d1:,a2,a3,b2,b4,c3,c4,
d2:,a1,a3,a4,b1,b3,c4,
d3:,a1,a2,a4,b2,b4,c1,
d4:,a2,a3,b1,b3,c1,c2,
' =~ 
/^;.*,(\w+),.*
;.*,(\w+),.*
[^;]*\2:.*,\1[^;]*
;.*,(\w+),.*
[^;]*\3:.*,\1.*,\2[^;]*
;.*,(\w+),.*
[^;]*\4:.*,\1.*,\2.*,\3[^;]*
/
[a3 b1 c4 d2]
$ ./queens -n 8
[a8 b4 c1 d3 e6 f2 g7 h5]

And here's the program:

#!/usr/bin/perl

use strict;
use warnings 'all';
    
use Getopt::Long;
              
Getopt::Long::Configure ("bundling");
GetOptions ('p|print'    =>  \my $print,
            'P|Print'    =>  \my $Print,
            'n|number=i' => \(my $nr_of_queens = 8)
);
    
my @rows =               1 .. $nr_of_queens;
my @cols = ('a' .. 'z') [0 .. $nr_of_queens - 1];
    
sub a2i {ord ($_ [0]) - ord ('a') + 1}
sub i2a {chr ($_ [0] + ord ('a') - 1)}
 
# Given a square, return all non-attacked squares on columns to
# the *left* of the given square. (a1 is the lower left corner).
sub free {
    my ($C, $R) = $_ [0] =~ /(\D)(\d+)/;
    $C = a2i $C;   
    map {join "" => i2a ($_ -> [0]), $_ -> [1]}
        grep {$_ -> [0] != $C &&
              $_ -> [1] != $R &&
              abs ($_ -> [0] - $C) != abs ($_ -> [1] - $R)}
        map {my $c = a2i $_; map {[$c, $_]} @rows} @cols [0 .. $C - 1]
}
            
my ($str, $re) = ("", "");
    
foreach my $c (@cols) {
    $str .= ";," . (join "," => map {"$c$_"} @rows) . ",\n";
    $re  .= ";.*,(\\w+),.*\n";

    next if $c eq 'a';
 
    map {$str .= "$_:," . join ("," => free ($_)) . ",\n"} map {"$c$_"
+} @rows;

    my $C = a2i $c;
    
    $re .= "[^;]*\\$C:" . join ("" => map {".*,\\$_"} 1 .. $C - 1) . "
+[^;]*\n";
}
        
if ($print || $Print) {
    print "'$str' =~ \n/^$re/\n";
    exit if $Print;
}
            
if (my @a = $str =~ /^$re/) {
    print "[@a]\n";
}
    
__END__

Abigail