#!/usr/bin/perl -w
#
#  Solves the general case of which the "Eight Queens" problem is
#  a single example, whereby 2 or more major chess pieces are placed
#  on a standard chess board such that no piece attacks another.
#
#  060113 by liverpole
#

##############
### Strict ###
##############
use strict;
use warnings;


####################
### User-defined ###
####################
my $version         = "1.0 (060113)";   # The current program version
my $attack_symbol   = ".";              # Symbol for an attacked square
my $nticks          = 1024;             # How often is progress updated?

# Which pieces are allowed?  The order is important; putting more powerful
# pieces first in the string causes them to be used first, which will tend
# to speed up the program when more than 1 kind of piece is used.
#
my $allowed_pieces  = "QRGCBNK";


#################
### Libraries ###
#################
use Data::Dumper;
use Getopt::Long;
use File::Basename;
use Legal;


####################
### Declarations ###
####################
sub elapsed_time;
sub show_board;
sub show_progress;
sub try_each_piece_each_square;
sub try_each_square;


###############
### Globals ###
###############
$| = 1;
my $iam = basename $0;

my $verbosity      = 0; # Level of verbosity
my $b_progress     = 0; # Display search progress?
my $b_one_solution = 0; # Quit after first successful solutions
my $show_attacks   = 0; # Display attacked squares?
my $nrows          = 8; # Board has how many rows?  (Default = 8)
my $ncols          = 8; # Board has how many cols?  (Default = 8)
my @rows           = qw( 1 2 3 4 5 6 7 8 );
my @cols           = qw( a b c d e f g h );
my $border         = "+---+---+---+---+---+---+---+---+";

my $syntax = "
    syntax:  $iam  [switches]  <chess piece(s)>

    Solves  a generalized  version  of the 'eight queens' problem, whereby
    some number of major chess pieces (usually 8 queens) of the same color
    have to be placed on a chess board in such a way that no piece attacks
    any other.  (For the purposes of this program, a  'major piece' is any
    piece other than a pawn).

    The command-line arguments are each strings of characters representing
    chess  pieces,  from the set {K, Q, R, B, N} (where 'N' stands for the
    'knight').  As a notational convenience, any  piece may be followed by
    a  count indicating the number of that piece to use.  For example, the
    original 'eight queens' problem can be solved  using either 'QQQQQQQQ'
    or 'Q8'.  Or, to solve the problem of 3 queens, 2 rooks and 2 knights,
    the  following are  all legal:  'QQQ RR NN', 'Q3 R2 N2', and 'Q3R2N2'.

    Switches:

        -r <nrows> ... Specify alternate # of rows (from 2 to 8)
        -c <ncols> ... Specify alternate # of cols (from 2 to 8)
        -a ........... Label squares under attack (forces -vv)
        -1 ........... Quit after 1st solution found (forces -vv)
        -p ........... Display search progress every $nticks boards
        -v ........... Verbose; display solutions (1 per line)
        -vv .......... Very verbose; display board for each solution

";


