#!/usr/bin/perl -w
# $Id$

# linviewer.pl (c) 2005, 2006 Christoph Berg <cb@df7cb.de>
# All rights reserved.
# This program is free software licensed under the terms of the GNU GPL v2.

=pod

=head1 NAME

linviewer.pl -- view bridge movies

=head1 SYNOPSIS

=over

=item B<linviewer.pl> [B<-h> I<n>] [I<movie.lin>]

=back

=head1 DESCRIPTION

This program takes a "Bridge Movie", as produced by Bridgebase Online, and
converts it to human readable text form.

When running on a UTF-8 terminal, suit symbols substitute letters.

=head1 OPTIONS

=over

=item B<-h> B<--html> I<n>

Print hands and bidding as html table. 1 = big hand table, 2 = smaller hand table.

=head1 AUTHOR

Christoph Berg <cb@df7cb.de>

=head1 WEBSITE

http://www.df7cb.de/bridge/

=head1 SEE ALSO

http://online.bridgebase.com/myhands/index.php

=cut

use strict;
use Getopt::Long;

my $utf8 = 0;
my $lang = $ENV{LC_ALL} || $ENV{LC_CTYPE} || $ENV{LANG} || "";
$utf8 = 1 if $lang =~ /utf.?8/i;
my $html = 0;

Getopt::Long::config('bundling');
unless (GetOptions(
	'-h=i' => \$html,
	'--html=i' => \$html,
)) {
	exit 1;
}

#
# data
#

my $S = $html ? '&#9824;' : $utf8 ? '♠' : 'S';
my $H = $html ? '<font color="red">&#9829;</font>' : $utf8 ? '♡' : 'H';
my $D = $html ? '<font color="red">&#9830;</font>' : $utf8 ? '♢' : 'D';
my $C = $html ? '&#9827;' : $utf8 ? '♣' : 'C';

#
# functions
#

# normalize number to 1..4 range
sub normpl {
	my $p = shift;
	return (($p - 1) % 4) + 1;
}

# player name, 0 is undef
sub pl {
	my $p = shift;
	return (qw/- S W N E/)[$p];
}

sub sort_card {
    my ($aa, $bb) = ($a, $b);
    $aa =~ tr/TJQKA/abcde/;
    $bb =~ tr/TJQKA/abcde/;
    return $aa cmp $bb;
}

# converts SJ6HAKT6DK8654C62 to array of cards
sub cards {
	my @hand = split '', shift;
	my $suit = '';
	my @ret;
	foreach (@hand) {
		$suit = $_ if /[SHDC]/;
		push @ret, "$suit$_" if /[AKQJT98765432]/;
	}
	return @ret;
}

sub pr {
	my $str = shift;
	return $str unless $utf8;
	$str =~ s/S/$S/g;
	$str =~ s/H/$H/g;
	$str =~ s/D/$D/g;
	$str =~ s/C/$C/g;
	return $str;
}

sub hands_str {
	my $hand = shift;
	my %h = (S => $S, H => $H, D => $D, C => $C);
	foreach (@$hand) {
		$h{$1} .= $2 if /(.)(.)/;
	}
	return \%h;
}

# compare two cards of a suit
sub beats {
	my ($a, $b) = @_;
	my %val = (
		2 => 2,
		3 => 3,
		4 => 4,
		5 => 5,
		6 => 6,
		7 => 7,
		8 => 8,
		9 => 9,
		T => 10,
		J => 11,
		Q => 12,
		K => 13,
		A => 14,
	);
	return $val{$a} > $val{$b};
}

# which player won a trick
sub won_trick {
	my $contractsuit = shift;
	my $player = shift;
	my $lead = shift;
	$lead =~ /(.)(.)/ or print "card?";
	return 0 if @_ < 3; # partial trick (claim)

	my ($s, $c) = ($1, $2);
	my $won = $player;
	foreach (@_) {
		$player = normpl($player + 1);
		/(.)(.)/ or print "card?";
		if (($1 eq $s and beats($2, $c)) or # higher card in current highest suit
			($1 eq $contractsuit and $s ne $contractsuit)) { # trump, no trump before
			#print "$_ beats $lead\n";
			$s = $1;
			$c = $2;
			$won = $player;
		}
	}
	return $won;
}

#
# main
#

