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