| 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; |