# main function for each hand
sub do_hand {
my @lin = @_;
my (@players, @hands, @hands_str, $dealer, @dealer, $vuln, $vuln_str, @bidding, @lead, $claim, $finished);

while (@lin) {
	my $tok = shift @lin;
	# tournament overview
	if ($tok eq "vg") {
		print "Tournament: ", shift @lin, "\n";
	} elsif ($tok eq "rs") {
		print "Contracts: ", shift @lin, "\n";
	} elsif ($tok eq "pw") {
		print "Players: ", shift @lin, "\n";
	} elsif ($tok eq "mp") {
		print "IMPs: ", shift @lin, "\n";
	} elsif ($tok eq "bn") {
		print "Board numbers: ", shift @lin, "\n";
	# single hand
	} elsif ($tok eq "qx") {
		print "\nBoard number: ", shift @lin, "\n";
	} elsif ($tok eq "pn") {
		@players = split ',', shift @lin;
		#print "Players: W: $players[1] N: $players[2] E: $players[3] S: $players[0]\n";
	} elsif ($tok eq "st") { # what's that?
		my $st = shift @lin;
		print "st: $st\n" if $st;
	} elsif ($tok eq "md") {
		my $hands = shift @lin;
		$dealer = substr $hands, 0, 1, ''; # 1->S 2->W 3->N 4->E
		@dealer = ("", " ", " ", " ", " ");
		$dealer[$dealer] = "D";
		#$dealer =~ y/24/42/;
		@hands = map { [ reverse sort sort_card (cards($_)) ] } split ',', $hands;
		my %deck; # compute East hand
		foreach my $s (qw/S H D C/) {
			foreach my $c (qw/A K Q J T 9 8 7 6 5 4 3 2/) {
				$deck{"$s$c"} = 1;
			}
		}
		foreach my $h (@hands) {
			map { delete $deck{$_} } @{$h};
		}
		$hands[3] = [ reverse sort sort_card keys %deck ];
		@hands_str = map { hands_str($_); } @hands;
	} elsif ($tok eq "rh") {
		my $rh = shift @lin;
		print "rh: $rh\n" if $rh;
	} elsif ($tok eq "ah") {
		print "Title: ", shift @lin, "\n";
	} elsif ($tok eq "sv") {
		my $sv = shift @lin;
		my %vuln = (
			o => "none",
			n => "NS",
			e => "EW",
			b => "both",
		);
		my %vuln_str = (
			o => "   ",
			n => " | ",
			e => "---",
			b => "-|-",
		);
		#print "Vulnerable: $vuln{$sv}\n";
		$vuln = $vuln{$sv};
		$vuln_str = $vuln_str{$sv};
	} elsif ($tok eq "mb") {
		push @bidding, shift @lin;
	} elsif ($tok eq "an") {
		my $an = shift @lin;
		push @bidding, ((pop @bidding) . "($an)");
	} elsif ($tok eq "pg") {
		my $pg = shift @lin;
		print "pg: $pg\n" if $pg;
		$finished = 1;
	} elsif ($tok eq "pc") {
		push @lead, shift @lin;
		$finished = 0; # if this was the last token seen, the game ran out of time (ave score)
	} elsif ($tok eq "mc") {
		$claim = shift @lin;
		$finished = 1;
	} elsif ($tok eq "") {
	} else {
		print "unknown token: $tok at $.\n";
	}
}

return unless @hands;

unshift @bidding, '' for (1 .. (($dealer - 2) % 4));
my %bidwidth = (
	0 => 0,
	1 => 0,
	2 => 0,
	3 => 0,
);
my $n = 0;
map { $bidwidth{$n} = length($_) if $bidwidth{$n} < length($_); $n = ++$n % 4 } @bidding;

my $h = 2;
my %co;
my ($contract, $contractsuit, $contractlevel);
my $declarer;
foreach (@bidding) {
	if (/^(.)([NSHDC])/) {
		$co{$h % 2}->{$2} ||= $h;
		$contractlevel = $1;
		$contractsuit = $2;
		$contract = $1.$2;
		$declarer = $co{$h % 2}->{$2};
	}
	if (/^([dr])/) {
		$contract .= 'x';
	}
	$h = ($h % 4) + 1;
}

format text =
           N @<<<<<<<<<
           $players[2]
           @<<<<<<<<<
           $hands_str[2]->{S}
           @<<<<<<<<<
           $hands_str[2]->{H}
           @<<<<<<<<<
           $hands_str[2]->{D}
           @<<<<<<<<<
           $hands_str[2]->{C}
W @<<<<<<<<<  @      E @<<<<<<<<<
$players[1], $dealer[3], $players[3]
@<<<<<<<<<      N      @<<<<<<<<<
$hands_str[1]->{S},   $hands_str[3]->{S}
@<<<<<<<<<  @ W@<<@ @  @<<<<<<<<<
$hands_str[1]->{H}, $dealer[2], $vuln_str, "E", $dealer[4], $hands_str[3]->{H}
@<<<<<<<<<      S      @<<<<<<<<<
$hands_str[1]->{D},   $hands_str[3]->{D}
@<<<<<<<<<      @      @<<<<<<<<<
$hands_str[1]->{C}, $dealer[1], $hands_str[3]->{C}
           S @<<<<<<<<<
           $players[0]
           @<<<<<<<<<
           $hands_str[0]->{S}
           @<<<<<<<<<
           $hands_str[0]->{H}
           @<<<<<<<<<
           $hands_str[0]->{D}
           @<<<<<<<<<
           $hands_str[0]->{C}
.

format html =
<table>
<tr><td></td>
    <td>N <i>@*</i><br>@*<br>@*<br>@*<br>@*</td>
    $players[2], $hands_str[2]->{S}, $hands_str[2]->{H}, $hands_str[2]->{D}, $hands_str[2]->{C}
    <td></td></tr>
<tr><td>W <i>@*</i><br>@*<br>@*<br>@*<br>@*</td>
    $players[1], $hands_str[1]->{S}, $hands_str[1]->{H}, $hands_str[1]->{D}, $hands_str[1]->{C}
    <td align="center">N<br>W@<< E <br>S</td>
    $vuln_str
    <td>E <i>@*</i><br>@*<br>@*<br>@*<br>@*</td>
    $players[3], $hands_str[3]->{S}, $hands_str[3]->{H}, $hands_str[3]->{D}, $hands_str[3]->{C}
    </tr>
<tr><td></td>
    <td>S <i>@*</i><br>@*<br>@*<br>@*<br>@*</td>
    $players[0], $hands_str[0]->{S}, $hands_str[0]->{H}, $hands_str[0]->{D}, $hands_str[0]->{C}
    <td></td></tr>
</table>
.

format html2 =
<table border="1">
<tr><td>Dealer: @*<br>Vuln: @*</td>
    pl($dealer), $vuln
    <td rowspan="2">N <i>@*</i><br>@*<br>@*<br>@*<br>@*</td>
    $players[2], $hands_str[2]->{S}, $hands_str[2]->{H}, $hands_str[2]->{D}, $hands_str[2]->{C}
    <td>&nbsp;</td></tr>
<tr><td rowspan="2">W <i>@*</i><br>@*<br>@*<br>@*<br>@*</td>
    $players[1], $hands_str[1]->{S}, $hands_str[1]->{H}, $hands_str[1]->{D}, $hands_str[1]->{C}
    <td rowspan="2">E <i>@*</i><br>@*<br>@*<br>@*<br>@*</td>
    $players[3], $hands_str[3]->{S}, $hands_str[3]->{H}, $hands_str[3]->{D}, $hands_str[3]->{C}
    </tr>
<tr><td rowspan="2">S <i>@*</i><br>@*<br>@*<br>@*<br>@*</td>
    $players[0], $hands_str[0]->{S}, $hands_str[0]->{H}, $hands_str[0]->{D}, $hands_str[0]->{C}
    </tr>
<tr><td>@* @*</td>
    pr($contract), pl($declarer)
    <td>&nbsp;</td></tr>
</table>
.

if ($html eq "1") {
	$~ = "html";
} elsif ($html eq "2") {
	$~ = "html2";
} else {
	$~ = "text";
}

write;

#print "Hands:\n";
#printf "W: %s\nN: %s\nE: %s\nS: %s\n",
#	(join ' ', map { pr($_) } @{$hands[1]}),
#	(join ' ', map { pr($_) } @{$hands[2]}),
#	(join ' ', map { pr($_) } @{$hands[3]}),
#	(join ' ', map { pr($_) } @{$hands[0]});
#print "Dealer: ". pl($dealer) ."\n";

print "Bidding:\n";
print "<table>\n" if $html;
$n = 0;
my $open = 0;
foreach (qw/W N E S/, @bidding) {
	my $b = $_;
	if ($b =~ /(..)(.*)/) {
		$b = pr($1) . $2;
	}
	if ($html) {
		print "<tr>" unless $open;
		print "<td>$b</td>";
		$open = 1;
	} else {
		printf "%-${bidwidth{$n}}s  ", $b;
	}
	unless ($n = (++$n % 4)) {
		print "</tr>" if $html;
		print "\n";
		$open = 0;
	}
}
print "</tr>" if $open and $html;
print "\n" if $open;
print "</table>\n" if $html;
my $leader = normpl($declarer + 1);
printf "Contract: %s, Declarer: %s, Lead: %s\n", pr($contract), pl($declarer), pl($leader);

my $onlead = $leader;

my %count = (
	0 => 0,
	1 => 0,
);

my $trick = 1;
while (@lead) {
	my @trick = splice @lead, 0, 4, ();
	my $won = won_trick($contractsuit, $onlead, @trick);
	$count{$won % 2}++ if $won > 0; # won = 0 -> claim
	my $trickstr = join " ", map { pr($_) } @trick;
	printf "Trick %2d: (%s) $trickstr -> %s\n", $trick++, pl($onlead), pl($won);
	$onlead = $won;
}

printf "Tricks: NS: %d, EW: %d\n", $count{1}, $count{0};
if ($claim) {
	print "Claimed $claim tricks\n" if $claim;
	$count{$declarer % 2} = $claim;
}
if ($finished) {
	my $res = $count{$declarer % 2} - $contractlevel - 6;
	$res = $res ? sprintf "%+d", $res : '=';
	printf "Result: %s%s%s\n", pr($contract), pl($declarer), $res;
} else {
	print "Board unfinshed (which probably means average scores assigned)\n";
}

} # do_hand

# real main code

while (my $lin = <>) {
	chomp $lin;
	$lin =~ s/\r//;
	my @lin = split '\|', $lin, -1;
	do_hand(@lin);
}

# vim:sw=8: