Commit | Line | Data |
---|---|---|
bba7b95e MW |
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; |