#! /usr/bin/perl
#########################################################################
#        This Perl script is Copyright (c) 2008, Peter J Billam         #
#               c/o DPIWE, Hobart, Tasmania, Australia                  #
#                                                                       #
#     This script is free software; you can redistribute it and/or      #
#            modify it under the same terms as Perl itself.             #
#########################################################################
my $Version       = '3.4';
my $VersionDate   = '7apr2011';
# 20110330 3.4 multiple-take stops on promotion
# 20110330 3.3 does multiple takes
# 20030810 3.2 roll takes and nontakes into possible_moves
# The aim of this version is to use 0,1,2,3,4 instead of q{},w,b,W,B
# or, perhaps, 7,0,1,2,3 for the 3+2+2+2+2.. column storage
# Yes! 0=w 1=b 2=W 3=B and the 3rd-4th bits means is_occupied
# so as to use arrays instead of hashes and speed lookups
# it's tempting to put columns all in the same int..
# as octits, you can only get 10 counters in a 32-bit int,
# (but as 3+2+2+2+2 bits you can still only get 15).  But it's tempting...
# Top counter should be LS because you need it often (taking, possible_moves)
# No: if w is 0b00 then you can't tell
# so 4=w 5=b 6=W 7=B and no separate is_occupied is necessary.

#Total Elapsed Time = 1020.750 Seconds
#  User+System Time = 295.0508 Seconds
#Exclusive Times
#%Time ExclSec CumulS #Calls sec/call Csec/c  Name
# 34.7   102.6 102.62 168625   0.0001 0.0001  main::possible_takes
# 26.3   77.61 77.616 124944   0.0001 0.0001  main::possible_nontakes
# 11.3   33.48 213.72 168625   0.0000 0.0001  main::possible_moves
# 8.82   26.03 178.49 343840   0.0001 0.0005  main::evaluate
# 6.91   20.39 20.390  93556   0.0002 0.0002  DB_File::DoTie_
# 6.54   19.28 307.00  93413   0.0002 0.0033  main::best_move
# 6.17   18.20 18.201 565906   0.0000 0.0000  main::new_position
# 1.14   3.360  3.360  93465   0.0000 0.0000  DB_File::FETCH
# 1.05   3.089 23.479  93556   0.0000 0.0003  DB_File::tie_hash_or_array
# 0.80   2.360  2.360  93556   0.0000 0.0000  DB_File::DESTROY
# 0.20   0.599 24.078  93556   0.0000 0.0003  DB_File::TIEHASH
# 0.01   0.036  0.036   2350   0.0000 0.0000  main::c
# 0.01   0.029  0.029    981   0.0000 0.0000  Term::Clui::puts
# 0.01   0.026  0.063     94   0.0003 0.0007  main::display_tty
# 0.01   0.026  0.042    778   0.0000 0.0001  Term::Clui::wr_cell

# use Term::Clui;
eval 'require "Term/Clui.pm"'; if ($@) { die
	"you'll need to install the Term::Clui module from search.cpan.org/~pjb\n";
}
import Term::Clui;

