mdw@git.distorted.org.uk Git - bridge-toys/blob - mason/.perl-lib/Deal.pm

   1 ### -*-perl-*-
   2
   3 package Deal;
   4
   5 use MIME::Base32;
   6
   7 ###--------------------------------------------------------------------------
   8 ### Random numbers.
   9
  10 package Deal::Random;
  11
  12 sub init ($) { }
  13
  14 sub range ($$) {
  15   my ($me, $max) = @_;
  16
  17   my ($nby, $get, $r);
  18   if ($max <= 255) { $nby = 1; $get = "C"; }
  19   elsif ($max <= 65535) { $nby = 2; $get = "S"; }
  20   else { $nby = 4; $get = "L"; }
  21
  22   my $lim = unpack $get, "\xff" x $nby;
  23   my $m = int $lim/$max;
  24   my $thresh = $m*$max;
  25   do { $r = unpack $get, $me->bytes($nby); } while $r >= $thresh;
  26   return $r%$max;
  27 }
  28
  29 package Deal::BufferedRandom;
  30
  31 @ISA = qw(Deal::Random);
  32
  33 sub init ($) {
  34   my ($me) = @_;
  35   $me->{buf} = "";
  36   $me->SUPER::init;
  37 }
  38
  39 sub bytes ($$) {
  40   my ($me, $n) = @_;
  41
  42   if ($n > length $me->{buf}) {
  43     my $want = ($n + 4095 - length $me->{buf})&-4096;
  44     while ($want > 0) {
  45       my $more = $me->fetch($want);
  46       $want -= length $more;
  47       $me->{buf} .= $more;
  48     }
  49   }
  50
  51   my $chunk = substr $me->{buf}, 0, $n;
  52   $me->{buf} = substr $me->{buf}, $n;
  53   return $chunk;
  54 }
  55
  56 package Deal::SysRandom;
  57
  58 @ISA = qw(Deal::BufferedRandom);
  59
  60 sub new ($) {
  61   my ($pkg) = @_;
  62   my $me = bless {};
  63   $me->init;
  64   return $me;
  65 }
  66
  67 sub init ($) {
  68   my ($me) = @_;
  69   open my $rand, "/dev/urandom" or die "open (/dev/urandom): $!";
  70   $me->{rand} = $rand;
  71   $me->SUPER::init;
  72 }
  73
  74 sub fetch ($$) {
  75   my ($me, $want) = @_;
  76   defined (read $me->{rand}, my $more, $want)
  77     or die "read (/dev/urandom): $!";
  78   return $more;
  79 }
  80
  81 package Deal::SeedRandom;
  82
  83 use Digest::SHA qw(sha256);
  84
  85 @ISA = qw(Deal::BufferedRandom);
  86
  87 sub new ($@) {
  88   my ($pkg, @args) = @_;
  89   my $me = bless {};
  90   $me->init(@args);
  91   return $me;
  92 }
  93
  94 sub init ($$) {
  95   my ($me, $seed) = @_;
  96   $me->{seed} = $seed;
  97   $me->{i} = 0;
  98 }
  99
 100 sub fetch ($$) {
 101   my ($me, $want) = @_;
 102   return sha256(pack "La*", $me->{i}++, $me->{seed});
 103 }
 104
 105 ###--------------------------------------------------------------------------
 106 ### General stuff.
 107
 108 package Deal;
 109
 110 our $RAND = Deal::SysRandom->new;
 111
 112 sub shuffle ($@) {
 113   my ($r, @x) = @_;
 114   my $n = @x;
 115   for (my $i = 0; $i < $n - 1; $i++) {
 116     my $k = $i + $r->range($n - $i);
 117     ($x[$i], $x[$k]) = ($x[$k], $x[$i]);
 118   }
 119   return @x;
 120 }
 121
 122 our @LINE; $LINE[$_] = $_%4 + 1 for 0..51;
 123
 124 sub line () { return shuffle $RAND, @LINE; }
 125
 126 ###--------------------------------------------------------------------------
 127 ### Generating hands for study.
 128
 129 our @RANK = ("A", "K", "Q", "J", "10", "9",
 130              "8", "7", "6", "5", "4", "3", "2");
 131 our @SUIT = ("C", "D", "H", "S");
 132 our @DECK;
 133 for (my $r = 0; $r < @RANK; $r++)
 134   { for my $s (@SUIT) { push @DECK, [$s, $r]; } }
 135
 136 our @SEAT = ("N", "W", "S", "E");
 137 our @VULN = ("None", "N/S", "E/W", "All");
 138
 139 our %HCP = ("A" => 4, "K" => 3, "Q" => 2, "J" => 1);
 140
 141 sub hand (@) {
 142   my (@cards) = @_;
 143   my %card;
 144
 145   ## Work out the cards and sort them into suits.
 146   for my $s (@SUIT) { $card{$s} = []; }
 147   for my $c (@cards) { push @{$card{$c->[0]}}, $c->[1]; }
 148   for my $s (@SUIT) {
 149     @{$card{$s}} = map { $RANK[$_] } sort { $a <=> $b } @{$card{$s}};
 150   }
 151
 152   ## Count the high-card points and losers.
 153   my $hcp = 0;
 154   my $ltc = 0;
 155   for my $s (@SUIT) {
 156     my @c = @{$card{$s}};
 157     my $n = @c;
 158     my %c = map { $_ => 1 } @c;
 159     for my $i (keys %HCP) { $hcp += $HCP{$i} if $c{$i}; }
 160     for my $i ("A", "K", "Q") {
 161       last unless $n--;
 162       $ltc++ unless $c{$i};
 163     }
 164   }
 165
 166   ## Done.
 167   return { %card, ltc => $ltc, hcp => $hcp };
 168 }
 169
 170 sub deal (%) {
 171   my $deal = { @_ };
 172   $deal->{seed} //= lc(MIME::Base32::encode($RAND->bytes(16)));
 173   my $r = Deal::SeedRandom->new($deal->{seed});
 174   my @cards = shuffle $r, @DECK;
 175   for my $s (@SEAT) { $deal->{$s} = hand splice @cards, 0, 13; }
 176   $deal->{dealer} //= $r->range(4);
 177   $deal->{vuln} //= $r->range(4);
 178
 179   return $deal;
 180 }
 181
 182 ###----- That's all, folks --------------------------------------------------
 183
 184 1;