File Coverage

blib/lib/Games/Cards/Bridge/Contract.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package Games::Cards::Bridge::Contract;

use strict;
use warnings;
use base qw(Class::Accessor);
use Carp;

our $VERSION = '0.02';

__PACKAGE__->mk_accessors(
	'declarer',	# N E S W
	'trump',	# C D H S N P
	'vul',		# boolean
	'penalty',	# 0=none 1=X 2=XX
	'bid',		# 1..7
	'made',		# bid..7	undef
	'down',		# undef		1..bid
);

sub new {
  my $self = shift;
  my $class = ref($self) || $self;
  my $p = { @_ };
  my $obj = bless {}, $class;
  while( my($k,$v) = each %$p ){
    next unless $obj->can($k);
    $obj->set($k, $v);
  }
  $obj->set('vul', $obj->vul ? 1 : 0 );  # force boolean
  $obj->set('penalty', 0 ) if ! $obj->penalty;  # force 0 for false
  $obj->__validate;
  return $obj;
}

sub __validate {
  my $self = shift;
  return if $self->trump eq 'P';
  croak 'declarer must be one of (N,E,S,W)' unless $self->declarer =~ /^[NESW]$/;
  croak 'trump must be one of (C,D,H,S,N,P)' unless $self->trump =~ /^[CDHSN]$/;
  croak 'vul must be true or false' unless $self->vul =~ /^[01]$/;
  croak 'penalty must be one of (0,1,2)' unless $self->penalty =~ /^[012]$/;
  croak 'bid must be one of (1..7)' unless $self->bid =~ /^[1234567]$/;
  if( defined $self->made ){
    croak 'made must be one of (1..7) and >= bid' unless $self->made =~ /^[1234567]$/ && $self->made >= $self->bid;
    croak 'down must be unset' if defined $self->down;
  }else{
    croak 'down must be one of (1..13) and <= bid+6' unless $self->down =~ /^([123456789]|1[0123])$/ && $self->down <= $self->bid + 6;
    croak 'made must be unset' if defined $self->made;
  }
}

sub minor { return shift->trump =~ /^[CD]$/ ? 1 : 0; }
sub major { return shift->trump =~ /^[HS]$/ ? 1 : 0; }
sub notrump { return shift->trump eq 'N' ? 1 : 0; }
sub passout { return shift->trump eq 'P' ? 1 : 0; }
sub slam { return shift->bid >= 6 ? 1 : 0; }
sub small_slam { return shift->bid == 6 ? 1 : 0; }
sub grand_slam { return shift->bid == 7 ? 1 : 0; }
sub game {
  my $self = shift;
  my $tricks = shift;
  $tricks = $self->bid unless defined $tricks;
  return $tricks >= 3 && ($self->notrump || ($self->major && $tricks >= 4) || ($self->minor && $tricks >= 5));
}
sub overtricks {
  my $self = shift;
  return unless $self->made;
  return $self->made - $self->bid;
}

sub rubber_score {
  my $self = shift;
  my $score = $self->__calc_score;
  return ( $score->{overtricks} + $score->{slam} + $score->{insult},  $score->{tricks},  $score->{undertricks} );
}

sub duplicate_score {
  my $self = shift;
  my $score = $self->__calc_score;
  return $score->{tricks} + $score->{overtricks} + $score->{partscore} + $score->{game} + $score->{slam} + $score->{insult} - $score->{undertricks};
}

sub __calc_score {
  my $self = shift;
  my %score = map { $_ => 0 } qw/ undertricks tricks overtricks partscore game slam insult /;
  if( $self->passout ){
    # do nothing
  }elsif( $self->made ){
    my ($n, $over) = ($self->bid, $self->overtricks);
    my ($minor, $major, $nt) = ($self->minor, $self->major, $self->notrump);
    $score{tricks} += 30*$n+10 if $nt;				# notrump: 40 first, 30 each after
    $score{tricks} += 30*$n if $major;				# major: 30 each
    $score{tricks} += 20*$n if $minor;				# minor: 20 each
    $score{tricks} *= 2*$self->penalty if $self->penalty;	# multiply 2x or 4x if X or XX
    $n *= 2*$self->penalty if $self->penalty;		# change the effective tricks based on X/XX
    if( $self->game($n) ){
      $score{game} += $self->vul ?  500 :  300;			# game bonus
    }else{
      $score{partscore} += 50;					# partscore bonus
    }
    if( $self->grand_slam ){
      $score{slam} += ($self->vul ? 1500 : 1000);		# grand slam bonus
    }elsif( $self->small_slam ){
      $score{slam} += ($self->vul ?  750 :  500);		# small slam bonus
    }
    if( $self->penalty ){
      $score{overtricks} += $over * 100 * $self->penalty * ($self->vul?2:1);  # overtricks: 100 each; x2/x4 for X/XX; x2 for vul
      $score{insult} += 50*$self->penalty;			# plus 50 or 100 for X or XX
    }else{
      $score{overtricks} += $over * ($minor ? 20 : 30);		# minor/major/notrump: 20/30/30 per overtrick
    }
  }else{  #down
    my $n = $self->down;
    if( ! $self->penalty ){
      $score{undertricks} += $n * ( $self->vul ? 100 : 50 );
    }else{
      if( $self->vul ){
        $score{undertricks} += 300*$n-100;
      }else{
        $score{undertricks} += 300*$n-400 + ($n==1?200:0) + ($n==2?100:0);
      }
      $score{undertricks} *= $self->penalty; # x2 if XX
    }
  }
  return \%score;
}

1;
__END__