-
-
Save mjdominus/ac2c3c36c50d7ae97b0f06bf94346061 to your computer and use it in GitHub Desktop.
Perl program for comparing different combinations of dice
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/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; | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment