From: Don Armstrong Date: Sat, 15 Nov 2014 02:27:38 +0000 (-0800) Subject: add pocket devotee X-Git-Url: https://git.donarmstrong.com/?p=bin.git;a=commitdiff_plain;h=fbd5071cf1eb41f9fc62325a6142dd10a41f1717 add pocket devotee --- diff --git a/pocket_devotee b/pocket_devotee new file mode 100755 index 0000000..97a2433 --- /dev/null +++ b/pocket_devotee @@ -0,0 +1,633 @@ +#!/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} < $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 + +=head1 COPYRIGHT AND LICENSE + +This script is a part of the Devotee package, and is + +Copyright (c) 2002, 2003, 2004, 2005 Manoj Srivastava + +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__ +