while ($ARGV[$[] =~ /^-([a-z])/) {
	if ($1 eq 'v')      { shift;
		my $n = $0; $n =~ s{^.*/([^/]+)$}{$1};
		print "$n version $Version $VersionDate\n";
		exit 0;
	} elsif ($1 eq 'c') { &whatever; shift;
	} else {
		print "usage:\n";  my $synopsis = 0;
		while (<DATA>) {
			if (/^=head1 SYNOPSIS/)     { $synopsis = 1; next; }
			if ($synopsis && /^=head1/) { last; }
			if ($synopsis && /\S/)      { s/^\s*/   /; print $_; next; }
		}
		exit 0;
	}
}

# draughts on 7x7 board, whose move = 0, squares a1=1 c1=2 e1=3 g1=4
# b2=5 d2=6 f2=7  a3=8 c3=9 e3=10 g3=11  b4=12 d4=13 f4=14
# a5=15 c5=16 e5=17 g5=18  b6=19 d6=20 f6=21 a7=22 c7=23 e7=24 g7=25

# globals:
# use integer;
my $Db = '/var/tmp/laska_3';
my @square2string = qw( to_move
	a1 c1 e1 g1 b2 d2 f2 a3 c3 e3 g3 b4 d4 f4 a5 c5 e5 g5 b6 d6 f6 a7 c7 e7 g7
);
my @worth; $#worth = 511;
	$worth[04]   = 100; # w
	# wb=>70,  wbb=>65,  wbw=>80,  wbB=>60,  wbW=>90,
	$worth[054]  = 70;  # wb  (read backwards!)
	$worth[0554] = 65;  # wbb
	$worth[0454] = 80;  # wbw
	$worth[0754] = 60;  # wbB
	$worth[0654] = 90;  # wbW
	# ww=>160, wwb=>150, www=>170, wwB=>140, wwW=>180,
	$worth[044]  = 160; # ww  (read backwards!)
	$worth[0544] = 150; # wwb
	$worth[0444] = 170; # www
	$worth[0744] = 140; # wwB
	$worth[0644] = 175; # wwW
	# wB=>60,  wBb=>55,  wBw=>70,  wBB=>50,  wBW=>80,
	$worth[074]  = 60;  # wB  (read backwards!)
	$worth[0574] = 55;  # wBb
	$worth[0474] = 70;  # wBw
	$worth[0774] = 50;  # wBB
	$worth[0674] = 80;  # wBW
	# wW=>170, wWb=>160, wWw=>180, wWB=>150, wWW=>170,
	$worth[064]  = 165; # wW  (read backwards!)
	$worth[0564] = 160; # wWb
	$worth[0464] = 170; # wWw
	$worth[0764] = 150; # wWB
	$worth[0664] = 170; # wWW
	# W=>170,
	$worth[06]   = 170; # w
	# Wb=>120, Wbb=>90,  Wbw=>120, WbB=>80,  WbW=>130,
	$worth[056]  = 120; # Wb  (read backwards!)
	$worth[0556] = 90;  # Wbb
	$worth[0456] = 120; # Wbw
	$worth[0756] = 80;  # WbB
	$worth[0656] = 130; # WbW
	# Ww=>195, Wwb=>192, Www=>190, WwB=>160, WwW=>195,
	$worth[046]  = 185; # Ww  (read backwards!)
	$worth[0546] = 180; # Wwb
	$worth[0446] = 185; # Www
	$worth[0746] = 160; # WwB
	$worth[0646] = 190; # WwW
	# WB=>100, WBb=>80,  WBw=>110, WBB=>90,  WBW=>110,
	$worth[076]  = 100; # WB  (read backwards!)
	$worth[0576] = 80;  # WBb
	$worth[0476] = 110; # WBw
	$worth[0776] = 90;  # WBB
	$worth[0676] = 110; # WBW
	# WW=>200, WWb=>180, WWw=>190, WWB=>200, WWW=>200,
	$worth[066]  = 190; # WW  (read backwards!)
	$worth[0566] = 185; # WWb
	$worth[0466] = 195; # WWw
	$worth[0766] = 180; # WWB
	$worth[0666] = 200; # WWW

foreach my $w_key (0..511) {
	next if 01 & $w_key;
	next unless 04 & $w_key;
	next unless $worth[$w_key] > 1;
	my $b_key;  # flip LSBit of each occupied octit
	if ($w_key >= 64)     { $b_key = 0111 ^ $w_key;
	} elsif ($w_key >= 8) { $b_key = 011  ^ $w_key;
	} else                { $b_key = 01   ^ $w_key;
	}
	$worth[$b_key] = 0 - $worth[$w_key];
}

my @start_position = ( 04, 04,04,04,04, 04,04,04, 04,04,04,04, 0,0,0,
 05,05,05,05, 05,05,05, 05,05,05,05 );
#my @start_position = ( 04, 0,0,0,0, 04,04,04, 04,04,04,04, 0,0,0,
# 05,05,05,05, 05,05,05, 0,0,0,0 );

my @forward_move_squares = ( # from white's point of view [new (, new)]
	[],
	[5],    [5,6],   [6,7],     [7],
	    [8,9],   [9,10], [10,11],
	[12],  [12,13], [13,14],   [14],
	   [15,16], [16,17], [17,18],
	[19],  [19,20], [20,21],   [21],
	   [22,23], [23,24], [24,25],
	[],      [],      [],        [],
);
my @backward_move_squares = (
	[],
	[],      [],       [],       [],
	   [1,2],   [2,3],     [3,4],
	[5],    [5,6],    [6,7],    [7],
	   [8,9],   [9,10],  [10,11],
	[12],  [12,13],  [13,14],  [14],
	   [15,16], [16,17], [17,18],
	[19],  [19,20],  [20,21],  [21],
);
my @officer_move_squares = ([]);
foreach my $sq (1..25) {
	push @officer_move_squares,
	 [ @{$backward_move_squares[$sq]}, @{$forward_move_squares[$sq]} ];
	# print "$sq to ", join (',', @{$officer_move_squares[$sq]}), "\n";
}
my @move_squares; $#move_squares = 7;
	$move_squares[04] = [@forward_move_squares];
	$move_squares[05] = [@backward_move_squares];
	$move_squares[06] = [@officer_move_squares];
	$move_squares[07] = [@officer_move_squares];

my @forward_take_squares = ( # from white's point of view [mid,new, mid,new]
	[],
	[5,9],     [5,8, 6,10],    [6,9, 7,11],     [7,10],
	# 00511, ugg: we have an array of moves :-(
	    [9,13],        [9,12, 10,14],     [10,13],
	[12,16],  [12,15, 13,17], [13,16, 14,18],   [14,17],
	     [16,20],     [16,19, 17,21],     [17,20],
	[19,23],  [19,22, 20,24], [20,23, 21,25],   [21,24],
	  [], [], [],
	[], [], [], [],
);
my @backward_take_squares = (
	[],
	[], [], [], [],
	  [], [], [],
	[5,2],    [5,1, 6,3],    [6,2, 7,4],    [7,3],
	   [9,6],   [9,5, 10,7],  [10,6],
	[12,9],  [12,8, 13,10],  [13,9, 14,11],  [14,10],
	   [16,13], [16,12, 17,14], [17,13],
	[19,16],  [19,15, 20,17],  [20,16, 21,18],  [21,17],
);
my @officer_take_squares = ([]);
foreach my $sq (1..25) {
	push @officer_take_squares,
	 [ @{$backward_take_squares[$sq]}, @{$forward_take_squares[$sq]} ];
	# print "$sq to ", join (',', @{$officer_take_squares[$sq]}), "\n";
}
my @take_squares; $#take_squares = 7;
	$take_squares[04] = [@forward_take_squares];
	$take_squares[05] = [@backward_take_squares];
	$take_squares[06] = [@officer_take_squares];
	$take_squares[07] = [@officer_take_squares];

my $starting_ply = 7;
my $pre_loaded_fen = '';
my @game = ();
my $first_display = 1;
my $up_one_row = "\033[A";
my $clrtoeol   = "\033[K";
my $clrtoeos   = "\033[J";

@position = @start_position;
# XXX must be New Game As White etc, like the JS version. White moves 1st.
my $task = choose('How do you want to play ?',
 'Human moves first', 'Computer moves first', 'Load a FEN position');
if ($task =~ /^Computer/) {
	$position[0] = 05;
	$move = random_choice( [15,12],[16,12],[16,12],[16,13],[16,13],
	 [17,13],[17,13],[17,14],[17,14],[18,14]);
	@position = new_position($move, @position);
	print "My move is ".move2string($move, @position)."$clrtoeol\n";
	push @game, move2string($move, @position);
} elsif ($task =~ /^Human/) {
} elsif ($task =~ /^Load/) {
	$pre_loaded_fen = ask('Enter FEN :');
	exit unless $pre_loaded_fen;
	@position = fen2position($pre_loaded_fen);
	if (!@position) { die "invalid FEN syntax\n"; }
	# should ask whether to analyse or who has which colour
}
display_tty(1,@position);

while (1) {
	$move = choose_move(@position);
	@position = new_position($move, @position);
	push @game, move2string($move, @position);
	display_tty(0,@position);

	($move, $evaluation) = best_move($starting_ply, @position);
	if ($evaluation > 1000000) {
		print "I resign. You win!\n"; goodbye(@position);
	}
	@position = new_position($move, @position);
	push @game, move2string($move, @position);
	display_tty(1,@position);
}
exit 0;

sub goodbye { my @position = @_;
	if ($position[0] & 01) { push @game, '1-0'; } else { push @game, '0-1'; }
	print "\n", game2string(@game);
	print position2fen(@position), "\n\n";
	my $task = choose('Do you want to save that game ?',
		'Save game to file', 'No, just exit'
	);
	if ($task =~ /^Save/) { save_game(@game); }
	exit 0;
}
sub choose_move { my @position = @_;
	my @possible_moves = possible_moves(@position);
	if (! @possible_moves) { print "You lose!\n"; goodbye(@position); }
	my %string2move = ();
	foreach (@possible_moves) { $string2move{move2string($_)} = $_; }
	while (1) {
		my $string = choose("Your move ?\n\n(q for other options)",
		  sort keys %string2move);
		if ($string) { return $string2move{$string}; }
		my $task = choose('What would you like to do ?',
			'View game so far', 'Save game to file','Level', 'Resign'
		);
		if ($task =~ /^Show position/)  { print position2fen(@position), "\n";
		} elsif ($task =~ /^View game/) { view_game(@game);
		} elsif ($task =~ /^Save game/) { save_game(@game);
		} elsif ($task =~ /^Level/)     { level(@game);
		} elsif ($task =~ /^Resign/) { print "I win !\n"; goodbye(@position);
		}
		if (! confirm('Continue the game ?')) { exit 0; }
		print STDERR "$up_one_row$clrtoeol";  # back up one row and clrtoeol
	}
}
sub level {
	my $x = choose("level (currently $starting_ply) = ?", 1..10);
	if ($x) { $starting_ply = 0+$x; }
	print STDERR "$up_one_row$clrtoeol"x2;
}
sub best_move { my ($ply, @position) = @_;
# 1) for speed: DB all analyses (e.g. for cgi use)
# 2) keep game positions and evaluations in memory, and when an evaluation
#    is worse than the previous move's, update the previous moves evaluation
#    and delete all the moves before that!  Cache the remainder in DB
#    at the end of the game.  For steadily increasing quality of play.
#	my %db;
#	if (dbmopen(%db,$Db,0666)) {
#		my $s = $db{position2fen(@position)};
#		dbmclose %db;
#		if ($s) {
#			my ($db_ply,$db_move,$db_eval) = split q{ }, $s;
#			if ($db_ply >= $ply) {
# warn "taking best_move from $Db because ply=$ply and db_ply=$db_ply\n";
#				my @move = map(0+$_, split q{,}, $db_move);
#				return (\@move, 0+$db_eval);
#			} else {
# warn "considered best_move from $Db; but ply=$ply and db_ply=$db_ply only\n";
#			}
#		}
#	}
	my $whites_move;
	if ($position[0] & 01) { $whites_move = -1; } else { $whites_move = 1; }
	my @best_moves = ([24,25]);
	my $best_evaluation = -1000001*$whites_move;  # start pessimist
	my @possible_moves = possible_moves(@position);
	if (! @possible_moves) { return ([0,0], $best_evaluation); }  # we've lost
	my $starting_time;
	if ($ply == $starting_ply) { # only at the top-level call...
		if (1 == @possible_moves) { return ($possible_moves[0], 0); } # forced
		$starting_time = times;
	}
	foreach my $candidate (@possible_moves) {
		my @new_position = new_position($candidate, @position);
		my @new_candidates = possible_moves(@new_position);
		if (! @new_candidates) {
			return ($candidate, 1000002*$whites_move);
		}
		my ($move, $evaluation);
		if ($ply < 1.5) {
			$evaluation = evaluate(@new_position);
		} else {
			my $new_ply = $ply - 1;
			if (1 ==  @possible_moves) { $new_ply = $ply; }
			($move, $evaluation) = best_move($new_ply, @new_position);
		}
		if ($evaluation == $best_evaluation) { # choose randomly from equals
			push @best_moves, $candidate;
		} elsif (($whites_move > 0) && ($evaluation > $best_evaluation)
		 || ($whites_move < 0) && ($evaluation < $best_evaluation)) {
			@best_moves = ($candidate);
			$best_evaluation = $evaluation;
		}
	}
	if ($ply == $starting_ply) {
		my $elapsed_time = times - $starting_time;
		# Should adjust Level by changing these times...
		if (($elapsed_time > 10) && ($starting_ply > 2)) { $starting_ply--;
		} elsif ($elapsed_time < 2) { $starting_ply++;
		}
		my $random_choice = random_choice(@best_moves);
#		if (dbmopen(%db,$Db,0666)) {
#			my $pos_s1 = position2fen(@position);
#			my $pos_s2 = position2fen(mirror_position(@position));
#			my ($from,$mid,$to) = @{$random_choice};  # Multi-takes?
#			my $mov_s1;
#			my $mov_s2;
#			if ($to) {
#				$mov_s1 = "$from,$mid,$to";
#				$from = mirror_square($from);
#				$mid  = mirror_square($mid);
#				$to   = mirror_square($to);
#				$mov_s2 = "$from,$mid,$to";
#			} else {
#				$mov_s1 = "$from,$mid";
#				$from = mirror_square($from);
#				$mid  = mirror_square($mid);
#				$mov_s2 = "$from,$mid";
#			}
#			$db{$pos_s1} = "$ply $mov_s1 $best_evaluation";
#			$db{$pos_s2} = "$ply $mov_s2 $best_evaluation";
#			dbmclose %db;
#		}
		return ($random_choice, $best_evaluation);
	}
	return ($best_moves[0], $best_evaluation);
}
sub mirror_position {
	return
	 @_[0,4,3,2,1,7,6,5,11,10,9,8,14,13,12,18,17,16,15,21,20,19,25,24,23,22];
}
sub mirror_move {
	if (scalar(@_) > 1) {
		return map(mirror_square($_), @_);
	} else {
		return join(',', map(mirror_square($_), split(',',$_[$[])));
	}
}
sub mirror_square { my $sq = $_[0];
	if ($sq <  0) { die "mirror_square: sq=$sq is out of range"; }
	if ($sq == 0) { return  0; }
	if ($sq <  5) { return  5-$sq; }
	if ($sq <  8) { return 12-$sq; }
	if ($sq < 12) { return 19-$sq; }
	if ($sq < 15) { return 26-$sq; }
	if ($sq < 19) { return 33-$sq; }
	if ($sq < 22) { return 40-$sq; }
	if ($sq < 26) { return 47-$sq; }
	die "mirror_square: sq=$sq is out of range";
}
sub random_choice {
	if (1 == @_) { return $_[0]; }
	return $_[int(rand(scalar @_))];
}
sub evaluate { my @position = @_;
	my $evaluation = 0;
	my $number_of_moves;
	my $whites_move;
	while (1) {
		$whites_move = ($position[0] == 04);
		my @possible_moves =  possible_moves(@position);
		$number_of_moves = scalar @possible_moves;
		if (! @possible_moves) { return -1000003*$whites_move; } # defeat
		last if $number_of_moves > 1;
		@position = new_position($possible_moves[0], @position);
	}
	# who's on move
	# number of possible moves
	my @pos = @position;
	$pos[0] = 04; $evaluation += 45 * possible_nontakes(@pos);
	$pos[0] = 05; $evaluation -= 45 * possible_nontakes(@pos);
	# closeness and emptiness of path to promotion
	# worth of each tower
	foreach my $square (1..25) {
		my $piece = (0777 & $position[$square]);
		$evaluation += $worth[$piece];
#warn "square=$square piece=$piece worth=$worth[$piece] evaluation=$evaluation\n";
	}
	return $evaluation;
}

sub possible_moves { my @pos = @_;
	# gives up looking for nontakes as soon as it finds the first take
	my @possible_takes = ();
	my @possible_nontakes = ();
	my $to_move = $pos[0];
	my $square = 0;
	while ($square < 26) { # this loop looks for takes and non_takes
		$square++;
		my $top = 07 & $pos[$square];
		next unless $to_move == ($top & 05);
		my @takes = @{${$take_squares[$top]}[$square]};
		while (@takes) {
			my $mid_sq = shift @takes;
			my $new_sq = shift @takes;  last unless $new_sq;
			next if $pos[$new_sq];
			next unless $pos[$mid_sq];
			if ($to_move == (05 & $pos[$mid_sq])) { next; }
			if (($new_sq>21.5 && $top==04) || ($new_sq<4.5 && $top==05)) {
				push @possible_takes, [$square,$mid_sq,$new_sq];
				next;   # promotion; multi-take stops here
			}
            my @new_position = new_position([$square,$mid_sq,$new_sq],@pos);
            $new_position[0] = $to_move;
            my @further_takes
             = possible_further_takes($mid_sq,$new_sq,@new_position);
            if (@further_takes) {
                foreach my $take (@further_takes) {
                    push @possible_takes, [$square,$mid_sq,$new_sq,@{$take}]
                }
            } else {
                push @possible_takes, [$square,$mid_sq,$new_sq];
            }
		}
		next if @possible_takes;
		foreach my $move_square (@{${$move_squares[$top]}[$square]}) {
			if (!$pos[$move_square]) {
				push @possible_nontakes, [$square, $move_square];
			}
		}
	}
	if (@possible_takes) { return @possible_takes;
	} else {               return @possible_nontakes;
	}
}

sub possible_nontakes { my @position = @_;
	my @possible_nontakes = ();
	my $to_move = $position[0];
	foreach my $square (1..25) {
		my $top = 07 & $position[$square];
		next unless $to_move == ($top & 05);
		foreach my $move_square (@{${$move_squares[$top]}[$square]}) {
			if (!$position[$move_square]) {
				push @possible_nontakes, [$square, $move_square];
			}
		}
	}
	return @possible_nontakes;
}

sub possible_further_takes { my ($prev_sq, $square, @pos) = @_; # from cgi 3.3
	# warn "prev_sq=$prev_sq square=$square pos=@pos\n";
	$#pos=25;
	my @possible_takes = ();
	# my $owner = substr $pos[$square], 0, 1;
	my $owner = 05 & $pos[$square];
	my $topp  = 07 & $pos[$square];
	my @takes = @{${$take_squares[$topp]}[$square]};
	my $to_move = $pos[0];
	# my $not_to_move = 'w'; if ($to_move eq 'w') { $not_to_move = 'b'; }
	my $not_to_move = 9 - $to_move;
	while (@takes) {
		my $mid_sq = shift @takes;
		my $new_sq = shift @takes;
		next if $mid_sq == $prev_sq;
		last unless $new_sq;
		next if $pos[$new_sq];  # next unless new square is empty
		next unless (05 & $pos[$mid_sq]) == $not_to_move;
		if (($new_sq>21.5 && $topp==04) || ($new_sq<4.5 && $topp==05)) {
			push @possible_takes, [$mid_sq,$new_sq];
			next;   # promotion; multi-take stops here
		}
		my @new_position = new_position([$square,$mid_sq,$new_sq],@pos);
		$new_position[0] = $to_move;
		my @further_takes
		 = possible_further_takes($mid_sq,$new_sq,@new_position);
		if (@further_takes) {
			foreach my $take (@further_takes) {
				push @possible_takes, [$mid_sq,$new_sq,@{$take}]
			}
		} else {
			push @possible_takes, [$mid_sq,$new_sq];
		}
	}
	return @possible_takes;
}

sub new_position { my ($move_ref, @pos) = @_;
	my ($old_sq, $mid_sq, $new_sq, @further_takes) = @$move_ref;
	my $piece = $pos[$old_sq];
	my $owner = 05 & $piece;
	if ($owner ne $pos[0]) {
		warn "new_position: piece is $piece, but $owner is not on move\n";
		return;
	}
	if (! $new_sq) {  # it's a plain move, not a take
		$new_sq = $mid_sq;
		if ($pos[$new_sq]) { warn
			"new_position: new_sq $new_sq is occupied by $pos[$new_sq]\n";
			return;
		}
		$pos[$old_sq] = 0;
		$pos[$new_sq] = $piece;
	} else {  #it's a take XXX have to loop along the multiple takes 3.3
		while (1) {
			if (! $pos[$mid_sq]) { warn
				"new_position: mid_sq $mid_sq is unoccupied\n"; return;
			}
			if ($pos[$new_sq]) { warn
				"new_position: new_sq $new_sq is occupied by $pos[$new_sq]\n";
				return;
			}
			my $mid_top = (07 & $pos[$mid_sq]);
			my $mid_bot = 0 + ($pos[$mid_sq] >> 3);
			$pos[$old_sq] = 0;
			$pos[$mid_sq] = $mid_bot;
			$mid_top <<= 3;
			while ($mid_top & $piece) { $mid_top <<= 3; }
			$pos[$new_sq] = ($piece | $mid_top );
# warn "  pos[$old_sq]=$pos[$old_sq] pos[$mid_sq]=$pos[$mid_sq] pos[$new_sq]=$pos[$new_sq]\n";
			last unless @further_takes;
			$old_sq = $new_sq;
			$mid_sq = shift @further_takes;
			$new_sq = shift @further_takes;
		}
	}
	if (($new_sq>21.5 && $owner==04) || ($new_sq<4.5 && $owner == 05)) {
		$pos[$new_sq] |= 02;  # promotion
	}
	if ($owner & 01) { $pos[0] = 04; } else { $pos[0] = 05; }
	return @pos;
}
sub move2string { my $move_ref = shift; my @position = @_;
	my @move = @{$move_ref};
	my $string = $square2string[$move[0]].'-'.$square2string[$move[1]];
	# . piece2string($position[$move[1]]);
	my $i = 2;  while (1) {  # XXXX 3.3 multitakes
		if ($move[$i]) { $string .= q{-}.$square2string[$move[$i]];
		} else { last;
		}
		$i += 1;
	}
	if ($i > 2) {
		$string .= piece2string($position[$move[$i-1]]);
	}
	return $string;
}
sub piece2string { my $piece = $_[0];
	my @octit2char = qw(w b W B);
	my $string = '';
	while ($piece) {
		$string .= $octit2char[03 & $piece];
		$piece >>= 3;
	}
	return $string;
}
sub string2piece { my $string = $_[0];
	my %char2octit = ('w'=>4,'b'=>5,'W'=>6,'B'=>7);
	my $piece = 0;
	foreach my $c (reverse(split('',$string))) {
		$piece <<= 3;
		$piece += $char2octit{$c};
	}
	return $piece;
}
sub position2fen { my @p = map(piece2string($_), @_);
	my $fen = "$p[22],$p[23],$p[24],$p[25]/$p[19],$p[20],$p[21]/"
	. "$p[15],$p[16],$p[17],$p[18]/$p[12],$p[13],$p[14]/"
	. "$p[8],$p[9],$p[10],$p[11]/$p[5],$p[6],$p[7]/"
	. "$p[1],$p[2],$p[3],$p[4] $p[0]";
	$fen =~ s:/,,,?/://:g;
	return $fen;
}
sub fen2position { $fen = shift;
	# must be more defensive; this could be typed or pasted in by the user.
	my @position = (); $#position = 24;
	my @rows = split '[/ ]', $fen;
	$position[0] = pop @rows;
	@position[22..25] = map(string2piece($_), split ',', $rows[0]);
	@position[19..21] = map(string2piece($_), split ',', $rows[1]);
	@position[15..18] = map(string2piece($_), split ',', $rows[2]);
	@position[12..14] = map(string2piece($_), split ',', $rows[3]);
	@position[8 ..11] = map(string2piece($_), split ',', $rows[4]);
	@position[5 .. 7] = map(string2piece($_), split ',', $rows[5]);
	@position[1 .. 4] = map(string2piece($_), split ',', $rows[6]);
	return @position;
}
sub game2string { my @game = @_;
	my @string = ();
	# should have initial FEN, if any; Date, White, Black.
	# [Date "2008.06.16"]
	# [White "Carlsen,M"]
	# [Black "Onischuk,Al"]
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
	push @string,
	 sprintf "[Date \"%4.4d.%2.2d.%2.2d\"]", $year+1900,$mon+1,$mday;
	push @string, '[White "' . scalar getpwuid($>) . '"]';
	push @string, "[Black \"laska version $Version\"]";
	if ($pre_loaded_fen) {
		push @string, "[Starting from \"$pre_loaded_fen\"]";
		if ($pre_loaded_fen =~ /b$/) { unshift @game, '.....'; }
	}
	my $result = $game[-1]; if ($result =~ /^[-01]*$/) {
		push @string, "[Result: \"$result\"]";
	}
	$move_num = 1;
	while (@game) {
		push @string, "$move_num. ".(shift @game)." ".(shift @game);
		$move_num++;
	}
	return (join "\n", @string). "\n\n";
}
sub view_game {
	view ('Game so far', game2string(@_));
}
sub save_game {
	my $string = game2string(@_);
	eval 'require "Term/Clui/FileSelect.pm"'; import Term::Clui::FileSelect;
	my $file = select_file(
		-Path=>`pwd`,
		-Create=>1,
		-DisableShowAll=>1,
		-Title=>'Append to which file ?',
	);
	if (!open(F, ">> $file")) { warn "can't open $file: $!\n"; return; }
	if (print F $string) { print "File saved.\n";
	} else { warn "can't save $file: $!\n";
	}
	close F;
}
sub display_tty { my ($is_humans_move, @p) = @_;
	if ($first_display) {
		$first_display=0;
		print position2fen(@p), "$clrtoeol\n";
	} else {
		if ($is_humans_move) {
			print ${up_one_row}x19;
			print position2fen(@p), "$clrtoeol\n";
			print "My move was ",move2string($move,@position),"$clrtoeol\n";
		} else {
			print ${up_one_row}x20;
			print position2fen(@p), "$clrtoeol\n";
			print "Thinking...$clrtoeol\n";
		}
	}
	print ' ', '_'x41, "\n", ' |', ' 'x39, "|\n";
	printf "7|%9s %9s %9s %9s|", c($p[22]), c($p[23]), c($p[24]), c($p[25]);
	if ($p[0] & 01) { print "     Black to move$clrtoeol\n";
	} else          { print "     White to move$clrtoeol\n";
	}
	print ' |', ' 'x39, "|$clrtoeol\n";
	printf "6|     %9s %9s %9s     |", c($p[19]), c($p[20]), c($p[21]);
	print "     Level = $starting_ply$clrtoeol\n";
	print ' |', ' 'x39, "|$clrtoeol\n";
	printf "5|%9s %9s %9s %9s|\n", c($p[15]), c($p[16]), c($p[17]), c($p[18]);
	print ' |', ' 'x39, "|$clrtoeol\n";
	printf "4|     %9s %9s %9s     |\n", c($p[12]), c($p[13]), c($p[14]);
	print ' |', ' 'x39, "|$clrtoeol\n";
	printf "3|%9s %9s %9s %9s|\n", c($p[8]), c($p[9]), c($p[10]), c($p[11]);
	print ' |', ' 'x39, "|$clrtoeol\n";
	printf "2|     %9s %9s %9s     |\n", c($p[5]), c($p[6]), c($p[7]);
	print ' |', ' 'x39, "|$clrtoeol\n";
	printf "1|%9s %9s %9s %9s|$clrtoeol\n",c($p[1]),c($p[2]),c($p[3]),c($p[4]);
	print ' |', '_'x39, "|$clrtoeol\n";
	print "      a    b    c    d    e    f    g$clrtoeos\n";
	sub c {
		my $piece = $_[0];
		my $s = q{};
		my @convert = ('w','b','W','B');
		while ($piece) { 
			$s .= $convert[03 & $piece];
			$piece >>= 3;
		}
		if (!$s) { return '.    '; }
		return $s . ' 'x(4-int(-0.6 + 0.5 * length $s));
	}
}

__END__

=pod

=head1 NAME

laska - plays the Laska game

=head1 SYNOPSIS

 $ laska

=head1 DESCRIPTION

The game B<Laska> (or B<Lasca>)
was invented by world chess champion Emanuel Lasker
and published in 1911.
It is played on a seven-by-seven board,
using the corner squares and the other squares of that colour
(so on 25 squares of the available 49).
It uses eleven counters of each colour.
The counters should carry an ornament (like a star, or an asterisk)
on one side; they start the game with the ornamented side downwards,
and are turned over when promoted.

A taken counter is not removed from the board but placed under the taking
counter to form a column.
If a column is taken,
only its top counter is added to the the bottom of the taking column.
The colour of the top counter determines the ownership of its column.
(So if the second-to-top counter in a column is a different colour
to the top counter, that column will change owner if taken;
I call this a weak column.)
As in draughts, multiple takes can be made per turn.
Taking is compulsory; there is no huffing.
A multiple take ends on promotion.
If there is a choice of takes, it is a free choice.

When the opposite side is reached,
the counter (or the top counter of a column)
is promoted by being turned over;
it then becomes an officer and can move diagonally in any direction.
The rank of the top counter determines the rank of its column.
Officers remain as officers, even while buried ineffectively inside a column.

The game ends when one side cannot move, or has no pieces left. 

=head1 EQUIPMENT

Counters can be made from Poker chips, if the poker chip is ornamented
with painted signs like dots or the card suits.
If you take eleven white chips and eleven black (or red) chips
and can scratch off the ornamentation on one side using a sharp edge,
the you have an excellent set of Laska counters.
The white chips shouldn't show the scratching,
but the black chips may benefit from e.g. light brush of black ink.
A counter-diameter of 40mm looks good on a 50mm square.

The board is 7x7 (a chess-board is 8x8).
The colour of the corner-squares should be chosen
to present the two counters with as equal a contrast as possible.
One option is to cut one row and one file off an 8x8 chessboard,
especially one of those roll-up flexible plastic boards.
For symmetry you could also cut off any border around the other two sides.

=head1 OPTIONS

=over 3

=item I<-v>

Prints version number.

=back

=head1 AUTHOR

Peter J Billam  http://www.pjb.com.au/comp/contact.html

=head1 SEE ALSO

 http://www.pjb.com.au/laska/
 http://www.pjb.com.au/laska/angerstein.html     (Wolfgang Angerstein)
 http://en.wikipedia.org/wiki/Lasca
 http://www.boardgamegeek.com/game/6862
 http://www.cs.auckland.ac.nz/~alan/exstudnt.htm (Alan Creak)
 http://www.playdorado.com/lasca/index.htm       (Sander Agricola)
 http://research.interface.co.uk/lasca/about.htm (David Johnson-Davies)
 http://afdelingen.windesheim.nl/cvo/cvoprijs    (Willem van der Vegt)
 http://www.informaticaolympiade.nl/nio20000
 http://www.dsc.warwick.ac.uk/~csuom             (Duncan Witham)
 http://www.bignorromanvilla.co.uk
 Bignor Roman Villa, Bignor, Pulborough, West Sussex RH20 1PH
 http://www.pjb.com.au/
 perl(1)

=cut