Peaceful chess queen armies: Difference between revisions

===Terse===

<lang perl>use strict;

my $gaps = join '|', qr/-*/, map qr/.{$_}(?:-.{$_})*/s, $n-1, $n, $n+1;

place( scalar ('-' x $n . "\n") x $n );

<pre>Solution to 4 5

W---W</pre>

===Verbose===

A refactored version of the same code, with fancier output. Does not scale well for larger boards.

<lang perl>use strict;

use warnings;

use feature 'say';

use feature 'state';

use utf8;

binmode(STDOUT, ':utf8');

my $solution; # algorithm requires this variable to be global

# recursively place the next queen

sub place {

my($board, $n, $m, $empty_square) = @_;

state %seen;

# logic of 'attack' regex: queen ( ... paths between queens containing only empty squares ... ) queen of other color

my $attack =

'([WB])' . # 1st queen

'(?:' .

join('|',

"[$empty_square]*",

map {

"(?^s:.{$_}(?:[$empty_square].{$_})*)"

} $n-1, $n, $n+1

) .

')' .

'(?!\1)[WB]'; # 2nd queen

# bail out if seen this configuration previously, or attack detected

return if $seen{$board}++ or $board =~ /$attack/;

# success if queen count is m×2

$solution = $board and return if $m * 2 == (my $have = $board =~ tr/WB//);

# place the next queen (alternating colors each time)

place( $board =~ s/[$empty_square]\G/ qw<W B>[$have % 2] /er, $n, $m, $empty_square )

while $board =~ /[$empty_square]/g;

}

my($m, $n) = (shift, shift) || (4, 5);

my $empty_square = '◦•';

my $board = join "\n", map { substr $empty_square x $n, $_%2, $n } 1..$n;

place( $board, $n, $m, $empty_square );

say $solution

? sprintf "Solution to $m $n\n\n%s", map { s/(.)/$1 /gm; s/B /♛/gm; s/W /♕/gmr } $solution

: "No solution to $m $n";</lang>

{{out}}

<pre>Solution to 4 5

• ♛• ♛•

♛• ◦ • ◦

• ◦ ♕◦ ♕

♛• ◦ • ◦

• ◦ ♕◦ ♕