####################
### Command-line ###
####################
Getopt::Long::Configure("bundling");
GetOptions(
    "r=i"  => \$nrows,
    "c=i"  => \$ncols,
    "a"    => \$show_attacks,
    "1"    => \$b_one_solution,
    "p"    => \$b_progress,
    "v+"   => \$verbosity,
);
my ($pieces, %pieces, @pieces);
$pieces = uc join('', @ARGV) or die $syntax;
while ($pieces =~ s/([$allowed_pieces])(\d*)//i) { $pieces{$1} += $2 || 1 }
foreach my $piece (split(//, $allowed_pieces)) {
    push @pieces, (lc $piece) x ($pieces{$piece} || 0);
}
(@pieces > 1) or die "$iam:  need at least 2 pieces from '$allowed_pieces'\n";
($nrows < 2 || $nrows > 8) and die "$iam:  # of rows must be in {2...8}\n";
($ncols < 2 || $ncols > 8) and die "$iam:  # of cols must be in {2...8}\n";
($b_one_solution or $show_attacks) and $verbosity = 2;


####################
### Main program ###
####################
my $plegal = new Legal();
@rows = splice(@rows, 0, $nrows);
@cols = splice(@cols, 0, $ncols);
my @all_legal_squares;
$border = ' ' . ("+---" x $ncols) . '+';
foreach my $col (@cols) {
    foreach my $row (@rows) {
        push @all_legal_squares, "$col$row";
    }
}

# The number of levels of recursion is equal to the number of pieces
my $N = @pieces;
my $start = time;
try_each_piece_each_square($N, 0, \@pieces);


###################
### Subroutines ###
###################

#
#  sub try_each_square
#
#  Tries putting a given piece on every available square of the board.
#  The piece will only be placed if it doesn't attack any piece already
#  on the board, nor itself comes under attack from any piece already on
#  the board.
#
#  Whenever a piece is successfully placed, a recursive call back into
#  try_each_piece_each_square() occurs to try placing another available
#  piece.
#
sub try_each_square {
    my ($N, $plevel, $ppieces, $pboard, $piece, $pp) = @_;

    # Save the current set of legal squares remaining for this piece
    my @saved_legal_moves = @{$pp->{'legal'}->{$piece}};
    my $nattacks = $pp->{'nattacks'};

    SQUARE:  while (my $square = shift @{$pp->{'legal'}->{$piece}}) {
        # If the square is not empty, skip to the next square.
        defined($pboard->{$square}) and next;

        # Increment the total number of boards tried
        my $nboards = ++$pp->{'nboards'};

        # If search progress was requested (-p) and enough new boards have
        # been tried, issue a one-line progress report.
        #
        if ($b_progress && $nboards - $pp->{'lastboard'} >= $nticks) {
            show_progress($pp);
        }

        # If the square is under attack, skip to the next square.
        ($nattacks->{$square} > 0) and next;

        # If putting the given piece on the given square would attack
        # another piece already on the board, skip to the next square.
        #
        my $pthis = $plegal->attacks($piece, $square);
        map { defined($pboard->{$_}) and next SQUARE } @$pthis;

        # Place the piece on the board, ...
        $pboard->{$square} = $piece;

        # ... mark the squares it attacks ...
        map { ++$nattacks->{$_} } @$pthis;

        # ... and try more pieces on other squares ...
        try_each_piece_each_square($N, $plevel, $ppieces, $pboard, $pp);

        # ... and finally, remove the piece from the square, and
        # demote the squares it attacks.
        #
        delete $pboard->{$square};
        map { --$nattacks->{$_} } @$pthis;
    }

    # Reset the current legal moves
    $pp->{'legal'}->{$piece} = [ @saved_legal_moves ];
}


#
#  sub try_each_piece_each_square
#
#  Tries putting each piece on every square of the board.  For every piece
#  left to try placing, a recursive call is made to try_each_square(), which
#  will call this subroutine again with any position which placed the piece
#  successfully.  If all pieces are placed, that qualifies as a solution.
#
sub try_each_piece_each_square {
    my ($N, $plevel, $ppieces, $pboard, $pp) = @_;

    # Check level
    my $level = (!$plevel)? 1: $$plevel + 1;
    
    # Initialization (Called once at the beginning of all loops)
    if (1 == $level) {
        # Called prior to the first loop only
        # The struct 'pp' is a pointer to 'persistent' data; variables
        # which we want to be able to modify at different recursion levels.
        #
        $pboard = { };
        my $nattacks = { map { $_ => 0 } @all_legal_squares };
        $pp = {
            'nsolutions' => 0,          # Total solutions found
            'nboards'    => 0,          # Total boards tried
            'lastboard'  => 0,          # Last board displayed
            'legal'      => { },        # All legal squares (for a given piece)
            'nattacks'   => $nattacks,  # Level of attack on each square
        };
    }

    # Call loop N times
    if ($level <= $N) {
        # If this piece is the first piece of any being placed, or
        # or first piece of this type -- allow all legal squares to
        # be considered for the piece.
        #
        my $piece = $ppieces->[$level - 1];
        if ($level < 2 or $ppieces->[$level - 2] ne $piece) {
            $pp->{'legal'}->{$piece} = [ @all_legal_squares ];
        }

        # Then see whether placing the piece onto the board would attack
        # any other square.  If NOT, place it, and invoke a new loop.
        #
        try_each_square($N, \$level, $ppieces, $pboard, $piece, $pp);
    } else {
        # If we get this far, we've got a board in which none of the pieces
        # attack any others!  Increment the count, and (optionally) display
        # the board.
        #
        ++$pp->{'nsolutions'};  # Increment solutions found
        $verbosity and show_board($pboard, $pp);
        $b_one_solution and die "Found solution -- quitting\n";
    }

    # Finalization (Called once at the end of all loops)
    if (0 == --$level) {
        show_progress($pp, 1);
    }
}


#
#  sub elapsed_time
#
#  Returns a string containing the current elapsed time nicely formatted.
#
sub elapsed_time {
    my $nsecs = time - $start;
    my $hours = int($nsecs / 3600); $nsecs -= 3600 * $hours;
    my $mins  = int($nsecs / 60);   $nsecs -= 60 * $mins;
    return sprintf "%02d:%02d:%02d", $hours, $mins, $nsecs;
}


#
#  sub show_progress
#
#  Shows the current elapsed time, the number of solutions found,
#  the total number of boards tried, and the solution rate as a
#  percentage.
#
sub show_progress {
    my ($pp, $b_final) = @_;
    my $pct = 100 * $pp->{'nsolutions'} / $pp->{'nboards'};
    printf STDERR "%s  ", elapsed_time();
    $b_final and print STDERR "<Final>  ";
    printf STDERR "Solutions: %-d  ", $pp->{'nsolutions'};
    printf STDERR "Boards: %-d  ", $pp->{'nboards'};
    printf STDERR "Rate: %.3f%% \r", $pct;
    $pp->{'lastboard'} = $pp->{'nboards'};
    $b_final and print STDERR "\n\n";
    $b_final or ++$b_progress;
}


#
#  sub show_board
#
#  Displays the given board in shorthand notation.  If the verbosity level
#  is high enough (-vv), displays an ascii representation of the board with
#  all the pieces on it.
#
sub show_board {
    my ($pboard, $pp) = @_;
    if ($b_progress > 1) {
        print STDERR "\n";
        $b_progress = 1;
    }
    my $sol = join(' ', map { $_ . uc $pboard->{$_} } sort keys %$pboard);
    my $nsolutions    = $pp->{'nsolutions'};
    my $nboards = $pp->{'nboards'};
    printf STDERR "%s  ", elapsed_time();
    printf "Solution # %-d  Board # %-d  [%s]\n", $nsolutions, $nboards, $sol;
    if ($verbosity > 1) {
        print "$border\n";
        foreach my $row (reverse @rows) {
            print " | ";
            foreach my $col (@cols) {
                my $square = "${col}${row}";
                my $piece = uc $pboard->{$square} || " ";
                if ($show_attacks && $piece eq " ") {
                    if ($plegal->is_attacked($pboard, $square)) {
                        $piece = $attack_symbol;
                    }
                }
                printf "$piece | ";
            }
            print "$row\n$border\n";
        }
        printf "   %s\n\n", join('   ', @cols);
    }
}