Perl program for comparing different combinations of dice

dice

#!/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;
}