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 foreach my $c (keys %continuing) {
 122     $sorted{$c} = {
 123         Cand => $c,
 124         Votes => [],
 125     };
 126 }
 127
 128 for (;;) {
 129     $stage++;
 130
 131     printf "----- stage %d -----\n", $stage;
 132
 133     print DEBUG "#################### $stage ####################\n",
 134         Data::Dumper->Dump(
 135 [ \@stagerecord, \@elected, \@unsorted, \%sorted, \@surpluses, \%continuing ],
 136 [qw( _@stagerecord _@elected _@unsorted _%sorted _@surpluses _%continuing )]
 137            );
 138
 139     my $placesremain = $places - @elected;
 140
 141     unless ($placesremain > 0) {
 142         printf "Complete.\n";
 143         last;
 144     }
 145
 146     while (my $vote = shift @unsorted) {
 147         my ($firstpref) = grep { $continuing{$_} } @{ $vote->{Prefs} };
 148         if (!defined $firstpref) {
 149             votelog $vote, "ballot exhausted";
 150             push @exhausted, $vote;
 151         } else {
 152             push @{ $sorted{$firstpref}{Votes} }, $vote;
 153         }
 154     }
 155     foreach my $firstpref (sort keys %sorted) {
 156         foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
 157             votelog $vote, "counted $vote->{Weight} for $firstpref";
 158         }
 159     }
 160     my @sorted;
 161     my $things_update = sub {
 162         foreach my $s (@surpluses, values %sorted) {
 163             $s->{Total} = sum0 map { $_->{Weight} } @{ $s->{Votes } };
 164         }
 165         @sorted = nsort_by { -$_->{Total} } values %sorted;
 166     };
 167     $things_update->();
 168
 169     print DEBUG "SORTED\n", Dumper(\@sorted);
 170
 171     push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted };
 172
 173     my $totalvalid = 0;
 174     my $countvalid = sub {
 175         my ($l, $what) = @_;
 176         foreach my $s (@$l) {
 177             printf "%-7s %10s %s\n", $what, $s->{Cand}, pr $s->{Total};
 178             $totalvalid += $s->{Total};
 179         }
 180     };
 181     $countvalid->(\@sorted,    '1stpref');
 182     $countvalid->(\@surpluses, 'surplus');
 183
 184     printf "%7s %10s %s\n", 'TOTAL', '-----', pr $totalvalid;
 185
 186     unless ($totalvalid > 0) {
 187         printf "No more votes!\n";
 188         last;
 189     }
 190
 191     my $quota = $totalvalid / ($placesremain + 1);
 192     printf "%7s %10s %s\n", 'quota', '', pr $quota;
 193
 194     my $need_to_transfer_surplus = 1;
 195
 196     # Look for people to elect.
 197     # We elect as many as we can, rather than recomputing the (lower) quota
 198     # (ERS rules 5.4.9)
 199     for (;;) {
 200         my $s = $sorted[0];
 201         my $topvoters = $s->{Total};
 202         my $surplus = $topvoters - $quota;
 203         last unless $surplus > 0;
 204
 205         printf "%7s %10s ***************\n", 'ELECTED', $s->{Cand};
 206         push @elected, $s->{Cand};
 207
 208         my $derate = $topvoters / $surplus;
 209         printf "%7s %10s %s\n", 'derate', $s->{Cand}, pr $derate;
 210
 211         foreach my $vote (@{ $s->{Votes} }) {
 212             votelog $vote, "elected $s->{Cand}, derated $derate";
 213             $vote->{Weight} /= $derate;
 214         }
 215         push @surpluses, $s;
 216         delete $sorted{ $s->{Cand} };
 217         delete $continuing{ $s->{Cand} };
 218
 219         $things_update->();
 220         printf "%7s %10s %s\n", 'surplus', $s->{Cand}, pr $s->{Total};
 221
 222         $need_to_transfer_surplus = 0;
 223         # before actually transferring a surplus, we will consider
 224         # eliminating, and then reconsider with a lower quota
 225     }
 226
 227     my $deferredsurplus = sum0 map { $_->{Total} } @surpluses;
 228     printf "%18s %s\n", 'deferred surplus', pr $deferredsurplus;
 229
 230     # Look for people to eliminate
 231     # We eliminate before trying to transfer surpluses
 232     # ERS 5.2.5
 233     my $elimvotebefore = 0;
 234     for (;;) {
 235         last unless @sorted;
 236
 237         if ($elimvotebefore) {
 238             printf "%18s %s\n", 'elimination, sofar', pr $elimvotebefore;
 239         } elsif (@surpluses) {
 240             printf "%18s\n", 'elimination, maybe';
 241         } else {
 242             printf "%18s\n", 'elimination, starts';
 243         }
 244
 245         my @elim = equalpiles 'elim?', reverse @sorted;
 246         my $elimvotenow = sum0 map { $_->{Total} } @elim;
 247
 248         if (@surpluses || $elimvotebefore) {
 249             # rule 5.2.2
 250             if (@sorted == @elim) {
 251                 printf "%18s\n", 'no-elim (all-equal)';
 252                 last;
 253             }
 254             my $nextup = $sorted[ $#sorted - @elim ];
 255             printf "%7s %10s %s\n", 'nextup', $nextup->{Cand},
 256                 pr $nextup->{Total};
 257             my $aheadby = $nextup->{Total} - ($elimvotenow + $elimvotebefore);
 258             unless ($deferredsurplus <= $aheadby) {
 259                 # rule 5.2.2 (b)
 260                 printf "%18s %s\n", 'no-elim (nextup)', pr $aheadby;
 261                 last;
 262             }
 263         }
 264
 265         my $elim_tie =
 266             @elim > 1 &&
 267             (scalar keys %continuing) - (scalar @elim) < $placesremain;
 268         if ($elim_tie) {
 269             # eliminate only one then, and try again
 270             printf "elim-tie!\n";
 271             @elim = historically_prefer -1, @elim;
 272         }
 273
 274         foreach my $s (@elim) {
 275             my $c = $s->{Cand};
 276             printf "%7s %10s %s\n", 'ELIM', $c, '----------';
 277             my $votes = $s->{Votes};
 278             votelog $_, "failed to stop $c elimination" foreach @$votes;
 279             $elimvotebefore += $s->{Total};
 280             delete $continuing{$c};
 281             delete $sorted{$c};
 282             push @unsorted, @$votes;
 283         }
 284
 285         $things_update->();
 286         $need_to_transfer_surplus = 0;
 287         last if $elim_tie; # no more, then!
 288     }
 289
 290     next unless $need_to_transfer_surplus;
 291
 292     @surpluses = nsort_by { $_->{Total} } @surpluses;
 293     my @surplusxfer = equalpiles 'xfer?', @surpluses;
 294     die unless @surplusxfer;
 295
 296     if (@surplusxfer > 1) {
 297         @surplusxfer = historically_prefer +1, @surplusxfer;
 298     }
 299
 300     my $s = $surplusxfer[0];
 301     my $c = $s->{Cand};
 302     printf "%7s %10s\n", 'xfer', $c;
 303     my $votes = $s->{Votes};
 304     votelog $_, "surplus transferred" foreach @$votes;
 305     @surpluses = grep { $_->{Cand} ne $c } @surpluses;
 306     push @unsorted, @$votes;
 307 }
 308
 309 print "done.\n";