|
|
@@ -0,0 +1,126 @@ |
|
|
#!/usr/bin/perl |
|
|
# |
|
|
# 14 October 2017 |
|
|
# Author: Mark Jason Dominus |
|
|
# |
|
|
# This program is in the public domain. |
|
|
# You may use, modify, copy, or distribute it |
|
|
# in any way for any purpose, without restriction. |
|
|
# |
|
|
|
|
|
use strict 'vars'; |
|
|
|
|
|
my $G = [1,1,1,1,1,1]; # equidistributed 0-5 |
|
|
my $R = [0,1,1,1,1,1,1]; # equidistributed 1-6 |
|
|
my $S1 = [0,1,2,2,1]; # Sicherman A |
|
|
my $S2 = [0,1,0,1,1,1,1,0,1]; # Sicherman B |
|
|
|
|
|
my %dname = (R => $R, G => $G, |
|
|
S1 => $S1, S2 => $S2, |
|
|
'2R' => add2($R, $R), |
|
|
'RG' => add2($R, $G), |
|
|
'2G' => add2($G, $G), |
|
|
'S' => add2($S1, $S2), # not better or worse than 2R |
|
|
); |
|
|
|
|
|
my ($d1, $d2) = @ARGV; |
|
|
defined($d2) or die "Usage: dice D1 D2\n\t(or: dice test D1)\n"; |
|
|
|
|
|
if ($d1 eq "test") { |
|
|
exists($dname{$d2}) or die "Unknown die '$d2'\n"; |
|
|
test($dname{$d2}); |
|
|
exit; |
|
|
} |
|
|
|
|
|
exists($dname{$_}) or die "Unknown die '$_'\n" for $d1, $d2; |
|
|
play(@dname{$d1, $d2}); |
|
|
|
|
|
# dump out statistics for one die |
|
|
# including a random trial of 10,000 rolls |
|
|
sub test { |
|
|
my ($d) = @_; |
|
|
print "@$d\n"; |
|
|
my %count; |
|
|
for (1 .. 10_000) { |
|
|
$count{roll($d)}++; |
|
|
} |
|
|
for my $k (sort { $a <=> $b } keys %count) { |
|
|
next unless $count{$k} > 0; |
|
|
printf "%3d %4d\n", $k, $count{$k}; |
|
|
} |
|
|
} |
|
|
|
|
|
# Match one die against another, |
|
|
# print out who wins in the following format: |
|
|
# > dice G R |
|
|
# p1 10 27.8% 32.3% |
|
|
# p2 21 58.3 67.7 |
|
|
# tie 5 13.9 16.1 |
|
|
# 36 |
|
|
# |
|
|
# player 1 (G) wins 10 times out of 36, which is 27.8% |
|
|
# player 2 (R) wins 21 times out of 36, which is 58.3% |
|
|
# the two players tie 5 times out of 36, which is 13.9% |
|
|
# |
|
|
# The right-hand column is the probabilities if ties are |
|
|
# do-overs: player 1 wins 32.3% of the time, |
|
|
# player 2 wins 67.7% of the time. |
|
|
# |
|
|
# The number in the lower right is not very meaningful. |
|
|
b# It is the fraction of do-overs as compared to decisive results. |
|
|
|
|
|
sub play { |
|
|
my ($d1, $d2) = @_; |
|
|
my %count; |
|
|
my $total = 0; |
|
|
my $decisive = 0; |
|
|
for my $i (0 .. $#$d1) { |
|
|
for my $j (0 .. $#$d2) { |
|
|
my ($r1, $r2) = ($d1->[$i], $d2->[$j]); |
|
|
my $outcome = |
|
|
$i > $j ? "p1" |
|
|
: $i < $j ? "p2" : "tie"; |
|
|
$count{$outcome} += $r1 * $r2; |
|
|
$total += $r1 * $r2; |
|
|
$decisive += $r1 * $r2 unless $outcome eq "tie"; |
|
|
} |
|
|
} |
|
|
my $pct = "%"; |
|
|
for my $outcome (qw(p1 p2 tie)) { |
|
|
my $count = $count{$outcome}; |
|
|
printf "%-4s %3d %4.1f%1s %4.1f%1s\n", $outcome, $count, |
|
|
100*$count / $total, $pct, 100 *$count/$decisive, $pct; |
|
|
$pct = " "; |
|
|
} |
|
|
printf "%-4s %3d\n", "", $total, $decisive; |
|
|
} |
|
|
|
|
|
sub roll { |
|
|
my ($die) = @_; |
|
|
my $total = sum(@$die); |
|
|
my $rand = int(rand($total)); |
|
|
my $i = 0; |
|
|
while ($rand >= $die->[$i]) { |
|
|
$rand -= $die->[$i++]; |
|
|
} |
|
|
return $i; |
|
|
} |
|
|
|
|
|
sub sum { |
|
|
my $total = 0; |
|
|
for (@_) { $total += $_ } |
|
|
return $total; |
|
|
} |
|
|
|
|
|
# Add two dice together |
|
|
sub add2 { |
|
|
my $s = []; |
|
|
my ($d1, $d2) = @_; |
|
|
for my $i (0 .. $#$d1) { |
|
|
for my $j (0 .. $#$d2) { |
|
|
my ($r1, $r2) = ($d1->[$i], $d2->[$j]); |
|
|
$s->[$i+$j] += $r1*$r2; |
|
|
} |
|
|
} |
|
|
return $s; |
|
|
} |
mjdominus created this gist