stv

   1 #!/usr/bin/perl -w
   2 #
   3 # Does STV according to
   4 #  http://www.rosenstiel.co.uk/stvrules/av/index.htm
   5
   6 use strict;
   7 use utf8;
   8 use autodie;
   9 use bigrat;
  10 use List::MoreUtils qw(nsort_by);
  11
  12 # vote is
  13 #  { Voter => opaque,
  14 #    Prefs => [ list ],
  15 #    Weight => 1.0 }
  16
  17 our $stage=0;
  18 our @allvotes;
  19
  20 our $places = shift @ARGV;
  21 die unless $places eq ($places + 0);
  22
  23 while (<>) {
  24     next if m/^\w+$/;
  25     m/^(\w+) ([A-Z]+)$/ or die "$_ ?";
  26     my $prefs = $1;
  27     my $vote = {
  28         Voter => $1,
  29         Weight => 1.0,
  30         Prefs => [ split //, $prefs ],
  31     };
  32     push @allvotes, $vote;
  33 }
  34
  35 sub pr ($) {
  36     my ($f) = @_;
  37     return sprintf "%10.6f=%-10s", $f, $f;
  38 }
  39
  40 sub votelog ($$) {
  41     my ($vote,$m) = @_;
  42     push @{ $vote->{Log} }, "stage $stage: $m";
  43 }
  44
  45 sub filterout ($$) {
  46     my ($cand, $why) = @_;
  47     foreach my $vote (@allvotes) {
  48         my $oldprefs = $vote->{Prefs};
  49         my @prefs = grep { $_ ne $cand } $oldprefs;
  50         next if @prefs == @$oldprefs;
  51         votelog $vote, "crossed out candidate $cand: $why";
  52     }
  53 }
  54
  55 our @elected; # $elected[] = $candidate
  56
  57 our @unsorted = @allvotes;
  58
  59 our %sorted;
  60 # $sorted{$firstpref}{Votes} = [ $vote, ... ]
  61 # $sorted{$firstpref}{Cand} = $firstpref
  62 # $sorted{$firstpref}{Total} = $totalweight
  63 our @sorted; # values same as %sorted
  64 our @surpluses; # values same as %sorted
  65
  66 our @exhausted; # votes
  67
  68 our %continuing; # $continuing{$candidate}=1
  69
  70 our @stagerecord; # $stagerecord[]{$candidate} = $total
  71
  72 foreach my $vote (@allvotes) {
  73     $continuing{$_}=1 foreach @{ $vote->{Prefs} };
  74 }
  75
  76 sub equalpiles ($@) {
  77     my ($how, @sorted) = @_;
  78     return () unless @sorted;
  79     my $s = $sorted[0];
  80     my $eqtotal = $s->{Total};
  81     my $count = 0;
  82     while ($count < @$sorted && $sorted[$count]{Total} == $eqtotal) {
  83         printf "%7s %10s\n", $how, $sorted[$count]{Cand};
  84         $count++;
  85     }
  86
  87
  88 for (;;) {
  89     $stage++;
  90
  91     while (my $vote = shift @unsorted) {
  92         my ($firstpref) = grep { $continuing{$_} } @{ $vote->{Prefs} };
  93         if (!defined $firstpref) {
  94             votelog $vote, "ballot exhausted";
  95             push @exhausted, $vote;
  96         } else {
  97             push @{ $sorted{$firstpref}{Votes} }, $vote;
  98         }
  99     }
 100     $sorted{$_}{Cand} = $_ foreach keys %sorted;
 101     foreach my $firstpref (sort keys %sorted) {
 102         foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
 103             votelog $vote, "counted $vote->{Weight} for $firstpref";
 104             $sorted{$firstpref}{Total} += $vote->{Weight};
 105         }
 106     }
 107     my @sorted;
 108     my $sort_update = sub {
 109         @sorted = nsort_by { -$_->{Total} } values %sorted;
 110     };
 111     $sort_update->();
 112
 113     push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted };
 114
 115     my $totalvalid = 0;
 116     my $countvalid = sub {
 117         my ($l, $what) = @_;
 118         foreach my $s (@$l) {
 119             printf "%-7s %10s %s\n", $what, $s->{Cand}, pr $s->{Total};
 120             $totalvalid += $s->{Total};
 121         }
 122     };
 123     $countvalid->(\@sorted,    '1stpref');
 124     $countvalid->(\@surpluses, 'surplus');
 125
 126     printf "%7s %10s %s\n", 'TOTAL', '', pr $totalvalid;
 127
 128     unless ($totalvalid > 0) {
 129         printf "No more votes!\n";
 130         last;
 131     }
 132
 133     my $placesremain = $places - @elected;
 134
 135     unless ($placesremain > 0) {
 136         printf "Complete.\n";
 137         last;
 138     }
 139
 140     my $quota = $totalvalid / ($placesremain + 1);
 141     printf "%7s %10s %s\n", '', 'quota', pr $quota;
 142
 143     my $need_to_transfer_surplus = 1;
 144
 145     # Look for people to elect.
 146     # We elect as many as we can, rather than recomputing the (lower) quota
 147     # (ERS rules 5.4.9)
 148     for (;;) {
 149         my $s = $sorted[0];
 150         my $topvoters = $s->{Weight};
 151         my $surplus = $topvoters - $quota;
 152         last unless $surplus > 0;
 153
 154         printf "%7s %10s\n", 'ELECTED', $s->{Cand};
 155         push @elected, $s->{Cand};
 156
 157         my $derate = $topvoters / $surplus;
 158         printf "%7s %10s\n", 'derate', $s->{Cand}, pr $derate;
 159
 160         foreach my $vote (@{ $s->{Votes} }) {
 161             votelog $vote, "elected $s->{Cand}, derated $weightmult";
 162             $vote->{Weight} /= $derate;
 163         }
 164         push @surpluses, $s;
 165         delete %sorted{ $s->{Cand} };
 166         delete $continuing{ $s->{Cand} };
 167
 168         $sort_update->();
 169         $need_to_transfer_surplus = 0;
 170         # before actually transferring a surplus, we will consider
 171         # eliminating, and then reconsider with a lower quota
 172     }
 173
 174     my $deferredsurplus = sum map { $_->{Total} } @surpluses;
 175     printf "%7s %10s %s\n", 'def.srp', 'total', pr $deferredsurplus;
 176
 177     # Look for people to eliminate
 178     # We eliminate before trying to transfer surpluses
 179     # ERS 5.2.5
 180     for (;;) {
 181         last unless @sorted;
 182
 183         my @elim = equalpiles 'elim?', reverse @sorted;
 184         my $elimvote = sum map { $_->{Total} } @elim;
 185         my $elimvotetotal = $elimvote * scalar @elim;
 186
 187         if (@surpluses and $elimvotetotal > $deferredsurplus) {
 188             printf "no-elim, un-defer\n";
 189             last;
 190         }
 191
 192         if ((scalar keys %continuing) - (scalar @elim) < $placesremain) {
 193             # eliminate only one then, and try again
 194             printf "elim-tie!\n";
 195             @elim = historically_prefer -1, @elim;
 196         }
 197
 198         foreach my $s (@elim) {
 199             my $c = $s->{Cand};
 200             printf "%7s %10s\n", 'ELIM', $c;
 201             my $votes = $s->{Votes};
 202             votelog $_, "failed to stop $c elimination" foreach @$votes;
 203             delete %continuing{$c};
 204             delete %sorted{$c};
 205             push @unsorted, @$votes;
 206         }
 207
 208         $sort_update->();
 209         $need_to_transfer_surplus = 0;
 210     }
 211
 212     next unless $need_to_transfer_surplus;
 213
 214     @surpluses = nsort_by { $_->{Total} }, @surpluses;
 215     my @surplusxfer = equalpiles 'xfer?', @surpluses;
 216     die unless @surplusxfer;
 217
 218     if (@surplusxfer > 1) {
 219         @surplusxfer = historically_prefer +1, @surplusxfer;
 220     }
 221
 222     my $s = $surplusxfer[0];
 223     my $c = $s->{Cand};
 224     printf "%7s %10s\n", 'xfer', $c;
 225     my $votes = $s->{Votes};
 226     votelog $_, "surplus transferred" foreach @$votes;
 227     @surpluses = grep { $_->{Cand} ne $c } @surpluses;
 228     push @unsorted, @$votes;
 229 }
 230
 231 print "done.\n";