#!/usr/bin/perl
use strict;
#Program to do dice rolling for Donjon games. Rules for dice rolling:
#The player rolls N d20s, opposed by M d20s representing the difficultly of
#his task. Call the player P and the opposed roll Q. Look at P and Q for the
#highest roll; that side is the winner, and gets as many successes as it has
#dice over the opponent's highest rolls. Ties go to the winner.
my $choice = "1";
while ($choice)
{
print "Dice roller!
1) Standard opposing rolls
2) Generic batch mode
3) Rank actors against each other
4) Rank actors against a difficulty
5) Just roll dice
6) Quit
Choice [1-6]: ";
$choice = ;
chomp $choice;
#Syntax checking
if ($choice !~ /^[123456]$/)
{
print "$choice is not a valid choice. Please try again\n\n";
next;
}
if ($choice eq "1")
{
doStandard();
next;
}
if ($choice eq "2")
{
doBatchOne();
next;
}
if ($choice eq "3")
{
doBatchTwo();
next;
}
if ($choice eq "4")
{
doBatchThree();
next;
}
if ($choice eq "5")
{
doDice();
next;
}
if ($choice eq "6")
{
$choice = 0;
next;
}
else
{
print "Please don't input control characters. They give me headaches\n";
next;
}
}
sub doStandard()
{
my @prolls;
my @qrolls;
my $p = my $q = 0;
while (1)
{
print "Number of dice for first actor: ";
$p = ;
chomp $p;
if ($p =~ /[0-9]+/) {last;}
print "That is not a valid number of dice. Please try again.\n";
}
while (1)
{
print "Number of dice for second actor: ";
$q = ;
chomp $q;
if ($q =~ /[0-9]+/) {last;}
print "That is not a valid number of dice. Please try again.\n";
}
for (my $i = 0; $i < $p; ++$i)
{
$prolls[$i] = int (rand(20) + 1);
}
for (my $i = 0; $i < $q; ++$i)
{
$qrolls[$i] = int (rand(20) + 1);
}
#Sorts elements in increasing order
@prolls = sort {$a <=> $b} @prolls;
@qrolls = sort {$a <=> $b} @qrolls;
#Make $p and $q index the last element of their respective arrays
$p--;
$q--;
my $successes = numSuccesses(\@prolls, \@qrolls);
if ($successes == 0)
{
print "It's a tie! Amazing!\n";
}
#Print out dice results
for (my $i = 0; $i <= min($#prolls, $#qrolls); ++$i)
{
print "$prolls[$i]\t$qrolls[$i]\n";
}
#Account for mismatch between $p and $q where $p > $q
if ($#prolls > $#qrolls)
{
for (my $i = $#qrolls + 1; $i <= $#prolls; ++$i)
{
print "$prolls[$i]\n";
}
}
#Account for mismatch between $p and $q where $q > $p
if ($#prolls < $#qrolls)
{
for (my $i = $#prolls + 1; $i <= $#qrolls; ++$i)
{
print "\t$qrolls[$i]\n";
}
}
#P wins
if ($successes > 0)
{
print "First actor wins with $successes success";
if ($successes > 1) {print "es";}
print ".\n";
}
#Q wins
if ($successes < 0)
{
$successes *= -1;
print "Second actor wins with $successes success";
if ($successes > 1) {print "es";}
print ".\n";
}
}
sub doBatchOne()
{
my @orolls;
my @prolls;
my @actors;
my $oppose;
while (1)
{
print "Difficulty of the task: ";
$oppose = ;
chomp $oppose;
if ($oppose =~ /^[0-9]+$/) {last;}
print "That is not a valid number.\n";
}
my $numActors = 0;
print "Now input the number of dice each actor gets, one to a line.\n" .
"Input a blank line when you want to stop.\n";
while (1)
{
my $in = ;
chomp $in;
if ($in eq "") {last;}
if ($in !~ /[0-9]+/)
{
print "That wasn't blank and wasn't a valid number. Please input again.\n";
next;
}
$actors[$numActors] = $in;
$numActors++;
}
#Done getting input; now see how the opposed force does.
for (my $i = 0; $i < $oppose; ++$i)
{
$orolls[$i] = int (rand(20) + 1);
}
#Sorts elements in increasing order
@orolls = sort {$a <=> $b} @orolls;
#And set rolls for everyone else
for (my $i = 0; $i < $numActors; ++$i)
{
for (my $j = 0; $j < $actors[$i]; ++$j)
{
$prolls[$i][$j] = int (rand(20) + 1);
}
$prolls[$i] = [sort {$a <=> $b} @{$prolls[$i]}];
}
#Print everything out. Do so by creating an output array, for the sake of
#simplicity
my @out;
$out[0] = "";
#Header line - the difficulty and the number of each actor
for (my $i = -1; $i < $numActors; ++$i)
{
if ($i == -1) {$out[0] .= "Difficulty";}
else {$out[0] .= "\t" . "Actor" . ($i + 1);}
}
$out[0] .= "\n";
my $i = 0;
#Set one line at a time until the line we just output was all whitespace
#Works because arrays default to empty. Probably shouldn't do that...
while ($out[$i - 1] !~ /^\s+$/)
{
#Output difficulty's roll for this level
$out[$i + 1] .= $orolls[$i] . "\t";
for (my $j = 0; $j < $numActors; ++$j)
{
$out[$i + 1] .= "\t" . $prolls[$j][$i];
}
$out[$i + 1] .= "\n";
$i++;
}
#Now determine the number of successes per actor and add that to @out.
#@out's last line is full of tabs, so wipe it first.
$out[$#out] = "";
$out[$#out] .= "Successes:";
for ($i = 0; $i < $numActors; ++$i)
{
my $t1 = $prolls[$i];
my $succ = numSuccesses($t1, \@orolls);
$out[$#out] .= "\t$succ";
}
$out[$#out++] .= "\n";
$out[$#out] = "\n";
print @out;
}
sub doBatchTwo()
{
my @prolls;
my @actors;
my $numActors = 0;
print "Input the number of dice each actor gets, one to a line.\n" .
"Input a blank line when you want to stop.\n";
while (1)
{
my $in = ;
chomp $in;
if ($in eq "") {last;}
if ($in !~ /[0-9]+/)
{
print "That wasn't blank and wasn't a valid number. Please input again.\n";
next;
}
$actors[$numActors] = $in;
$numActors++;
}
#Set dice rolls for everyone, and sort them.
for (my $i = 0; $i < $numActors; ++$i)
{
for (my $j = 0; $j < $actors[$i]; ++$j)
{
$prolls[$i][$j] = int (rand(20) + 1);
}
$prolls[$i] = [sort {$a <=> $b} @{$prolls[$i]}];
}
#Print everything out. Do so by creating an output array, for the sake of
#simplicity
my @out;
$out[0] = "";
#Header line - the difficulty and the number of each actor
for (my $i = 0; $i < $numActors; ++$i)
{
$out[0] .= "Actor" . ($i + 1) . "\t";
}
$out[0] .= "\n";
my $i = 0;
#Set one line at a time until the line we just output was all whitespace
#Works because arrays default to empty. Probably shouldn't do that...
while ($out[$i - 1] !~ /^\s+$/)
{
for (my $j = 0; $j < $numActors; ++$j)
{
$out[$i + 1] .= $prolls[$j][$i] . "\t";
}
$out[$i + 1] .= "\n";
$i++;
}
#Find the order of actors. Do this by converting each actor's dice rolls
#to a string (padding with zeroes as appropriate) and sorting. This
#magically handles ties for us and is very convenient. The only trick is
#that the strings must all be the same length...so we'll have to pad
#short actors with zeroes or else someone with lots of dice will always
#win.
#First determine the maximum number of dice
my $max = 0;
foreach my $dice (@actors)
{
if ($dice > $max) {$max = $dice;}
}
print @out;
my %strhash;
#Generate the strings and add them to a hash of actor-string pairs.
for (my $j = 0; $j < $numActors; ++$j)
{
my $str = "";
for (my $k = $actors[$j] - 1; $k >= 0; --$k)
{
#Handle single-digit results
if ($prolls[$j][$k] < 10) {$str .= "0";}
$str .= $prolls[$j][$k];
}
#Pad with zeroes
for (my $k = 0; $k < $max - $actors[$j]; ++$k) {$str .= "00";}
$strhash{$j} = $str;
}
#Now output our results.
print "Results: ";
my @results = sort {$strhash{$b} <=> $strhash{$a}} (keys(%strhash));
foreach my $key (@results)
{
if ($key eq $results[$#results]) {print $key + 1 . "\n";}
else {print $key + 1 . ", ";}
}
print "\n\n";
}
#Like doBatchTwo, except that we compare everyone against a difficulty, and
#they succeed or fail on their own. We also want to count successes in this
#mode. This basically means copying a lot of code from doBatchOne and
#doBatchTwo. Ah, well.
sub doBatchThree()
{
my @orolls;
my @prolls;
my @actors;
my $oppose;
while (1)
{
print "Difficulty of the task: ";
$oppose = ;
chomp $oppose;
if ($oppose =~ /^[0-9]+$/) {last;}
print "That is not a valid number.\n";
}
my $numActors = 0;
print "Input the number of dice each actor gets, one to a line.\n" .
"Input a blank line when you want to stop.\n";
while (1)
{
my $in = ;
chomp $in;
if ($in eq "") {last;}
if ($in !~ /[0-9]+/)
{
print "That wasn't blank and wasn't a valid number. Please input again.\n";
next;
}
$actors[$numActors] = $in;
$numActors++;
}
#Done getting input; now see how the opposed force does.
for (my $i = 0; $i < $oppose; ++$i)
{
$orolls[$i] = int (rand(20) + 1);
}
@orolls = sort {$a <=> $b} @orolls;
#Set dice rolls for everyone, and sort them.
for (my $i = 0; $i < $numActors; ++$i)
{
for (my $j = 0; $j < $actors[$i]; ++$j)
{
$prolls[$i][$j] = int (rand(20) + 1);
}
$prolls[$i] = [sort {$a <=> $b} @{$prolls[$i]}];
}
#Print everything out. Do so by creating an output array, for the sake of
#simplicity
my @out;
$out[0] = "";
#Header line - the difficulty and the number of each actor
$out[0] .= "Difficulty";
for (my $i = 0; $i < $numActors; ++$i)
{
$out[0] .= "\tActor" . ($i + 1);
}
$out[0] .= "\n";
my $i = 0;
#Set one line at a time until the line we just output was all whitespace
#Works because arrays default to empty. Probably shouldn't do that...
while ($out[$i - 1] !~ /^\s+$/)
{
#First output the opposed roll
$out[$i + 1] .= $orolls[$i] . "\t";
for (my $j = 0; $j < $numActors; ++$j)
{
$out[$i + 1] .= "\t$prolls[$j][$i]";
}
$out[$i + 1] .= "\n";
$i++;
}
#Find the order of actors. Do this by converting each actor's dice rolls
#to a string (padding with zeroes as appropriate) and sorting. This
#magically handles ties for us and is very convenient. But like in
#doBatchTwo, we need to pad with zeroes so we don't let people with
#many dice always win.
#First determine the maximum number of dice
my $max = 0;
foreach my $dice (@actors)
{
if ($dice > $max) {$max = $dice;}
}
print @out;
my %strhash;
#Generate the strings and add them to a hash of actor-string pairs.
for (my $j = 0; $j < $numActors; ++$j)
{
my $str = "";
for (my $k = $actors[$j] - 1; $k >= 0; --$k)
{
#Handle single-digit results
if ($prolls[$j][$k] < 10) {$str .= "0";}
$str .= $prolls[$j][$k];
}
#Pad with zeroes
for (my $k = 0; $k < $max - $actors[$j]; ++$k) {$str .= "00";}
$strhash{$j} = $str;
}
#Now output our results.
print "Results(Successes): ";
my @results = sort {$strhash{$b} <=> $strhash{$a}} (keys(%strhash));
foreach my $key (@results)
{
#Determine number of successes for that actor
my $t1 = $prolls[$key];
my $succ = numSuccesses($t1, \@orolls);
if ($key eq $results[$#results])
{
print $key + 1 . "($succ)\n";
}
else
{
print $key + 1 . "($succ), ";
}
}
print "\n\n";
}
#Just roll generic dice - some number of dice with some number of sides,
#both input by the user.
sub doDice()
{
print "On each line input the number of dice and number of sides you want
to roll, separated by a d (e.g. 3d4 or 1d20). Input a blank line to stop.\n";
my @ndice;
my @nsides;
my @totals;
my $numRolls = 0;
my $maxDice = 0;
while (1)
{
my $in = ;
chomp $in;
if ($in eq "") {last;}
if ($in !~ /[0-9]+d[0-9]+/)
{
print "That wasn't blank and wasn't a valid entry. Please input again.\n";
next;
}
($ndice[$numRolls], $nsides[$numRolls]) = split(/d/, $in);
if ($maxDice < $ndice[$numRolls]) {$maxDice = $ndice[$numRolls];}
$numRolls++;
}
#Print out the header
print "\t";
for (my $i = 0; $i < $numRolls; ++$i)
{
print "$ndice[$i]d$nsides[$i]\t";
}
print "\n";
#Print out the results, one line at a time.
for (my $i = 0; $i < $maxDice; ++$i)
{
print "\t";
for (my $j = 0; $j < $numRolls; ++$j)
{
#No printing results if we're out of dice already
if ($i < $ndice[$j])
{
my $temp = int (rand($nsides[$j]) + 1);
$totals[$j] += $temp;
print "$temp\t";
}
else
{
print "\t";
}
}
print "\n";
}
#Print out totals
print "\nTotals:\t";
for (my $i = 0; $i < $numRolls; ++$i)
{
print "$totals[$i]\t";
}
print "\n";
}
#Return number of successes of p against q. May be negative, in which case
#q has that many successes against p, instead.
sub numSuccesses()
{
my $t1 = $_[0];
my $t2 = $_[1];
my @prolls = @$t1;
my @qrolls = @$t2;
my $p = $#prolls;
my $q = $#qrolls;
#Account for any tied rolls
my $done = 0;
my $bonus = 0;
while (!$done and min($p, $q) >= 0)
{
my $maxp = $prolls[$p];
my $maxq = $qrolls[$q];
if ($maxp == $maxq)
{
$bonus++;
$p--;
$q--;
}
else {$done = 1;}
}
#Short-circuits: since negative indices screw things up, catch them before
#going further. Set a boolean so we know exactly who won.
my $pwins = 0;
my $qwins = 0;
if ($p < 0 or $q < 0)
{
if ($p == $q)
{
#Tie
if ($prolls[$p] == $qrolls[$q]) {return 0;}
#P wins
if ($prolls[$p] > $qrolls[$q]) {return $bonus;}
#Q wins
return -1 * $bonus;
}
if ($p < 0)
{
$qwins = 1;
}
if ($q < 0)
{
$pwins = 1;
}
}
#P wins if Q ran out of dice or P's max roll beats Q's max roll or
#we previously determined that Q did not win
if (!$qwins and ($q < 0 or ($prolls[$p] > $qrolls[$q])))
{
#Calculate successes
#Ensure they still have dice left.
#If Q is out of dice, give the rest of the dice to P.
if ($q < 0) {return $bonus + $p + 1;}
if ($p >= 0)
{
for (my $i = $p; $i > -1; --$i)
{
if ($prolls[$i] <= $qrolls[$q]) {last;}
$bonus++;
}
}
return $bonus;
}
#Q wins if P ran out of dice or P has a higher max die roll or we
#previously determined that P did not win.
if (!$pwins and ($p < 0 or ($qrolls[$q] > $prolls[$p])))
{
#Calculate successes
#Ensure they still have dice left.
#If P is out of dice, then just give the rest of the dice to Q.
if ($p < 0) {return -1 * ($bonus + $q + 1);}
if ($q >= 0)
{
for (my $i = $q; $i > -1; --$i)
{
if ($prolls[$p] >= $qrolls[$i]) {last;}
$bonus++;
}
}
return -1 * $bonus;
}
}
sub min()
{
return ($_[0] > $_[1]) ? $_[1] : $_[0];
}