#!/usr/bin/perl -w
#                              -*- Mode: Cperl -*- 
# pocket_devotee --- 
# Author           : Manoj Srivastava ( srivasta@glaurung.green-gryphon.com ) 
# Created On       : Thu Oct 16 12:08:43 2003
# Created On Node  : glaurung.green-gryphon.com
# Last Modified By : Manoj Srivastava
# Last Modified On : Sat Mar 10 09:42:54 2007
# Last Machine Used: glaurung.internal.golden-gryphon.com
# Update Count     : 203
# Status           : Unknown, Use with caution!
# HISTORY          : 
# Description      : 
# arch-tag: 1a48504a-0668-4790-aa72-d4359a3c41e2
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# 

use warnings;
use strict;

require 5.005;
use Carp qw(carp croak);
use Params::Validate qw(validate_with :types);
use Getopt::Long;
#use Math::BigInt ':constant';
#use Math::BigFloat;

=head1 NAME

pocket_devotee - Given a tally sheet, calculate the Condorcet winner

=cut

=head1 SYNOPSIS

pocket_devotee --option 'A:foo' --option 'B:bar' < tally_sheet
pocket_devotee --num-options 3 < tally_sheet

=cut

=head1 DESCRIPTION

Produce the results, taking into consideration the tally, quorum
requirements, and the per option majority requirements, if any.
This routine is the heart of the voting system. It takes into account
quorum requirements (reading the output file produced by dvt-quorum),
and also the configured majority requirements, if any.

It reads the tally sheet produced by dvt-tally, and creates the
initial beat matrix; and the pairwise defeat list, and finally the
schwartz set. If there are defeats between the members of the schwartz
set, it drops the weakest defeat and repeats, until there is a winner.

It puts the results in the configured output file.

=cut

=head2 Internal Implementation

=head3 winner

This is the workhorse routine. 
This routine pays attention to the configuration variables
Quorum_File, Tally_File, Max_Choices, and Results.

=cut


my %Config;

our %option_to_number;
our %number_to_option;

BEGIN{

    @number_to_option{((0..9),(10..35))} = (('0'..'9'),('A'..'Z'));
    %option_to_number = reverse %number_to_option;

}

main();

sub main {
    my %options;
    GetOptions(\%options,
               'option=s@',
              );
    if (not exists $options{option} or not ref($options{option}) or
        @{$options{option}} < 2
       ) {
        die "you must give at least two options in a --option argument";
    }
    my @options;
    for my $option (@{$options{option}}) {
        my ($key,$name,$majority) = split /:/,$option;
        $majority //= 1;
        push @options,{key => $key,
                       name => $name,
                       majority => $majority,
                      };
    }
    winner(options=>\@options);
}

sub encode_base64{
    return map {$option_to_number{$_}} @_;
}

sub decode_base64{
    return map {$number_to_option{$_}} @_;
}

