+### -*-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;
~mdw / bridge-toys / commitdiff