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 Carp;
  11 use Data::Dumper;
  12 use List::Util qw(sum0);
  13 use List::MoreUtils qw(nsort_by);
  14
  15 # vote is
  16 #  { Voter => opaque,
  17 #    Prefs => [ list ],
  18 #    Weight => 1.0 }
  19
  20 our $stage=0;
  21 our @allvotes;
  22
  23 our $places = shift @ARGV;
  24 die unless $places eq ($places + 0);
  25
  26 open DEBUG, ">.stv.log" or die $!;
  27
  28 while (<>) {
  29     next if m/^\w+$/;
  30     m/^(\w+) ([A-Z]+)$/ or die "$_ ?";
  31     my $prefs = $2;
  32     my $vote = {
  33         Voter => $1,
  34         Weight => 1.0,
  35         Prefs => [ split //, $prefs ],
  36     };
  37     push @allvotes, $vote;
  38 }
  39
  40 sub pr ($) {
  41     my ($f) = @_;
  42     confess unless defined $f;
  43     return sprintf "%10.6f = %-10s", $f, $f;
  44 }
  45
  46 sub votelog ($$) {
  47     my ($vote,$m) = @_;
  48     push @{ $vote->{Log} }, "stage $stage: $m";
  49 }
  50
  51 sub filterout ($$) {
  52     my ($cand, $why) = @_;
  53     foreach my $vote (@allvotes) {
  54         my $oldprefs = $vote->{Prefs};
  55         my @prefs = grep { $_ ne $cand } $oldprefs;
  56         next if @prefs == @$oldprefs;
  57         votelog $vote, "crossed out candidate $cand: $why";
  58     }
  59 }
  60
  61 our @elected; # $elected[] = $candidate
  62
  63 our @unsorted = @allvotes;
  64
  65 our %sorted;
  66 # $sorted{$firstpref}{Votes} = [ $vote, ... ]
  67 # $sorted{$firstpref}{Cand} = $firstpref
  68 # $sorted{$firstpref}{Total} = $totalweight
  69 our @surpluses; # values same as %sorted
  70
  71 our @exhausted; # votes
  72
  73 our %continuing; # $continuing{$candidate}=1
  74
  75 our @stagerecord; # $stagerecord[]{$candidate} = $total
  76
  77 foreach my $vote (@allvotes) {
  78     $continuing{$_}=1 foreach @{ $vote->{Prefs} };
  79 }
  80
  81 sub equalpiles ($@) {
  82     my ($how, @sorted) = @_;
  83     return () unless @sorted;
  84     my $s = $sorted[0];
  85     my $eqtotal = $s->{Total};
  86     my $count = 0;
  87     while ($count < @sorted && $sorted[$count]{Total} == $eqtotal) {
  88         printf "%7s %10s %s\n", $how, $sorted[$count]{Cand},
  89             pr $sorted[$count]{Total};
  90         $count++;
  91     }
  92     return @sorted[ 0 .. $count-1 ];
  93 }
  94
  95 sub historically_prefer ($@) {
  96     my ($signum, @choices) = @_;
  97
  98     return $choices[0] if @choices < 2;
  99
 100     my $compare = sub {
 101         foreach my $sr (@stagerecord) {
 102             my $d = $sr->{ $a->{Cand} } <=> $sr->{ $b->{Cand} };
 103             return $d * $signum if $d;
 104         }
 105         return 0;
 106     };
 107
 108     @choices = sort $compare, @choices;
 109     $a = $choices[0];
 110     my $numequal = 0;
 111     for (;;) {
 112         last unless $numequal >= @choices;
 113         $b = $choices[$numequal];
 114         last if $compare->();
 115     }
 116
 117     die 'random choice unimplemented' if $numequal > 1;
 118     return $choices[0];
 119 }
 120
 121 for (;;) {
 122     $stage++;
 123
 124     printf "----- stage %d -----\n", $stage;
 125
 126     print DEBUG "#################### $stage ####################\n",
 127         Data::Dumper->Dump(
 128 [ \@stagerecord, \@elected, \@unsorted, \%sorted, \@surpluses, \%continuing ],
 129 [qw( _@stagerecord _@elected _@unsorted _%sorted _@surpluses _%continuing )]
 130            );
 131
 132     while (my $vote = shift @unsorted) {
 133         my ($firstpref) = grep { $continuing{$_} } @{ $vote->{Prefs} };
 134         if (!defined $firstpref) {
 135             votelog $vote, "ballot exhausted";
 136             push @exhausted, $vote;
 137         } else {
 138             push @{ $sorted{$firstpref}{Votes} }, $vote;
 139         }
 140     }
 141     $sorted{$_}{Cand} = $_ foreach keys %sorted;
 142     foreach my $firstpref (sort keys %sorted) {
 143         $sorted{$firstpref}{Total} = 0; # recount
 144         foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
 145             votelog $vote, "counted $vote->{Weight} for $firstpref";
 146             $sorted{$firstpref}{Total} += $vote->{Weight};
 147         }
 148     }
 149     my @sorted;
 150     my $sort_update = sub {
 151         @sorted = nsort_by { -$_->{Total} } values %sorted;
 152     };
 153     $sort_update->();
 154
 155     print DEBUG "SORTED\n", Dumper(\@sorted);
 156
 157     push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted };
 158
 159     my $totalvalid = 0;
 160     my $countvalid = sub {
 161         my ($l, $what) = @_;
 162         foreach my $s (@$l) {
 163             printf "%-7s %10s %s\n", $what, $s->{Cand}, pr $s->{Total};
 164             $totalvalid += $s->{Total};
 165         }
 166     };
 167     $countvalid->(\@sorted,    '1stpref');
 168     $countvalid->(\@surpluses, 'surplus');
 169
 170     printf "%7s %10s %s\n", 'TOTAL', '-----', pr $totalvalid;
 171
 172     unless ($totalvalid > 0) {
 173         printf "No more votes!\n";
 174         last;
 175     }
 176
 177     my $placesremain = $places - @elected;
 178
 179     unless ($placesremain > 0) {
 180         printf "Complete.\n";
 181         last;
 182     }
 183
 184     my $quota = $totalvalid / ($placesremain + 1);
 185     printf "%7s %10s %s\n", 'quota', '', pr $quota;
 186
 187     my $need_to_transfer_surplus = 1;
 188
 189     # Look for people to elect.
 190     # We elect as many as we can, rather than recomputing the (lower) quota
 191     # (ERS rules 5.4.9)
 192     for (;;) {
 193         my $s = $sorted[0];
 194         my $topvoters = $s->{Total};
 195         my $surplus = $topvoters - $quota;
 196         last unless $surplus > 0;
 197
 198         printf "%7s %10s ***************\n", 'ELECTED', $s->{Cand};
 199         push @elected, $s->{Cand};
 200
 201         my $derate = $topvoters / $surplus;
 202         printf "%7s %10s %s\n", 'derate', $s->{Cand}, pr $derate;
 203
 204         foreach my $vote (@{ $s->{Votes} }) {
 205             votelog $vote, "elected $s->{Cand}, derated $derate";
 206             $vote->{Weight} /= $derate;
 207         }
 208         push @surpluses, $s;
 209         delete $sorted{ $s->{Cand} };
 210         delete $continuing{ $s->{Cand} };
 211
 212         $sort_update->();
 213         $need_to_transfer_surplus = 0;
 214         # before actually transferring a surplus, we will consider
 215         # eliminating, and then reconsider with a lower quota
 216     }
 217
 218     my $deferredsurplus = sum0 map { $_->{Total} } @surpluses;
 219     printf "%18s %s\n", 'deferred surplus', pr $deferredsurplus;
 220
 221     # Look for people to eliminate
 222     # We eliminate before trying to transfer surpluses
 223     # ERS 5.2.5
 224     for (;;) {
 225         last unless @sorted;
 226
 227         printf "%18s\n", 'elimination round';
 228
 229         my @elim = equalpiles 'elim?', reverse @sorted;
 230         my $elimvotetotal = sum0 map { $_->{Total} } @elim;
 231
 232         if (@surpluses) {
 233             if (@sorted == @elim) {
 234                 printf "%18s\n", 'no-elim, un-defer, (all-equal)';
 235                 last;
 236             }
 237             my $nextup = $sorted[ $#sorted - @elim ];
 238             printf "%7s %10s %s\n", 'nextup', $nextup->{Cand},
 239                 pr $nextup->{Total};
 240             my $aheadby = $nextup->{Total} - $elimvotetotal;
 241             unless ($deferredsurplus <= $aheadby) {
 242                 # rule 5.2.2 (b)
 243                 printf "%18s %s\n", 'no-elim, un-defer', pr $aheadby;
 244                 last;
 245             }
 246         }
 247
 248         if ((scalar keys %continuing) - (scalar @elim) < $placesremain) {
 249             # eliminate only one then, and try again
 250             printf "elim-tie!\n";
 251             @elim = historically_prefer -1, @elim;
 252         }
 253
 254         foreach my $s (@elim) {
 255             my $c = $s->{Cand};
 256             printf "%7s %10s %s\n", 'ELIM', $c, '----------';
 257             my $votes = $s->{Votes};
 258             votelog $_, "failed to stop $c elimination" foreach @$votes;
 259             delete $continuing{$c};
 260             delete $sorted{$c};
 261             push @unsorted, @$votes;
 262         }
 263
 264         $sort_update->();
 265         $need_to_transfer_surplus = 0;
 266     }
 267
 268     next unless $need_to_transfer_surplus;
 269
 270     @surpluses = nsort_by { $_->{Total} } @surpluses;
 271     my @surplusxfer = equalpiles 'xfer?', @surpluses;
 272     die unless @surplusxfer;
 273
 274     if (@surplusxfer > 1) {
 275         @surplusxfer = historically_prefer +1, @surplusxfer;
 276     }
 277
 278     my $s = $surplusxfer[0];
 279     my $c = $s->{Cand};
 280     printf "%7s %10s\n", 'xfer', $c;
 281     my $votes = $s->{Votes};
 282     votelog $_, "surplus transferred" foreach @$votes;
 283     @surpluses = grep { $_->{Cand} ne $c } @surpluses;
 284     push @unsorted, @$votes;
 285 }
 286
 287 print "done.\n";