sub winner {
  my %params   = validate_with(params => \@_,
                               spec   => {quorum => {default => 5,
                                                     regex => qr/^\d+$/,
                                                    },
                                          options => {type => ARRAYREF,
                                                     },
                                          tally_fh => {type => HANDLE,
                                                       optional => 1,
                                                      },
                                         },
                               );
  # options is an array to keep it ordered
  my @options = @{$params{options}};
  my %options;
  my %order_to_options;
  my $max_choices = 0;
  my $order=1;
  my $valid_options = '';
  for my $option (@options) {
      $options{$option->{key}} =
         {key => $option->{key},
          name => $option->{name},
          majority => $option->{majority} // 1,
          order => $order,
         };
      $order_to_options{$order} = $options{$option->{key}};
      $valid_options .= $option->{key};
      $max_choices = $order;
      $order++;
  }

  # The constitution defines the maximum value of K to be 5
  my $K = 5; # Math::BigFloat->new($params{quorum});

  #   1. Given two options A and B, V(A,B) is the number of voters who
  #      prefer option A over option B.
  my @Beat_Matrix = ();
  for my $row (0..$max_choices) {
    for my $col (0..$max_choices) {
      $Beat_Matrix[$row][$col] = 0; #Math::BigFloat->bzero();
    }
  }
  
  my $RESULTS = \*STDOUT;

  my $now_string = gmtime;
  print {$RESULTS} "Starting results calculation at $now_string\n\n";

  if (not defined $params{tally_fh}) {
      $params{tally_fh} = \*STDIN;
  }

  # This is where we get our input data from
  while (defined ($_ = $params{tally_fh}->getline)) {
      chomp;
      my $vote;
      my $voter;
      if (m/^V:\s+(\S+)\s+(\S)/) { # standard devotee syntax
          $voter = $2;
          $vote = $1;
      } elsif (m/^(.+) # the voter, can have spaces
                 \s*:\s+ # needs a colon and a space
                 ((?:[$valid_options] # the vote
                         \s*(?:,|=|<)?\s*)*) # allow < and , or =
                 \s*$/x # useless trailing spaces
              ) {
          $voter = $1;
          $vote = $2;
          # now, because this format has the options ranked instead of
          # the rank of the option, figure out the rank of the option,
          # and give that to devotee
          my $current_rank = 1;
          my %option_rank;
          while ($vote =~ /([$valid_options]) # the vote
                           \s*((?:,|=|<)?)\s*/xg) {
              my ($option,$relationship) = ($1,$2);
              $option_rank{$option} = $current_rank;
              if ($relationship ne '=') {
                  $current_rank++;
              }
          }
          $vote = '';
          for my $opt (@options) {
              $vote .= exists $option_rank{$opt->{key}} ? $option_rank{$opt->{key}} : '-';
          }
          print {$RESULTS} "V: $vote $voter\n";

      } else {
         print STDERR "ignoring line '$_'; this is probably wrong!";
         next;
      }

      # my @rank = unpack "a" x $max_choices, $vote;
      my @rank = ();
      foreach my $rank (split //, uc $vote) {
          if ($rank eq '-') {
              push(@rank,$rank);
          }
          else {
              push(@rank,encode_base64($rank));
          }
      }
      foreach my $i (0..($max_choices - 1)) {
          foreach my $j (($i + 1)..($max_choices - 1)) {
              if ($rank[$i] eq '-' && $rank[$j] eq '-') {
                  next;                 # Both unranked
              } elsif ($rank[$i] eq '-' && $rank[$j] ne '-') {
                  $Beat_Matrix[$j][$i]++;
              } elsif ($rank[$i] ne '-' && $rank[$j] eq '-') {
                  $Beat_Matrix[$i][$j]++;
              } elsif ($rank[$i] < $rank[$j]) {
                  $Beat_Matrix[$i][$j]++;
              } elsif ($rank[$i] > $rank[$j]) {
                  $Beat_Matrix[$j][$i]++;
              } else {
                  next;                 # Equally ranked
              }
          }
      }
  }
  for my $opt (0..($max_choices - 1)) {
      print {$RESULTS} "Option ", $order_to_options{$opt+1}{key}, " \"", 
          $order_to_options{$opt+1}{name},
          "\"\n";
  }
  print {$RESULTS} <<EOF;

In the following table, tally[row x][col y] represents the votes that
option x received over option y.

EOF
  ;

  print {$RESULTS} " " x18, "Option\n";
  print {$RESULTS} " " x10;
  for my $col (0..($max_choices - 1)) {
      printf {$RESULTS} " % 4s ", $order_to_options{$col + 1}{key};
  }

  print {$RESULTS} "\n";
  print {$RESULTS} " " x10, "  === " x $max_choices, "\n";

  for my $row (0..($max_choices - 1)) {
      printf {$RESULTS} "Option %s  ", $order_to_options{$row + 1}{key};
      for my $col (0..($max_choices - 1)) {
          if ($row == $col) {
              printf {$RESULTS} "      ", $Beat_Matrix[$row][$col];
          } else {
              printf {$RESULTS} " % 4d ", $Beat_Matrix[$row][$col];
          }
      }
      print {$RESULTS} "\n";
  }
  print {$RESULTS} "\n\n";

  print {$RESULTS} <<EOM;

Looking at row 2, column 1, $order_to_options{2}{key}
received $Beat_Matrix[1][0] votes over $order_to_options{1}{key}

Looking at row 1, column 2, $order_to_options{1}{key}
received $Beat_Matrix[0][1] votes over $order_to_options{2}{key}.

EOM
  ;
  
  my %Drop = ();

  foreach my $i (0..($max_choices - 2)) {
      if ($K > $Beat_Matrix[$i][$max_choices - 1]) {
          $Drop{$i}++;
          print {$RESULTS} "Dropping Option", $order_to_options{$i + 1}{key}, 
              " \"", $order_to_options{$i + 1}{name},
              "\" because of Quorum\n";
      } else {
          print {$RESULTS} "Option ", $order_to_options{$i + 1}{key},
              " Reached quorum: $Beat_Matrix[$i][$max_choices - 1] > $K\n";
      }
  }
  print {$RESULTS} "\n\n";

  # Record Majority
  my %Ratio = ();


  #   2. An option A defeats the default option D by a majority ratio N,
  #   if V(A,D) is strictly greater than N * V(D,A).
  #   3. If a supermajority of S:1 is required for A, its majority ratio
  #   is S; otherwise, its majority ratio is 1.
  #  Any (non-default) option which does not defeat the default option
  #  by its required majority ratio is dropped from consideration.
  foreach my $i (0..($max_choices - 2)) {
      next unless $Beat_Matrix[$max_choices - 1][$i];
      next if $Drop{$i};

      my $ratio = 1.0 * $Beat_Matrix[$i][$max_choices - 1] /
          $Beat_Matrix[$max_choices - 1][$i];
      $Ratio{$i} = sprintf("%.2f", $ratio);
      if ($ratio < $order_to_options{$i + 1}{majority}) {
          # If the next line is commented out, we get a more verbose set of results
          $Drop{$i}++;
          print {$RESULTS} "Dropping Option ", $order_to_options{$i + 1}{key},
              " because of Majority. ($ratio)";
          printf {$RESULTS} " %6.3f (%d/%d) < %d\n",
              $ratio, $Beat_Matrix[$i][$max_choices - 1],
              $Beat_Matrix[$max_choices - 1][$i],
              $order_to_options{$i + 1}{majority};
      } else {
          print {$RESULTS} "Option ", $order_to_options{$i + 1}{key}, " passes Majority.";
          print {$RESULTS} "             ";
          printf {$RESULTS} " %6.3f (%d/%d) >= %d\n",
              $ratio, $Beat_Matrix[$i][$max_choices - 1],
              $Beat_Matrix[$max_choices - 1][$i],
              $order_to_options{$i + 1}{majority};
      }
  }
  print {$RESULTS} "\n\n";

  my $done = 0;
  my %Defeats;
  # Initialize the Defeats matrix
  foreach my $i (0..($max_choices - 1)) {
    next if $Drop{$i};
    foreach my $j (($i + 1)..($max_choices - 1)) {
        next if $Drop{$j};
        if ($Beat_Matrix[$i][$j] > $Beat_Matrix[$j][$i]) {
            # i defeats j
            $Defeats{$i}{$j}{for}     = $Beat_Matrix[$i][$j];
            $Defeats{$i}{$j}{against} = $Beat_Matrix[$j][$i];

            print {$RESULTS} "  Option ", $order_to_options{$i + 1}{key}, " defeats Option ",
                $order_to_options{$j + 1}{key},
                sprintf(" by (% 4d - % 4d) = %4d votes.\n", 
                        $Beat_Matrix[$i][$j],  $Beat_Matrix[$j][$i], 
                        $Beat_Matrix[$i][$j] - $Beat_Matrix[$j][$i]);
        } elsif ($Beat_Matrix[$i][$j] < $Beat_Matrix[$j][$i]) {
            # j defeats i
            $Defeats{$j}{$i}{for}     = $Beat_Matrix[$j][$i];
            $Defeats{$j}{$i}{against} = $Beat_Matrix[$i][$j];

            print {$RESULTS} "  Option ", $order_to_options{$j + 1}{key}, " defeats Option ",
                $order_to_options{$i + 1}{key},
                sprintf(" by (% 4d - % 4d) = %4d votes.\n",
                        $Beat_Matrix[$j][$i],  $Beat_Matrix[$i][$j], 
                        $Beat_Matrix[$j][$i] - $Beat_Matrix[$i][$j]);
        }
    }
}
  print {$RESULTS} "\n\n";
  my %BeatPath;
  my @Schwartz;
  # Ok, here is what we are here for.
  while (1) {

    # From the list of [undropped] pairwise defeats, we generate a set of
    # transitive defeats.

    # Initialize the Beatpath
    undef %BeatPath;
    foreach my $i (0..($max_choices - 1)) {
      next if $Drop{$i};
      foreach my $j (0..($max_choices - 1)) {
        next if $Drop{$j};
        $BeatPath{$i}{$j}{for}     = $Defeats{$i}{$j}{for};
        $BeatPath{$i}{$j}{against} = $Defeats{$i}{$j}{against};
      }
    }

    #   1. An option A transitively defeats an option C if A defeats C or
    #      if there is some other option B where A defeats B AND B
    #      transitively defeats C.
    while (!$done) {
      $done = 1;
      foreach my $i (0..($max_choices - 1)) {
        next if $Drop{$i};
        foreach my $j (0..($max_choices - 1)) {
          next if $Drop{$j};
          next if $i == $j;
          foreach my $k (0..($max_choices - 1)) {
            next if $Drop{$k};
            next if $i == $k;
            next if $k == $j;
            if (!$BeatPath{$i}{$j}{for}) {
              if ($BeatPath{$i}{$k}{for} && $BeatPath{$k}{$j}{for} ) {
                if ($BeatPath{$i}{$k}{for} == $BeatPath{$k}{$j}{for}) {
                  $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{against} > 
                                            $BeatPath{$k}{$j}{against}) ?
                                              $BeatPath{$i}{$k}{for}:$BeatPath{$k}{$j}{for};
                  $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{against} > 
                                                $BeatPath{$k}{$j}{against}) ?
                                                  $BeatPath{$i}{$k}{against} :
                                                    $BeatPath{$k}{$j}{against};
                } else {
                  $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{for} < 
                                            $BeatPath{$k}{$j}{for}) ?
                                              $BeatPath{$i}{$k}{for} : 
                                                $BeatPath{$k}{$j}{for};
                  $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{for} < 
                                                $BeatPath{$k}{$j}{for}) ?
                                                  $BeatPath{$i}{$k}{against} :
                                                    $BeatPath{$k}{$j}{against};
                }
                $done = 0;
              }
            }
          }
        }
      }
    }


    # We construct the Schwartz set from the set of transitive defeats.
    foreach my $i (0..($max_choices - 1)) {
      if ($Drop{$i}) {
        $Schwartz[$i] = 0;
      } else {
        $Schwartz[$i] = 1;
      }
    }

    foreach my $i (0..($max_choices - 1)) {
      foreach my $j (0..($max_choices - 1)) {
        next if $i == $j;
        # An option A is in the Schwartz set if for all options B, either
        # A transitively defeats B, or B does not transitively defeat A
        # Here, we throw out any option $i that does not meet the above
        # criteria.
        if (! ($BeatPath{$i}{$j}{for} || ! $BeatPath{$j}{$i}{for})) {
          $Schwartz[$i] = 0;
        }
      }
    }
    print {$RESULTS} "The Schwartz Set contains:\n";
    foreach my $i (0 ..$#Schwartz) {
      next unless $Schwartz[$i];
      print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"", 
        $order_to_options{$i + 1}{name}, "\"\n";
    }
    print {$RESULTS} "\n\n";

    # If there are defeats between options in the Schwartz set, we drop
    # the weakest such defeats from the list of pairwise defeats, and
    # return to step 5.

    #  1. A defeat (A,X) is weaker than a defeat (B,Y) if V(A,X) is
    #     less than V(B,Y). Also, (A,X) is weaker than (B,Y) if V(A,X) is
    #     equal to V(B,Y) and V(X,A) is greater than V(Y,B).

    #  2. A weakest defeat is a defeat that has no other defeat weaker
    #  than it. There may be more than one such defeat.

    # Check to see if there is anything in the Schwartz set that has no
    # defeats.
    my %Weakest;
    my $weak_count = 0;
    foreach my $i (0 ..$#Schwartz) {
      next unless $Schwartz[$i];
      foreach my $j (0..$#Schwartz) {
        next unless $Schwartz[$j];
        next if $i == $j;
        if (defined $Defeats{$i}{$j}{'for'}) {
          if (! $weak_count) {
            $Weakest{$weak_count}{'for'}     = $Defeats{$i}{$j}{for};
            $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
            $Weakest{$weak_count}{'Winner'}  = $i;
            $Weakest{$weak_count}{'Loser'}   = $j;
            $weak_count++;
          } elsif ($Weakest{0}{'for'} > $Defeats{$i}{$j}{for}) {
            undef %Weakest;
            $weak_count = 0;
            $Weakest{$weak_count}{'for'}     = $Defeats{$i}{$j}{for};
            $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
            $Weakest{$weak_count}{'Winner'}  = $i;
            $Weakest{$weak_count}{'Loser'}   = $j;
            $weak_count++;
          } elsif ($Weakest{0}{'for'} == $Defeats{$i}{$j}{'for'}) {
            if ($Weakest{0}{'against'} < $Defeats{$i}{$j}{against}) {
              undef %Weakest;
              $weak_count = 0;
              $Weakest{$weak_count}{'for'}     = $Defeats{$i}{$j}{for};
              $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
              $Weakest{$weak_count}{'Winner'}  = $i;
              $Weakest{$weak_count}{'Loser'}   = $j;
              $weak_count++;
            } else {
              $Weakest{$weak_count}{'for'}     = $Defeats{$i}{$j}{'for'};
              $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{'against'};
              $Weakest{$weak_count}{'Winner'}  = $i;
              $Weakest{$weak_count}{'Loser'}   = $j;
              $weak_count++;
            }
          }
        }
        if (defined $Defeats{$j}{$i}{'for'}) {
          if (! $weak_count) {
            $Weakest{$weak_count}{'for'}     = $Defeats{$j}{$i}{'for'};
            $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
            $Weakest{$weak_count}{'Winner'}  = $j;
            $Weakest{$weak_count}{'Loser'}   = $i;
            $weak_count++;
          } elsif ($Weakest{0}{'for'} > $Defeats{$j}{$i}{'for'}) {
            undef %Weakest;
            $weak_count = 0;
            $Weakest{$weak_count}{'for'}     = $Defeats{$j}{$i}{'for'};
            $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
            $Weakest{$weak_count}{'Winner'}  = $j;
            $Weakest{$weak_count}{'Loser'}   = $i;
            $weak_count++;
          } elsif ($Weakest{0}{'Low'} == $Defeats{$j}{$i}{'for'}) {
            if ($Weakest{0}{'against'} < $Defeats{$j}{$i}{'against'}) {
              undef %Weakest;
              $weak_count = 0;
              $Weakest{$weak_count}{'for'}    = $Defeats{$j}{$i}{'for'};
              $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
              $Weakest{$weak_count}{'Winner'} = $j;
              $Weakest{$weak_count}{'Loser'}  = $i;
              $weak_count++;
            } else {
              $Weakest{$weak_count}{'for'}     = $Defeats{$j}{$i}{'for'};
              $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
              $Weakest{$weak_count}{'Winner'}  = $j;
              $Weakest{$weak_count}{'Loser'}   = $i;
              $weak_count++;
            }
          }
        }
      }
    }
    if (! $weak_count) {
      print {$RESULTS} "\n", "-=" x 35, "\n";
      print {$RESULTS} "-=" x 35, "\n\n";
      print {$RESULTS} "The winners are:\n";
      foreach my $i (0 ..$#Schwartz) {
        next unless $Schwartz[$i];
        print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"", 
          $order_to_options{$i + 1}{name}, "\"\n";
      }
      print {$RESULTS} "\n", "-=" x 35, "\n";
      print {$RESULTS} "-=" x 35, "\n\n";
      last;
    } else {
      print {$RESULTS} "Weakest Defeat(s): \n";
      foreach my $k (sort keys %Weakest) {
        print {$RESULTS} "\tOption ", $order_to_options{$Weakest{$k}{'Winner'} + 1}{key},
          " beats Option ", $order_to_options{$Weakest{$k}{'Loser'} + 1}{key}, " by ",
            " ($Beat_Matrix[$Weakest{$k}{'Winner'}][$Weakest{$k}{'Loser'}] - ",
              "$Beat_Matrix[$Weakest{$k}{'Loser'}][$Weakest{$k}{'Winner'}])\t",
                "= ", $Weakest{$k}{'for'} - $Weakest{$k}{'against'}, " votes\n";
      }
      print {$RESULTS} "Deleting weakest defeat(s)\n\n";
      foreach my $k (sort keys %Weakest) {
        delete $Defeats{$Weakest{$k}{'Winner'}}{$Weakest{$k}{'Loser'}};
      }
  }
}
}





exit 0;


=head1 CAVEATS

This is very inchoate, at the moment, and needs testing.

=cut

=head1 BUGS

None Known so far.

=cut

=head1 AUTHOR

Manoj Srivastava <srivasta@debian.org>

=head1 COPYRIGHT AND LICENSE

This script is a part of the Devotee package, and is 

Copyright (c) 2002, 2003, 2004, 2005  Manoj Srivastava <srivasta@debian.org>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

=cut



__END__