Initial checkin.

[bridge-toys] / mason / .perl-lib / Deal.pm

### -*-perl-*-

package Deal;

use MIME::Base32;

###--------------------------------------------------------------------------
### Random numbers.

package Deal::Random;

sub init ($) { }

sub range ($$) {
  my ($me, $max) = @_;

  my ($nby, $get, $r);
  if ($max <= 255) { $nby = 1; $get = "C"; }
  elsif ($max <= 65535) { $nby = 2; $get = "S"; }
  else { $nby = 4; $get = "L"; }

  my $lim = unpack $get, "\xff" x $nby;
  my $m = int $lim/$max;
  my $thresh = $m*$max;
  do { $r = unpack $get, $me->bytes($nby); } while $r >= $thresh;
  return $r%$max;
}

package Deal::BufferedRandom;

@ISA = qw(Deal::Random);

sub init ($) {
  my ($me) = @_;
  $me->{buf} = "";
  $me->SUPER::init;
}

sub bytes ($$) {
  my ($me, $n) = @_;

  if ($n > length $me->{buf}) {
    my $want = ($n + 4095 - length $me->{buf})&-4096;
    while ($want > 0) {
      my $more = $me->fetch($want);
      $want -= length $more;
      $me->{buf} .= $more;
    }
  }

  my $chunk = substr $me->{buf}, 0, $n;
  $me->{buf} = substr $me->{buf}, $n;
  return $chunk;
}

package Deal::SysRandom;

@ISA = qw(Deal::BufferedRandom);

sub new ($) {
  my ($pkg) = @_;
  my $me = bless {};
  $me->init;
  return $me;
}

sub init ($) {
  my ($me) = @_;
  open my $rand, "/dev/urandom" or die "open (/dev/urandom): $!";
  $me->{rand} = $rand;
  $me->SUPER::init;
}

sub fetch ($$) {
  my ($me, $want) = @_;
  defined (read $me->{rand}, my $more, $want)
    or die "read (/dev/urandom): $!";
  return $more;
}

package Deal::SeedRandom;

use Digest::SHA qw(sha256);

@ISA = qw(Deal::BufferedRandom);

sub new ($@) {
  my ($pkg, @args) = @_;
  my $me = bless {};
  $me->init(@args);
  return $me;
}

sub init ($$) {
  my ($me, $seed) = @_;
  $me->{seed} = $seed;
  $me->{i} = 0;
}

sub fetch ($$) {
  my ($me, $want) = @_;
  return sha256(pack "La*", $me->{i}++, $me->{seed});
}

###--------------------------------------------------------------------------
### General stuff.

package Deal;

our $RAND = Deal::SysRandom->new;

sub shuffle ($@) {
  my ($r, @x) = @_;
  my $n = @x;
  for (my $i = 0; $i < $n - 1; $i++) {
    my $k = $i + $r->range($n - $i);
    ($x[$i], $x[$k]) = ($x[$k], $x[$i]);
  }
  return @x;
}

our @LINE; $LINE[$_] = $_%4 + 1 for 0..51;

sub line () { return shuffle $RAND, @LINE; }

###--------------------------------------------------------------------------
### Generating hands for study.

our @RANK = ("A", "K", "Q", "J", "10", "9",
	     "8", "7", "6", "5", "4", "3", "2");
our @SUIT = ("C", "D", "H", "S");
our @DECK;
for (my $r = 0; $r < @RANK; $r++)
  { for my $s (@SUIT) { push @DECK, [$s, $r]; } }

our @SEAT = ("N", "W", "S", "E");
our @VULN = ("None", "N/S", "E/W", "All");

our %HCP = ("A" => 4, "K" => 3, "Q" => 2, "J" => 1);

sub hand (@) {
  my (@cards) = @_;
  my %card;

  ## Work out the cards and sort them into suits.
  for my $s (@SUIT) { $card{$s} = []; }
  for my $c (@cards) { push @{$card{$c->[0]}}, $c->[1]; }
  for my $s (@SUIT) {
    @{$card{$s}} = map { $RANK[$_] } sort { $a <=> $b } @{$card{$s}};
  }

  ## Count the high-card points and losers.
  my $hcp = 0;
  my $ltc = 0;
  for my $s (@SUIT) {
    my @c = @{$card{$s}};
    my $n = @c;
    my %c = map { $_ => 1 } @c;
    for my $i (keys %HCP) { $hcp += $HCP{$i} if $c{$i}; }
    for my $i ("A", "K", "Q") {
      last unless $n--;
      $ltc++ unless $c{$i};
    }
  }

  ## Done.
  return { %card, ltc => $ltc, hcp => $hcp };
}

sub deal (%) {
  my $deal = { @_ };
  $deal->{seed} //= lc(MIME::Base32::encode($RAND->bytes(16)));
  my $r = Deal::SeedRandom->new($deal->{seed});
  my @cards = shuffle $r, @DECK;
  for my $s (@SEAT) { $deal->{$s} = hand splice @cards, 0, 13; }
  $deal->{dealer} //= $r->range(4);
  $deal->{vuln} //= $r->range(4);

  return $deal;
}

###----- That's all, folks --------------------------------------------------

1;