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 %tiebreak; # $tiebreak{ winningcand }{ losingcand } = 1
  24
  25 while (@ARGV && $ARGV[0] =~ m/[<>]/) {
  26     my ($losers, $winners) = ($? eq '<' ? ($`, $') : ($', $`));
  27     my @losers = sort split /\,/, $losers;
  28     my @winners = sort split /\,/, $winners;
  29     die "@losers @winners" if @losers>1 && @winners>1;
  30     my @all = sort @losers, @winners;
  31     my $record = sub {
  32         my ($how, $howers) = @_;
  33         return unless @$howers == 1;
  34         die "@all $how" if defined $tiebreak{$how}{"@all"};
  35         $tiebreak{$how}{"@all"} = $howers->[0];
  36     };
  37     $record->('winner', \@winners);
  38     $record->('loser',  \@losers);
  39     shift @ARGV;
  40 }
  41
  42 our $places = shift @ARGV;
  43 die unless $places eq ($places + 0);
  44
  45 open DEBUG, ">.stv.log" or die $!;
  46
  47 while (<>) {
  48     next if m/^\w+$/;
  49     m/^(\w+) ([A-Z]+)$/ or die "$_ ?";
  50     my $prefs = $2;
  51     my $vote = {
  52         Voter => $1,
  53         Weight => 1.0,
  54         Prefs => [ split //, $prefs ],
  55     };
  56     push @allvotes, $vote;
  57 }
  58
  59 sub pr ($) {
  60     my ($f) = @_;
  61     confess unless defined $f;
  62     return sprintf "%10.6f = %-10s", $f, $f;
  63 }
  64
  65 sub votelog ($$) {
  66     my ($vote,$m) = @_;
  67     push @{ $vote->{Log} }, "stage $stage: $m";
  68 }
  69
  70 our @elected; # $elected[] = $candidate
  71
  72 our @unsorted = @allvotes;
  73
  74 our %sorted;
  75 # $sorted{$firstpref}{Votes} = [ $vote, ... ]
  76 # $sorted{$firstpref}{Cand} = $firstpref
  77 # $sorted{$firstpref}{Total} = $totalweight
  78 our @surpluses; # values same as %sorted
  79
  80 our @exhausted; # votes
  81
  82 our %continuing; # $continuing{$candidate}=1
  83
  84 our @stagerecord; # $stagerecord[]{$candidate} = $total
  85
  86 sub voteliveprefs ($) {
  87     my ($vote) = @_;
  88     grep { $continuing{$_} } @{ $vote->{Prefs} };
  89 }
  90
  91 sub votelogfull ($$) {
  92     my ($vote,$m) = @_;
  93     votelog $vote, $m;
  94     votelog $vote, ("continuing prefs: ". join ' ', voteliveprefs $vote);
  95 }
  96
  97 foreach my $vote (@allvotes) {
  98     $continuing{$_}=1 foreach @{ $vote->{Prefs} };
  99 }
 100
 101 sub equalpiles ($@) {
 102     my ($how, @sorted) = @_;
 103     return () unless @sorted;
 104     my $s = $sorted[0];
 105     my $eqtotal = $s->{Total};
 106     my $count = 0/1;
 107     while ($count < @sorted && $sorted[$count]{Total} == $eqtotal) {
 108         printf "%7s %10s %s\n", $how, $sorted[$count]{Cand},
 109             pr $sorted[$count]{Total};
 110         $count++;
 111     }
 112     return @sorted[ 0 .. $count-1 ];
 113 }
 114
 115 sub historically_prefer ($@) {
 116     my ($signum, @choices) = @_;
 117     # $signum==+1 means choose candidates with more early preferences
 118
 119     return $choices[0] if @choices < 2;
 120
 121     my $compare = sub {
 122         foreach my $sr (@stagerecord) {
 123             my $d = ($sr->{ $a->{Cand} }//0) <=> ($sr->{ $b->{Cand} }//0);
 124             return -$d * $signum if $d;
 125         }
 126         return 0;
 127     };
 128
 129     @choices = sort $compare @choices;
 130
 131     print DEBUG "historically_prefer\n",
 132         Data::Dumper->Dump([\@choices, \@stagerecord],
 133                            [qw(_@choices _@stagerecord)]);
 134
 135     foreach my $s (@choices) {
 136         my $c = $s->{Cand};
 137         printf " %6s %10s |", 'tiebrk', $c;
 138         foreach my $sr (@stagerecord) {
 139             my $p = pr($sr->{$c} // 0);
 140             $p =~ s/\.0+\b//g;
 141             $p =~ s/ //g;
 142             print "$p|";
 143         }
 144         print "\n";
 145     }
 146
 147     $a = $choices[0];
 148     my $numequal = 1;
 149     for (;;) {
 150         last if $numequal >= @choices;
 151         $b = $choices[$numequal];
 152         last if $compare->();
 153         $numequal++;
 154     }
 155
 156     if ($numequal > 1) {
 157         my $how = $signum > 0 ? 'winner' : 'loser';
 158         my @all = sort map { $_->{Cand} } @choices[ 0 .. $numequal-1 ];
 159         my $hower = $tiebreak{$how}{"@all"};
 160         if (defined $hower) {
 161             printf "%7.7s %10s !!!!!!!!!!\n", "TIE".(uc $how), $hower;
 162             return grep { $_->{Cand} eq $hower } @choices;
 163         }
 164         die "need tie break for $how between @all\n";
 165     }
 166
 167     return $choices[0];
 168 }
 169
 170 foreach my $c (keys %continuing) {
 171     $sorted{$c} = {
 172         Cand => $c,
 173         Votes => [],
 174     };
 175 }
 176
 177 for (;;) {
 178     $stage++;
 179
 180     printf "----- stage %d -----\n", $stage;
 181
 182     print DEBUG "#################### $stage ####################\n",
 183         Data::Dumper->Dump(
 184 [ \@stagerecord, \@elected, \@unsorted, \%sorted, \@surpluses, \%continuing ],
 185 [qw( _@stagerecord _@elected _@unsorted _%sorted _@surpluses _%continuing )]
 186            );
 187
 188     my $placesremain = $places - @elected;
 189
 190     unless ($placesremain > 0) {
 191         printf "Complete: @elected\n";
 192         last;
 193     }
 194
 195     while (my $vote = shift @unsorted) {
 196         my ($firstpref) = voteliveprefs $vote;
 197         if (!defined $firstpref) {
 198             votelog $vote, "ballot exhausted";
 199             push @exhausted, $vote;
 200         } else {
 201             push @{ $sorted{$firstpref}{Votes} }, $vote;
 202         }
 203     }
 204     foreach my $firstpref (sort keys %sorted) {
 205         foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
 206             votelog $vote, "counted for $firstpref ".pr $vote->{Weight};
 207         }
 208     }
 209     my @sorted;
 210     my $things_update = sub {
 211         foreach my $s (values %sorted) {
 212             $s->{Total} = sum0 map { $_->{Weight} } @{ $s->{Votes } };
 213         }
 214         @sorted = nsort_by { -$_->{Total} } values %sorted;
 215     };
 216     $things_update->();
 217
 218     print DEBUG "SORTED\n", Dumper(\@sorted);
 219
 220     push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted };
 221
 222     my $totalvalid = 0/1;
 223     my $countvalid = sub {
 224         my ($l, $what) = @_;
 225         foreach my $s (@$l) {
 226             printf "%-7s %10s %s\n", $what, $s->{Cand}, pr $s->{Total};
 227             $totalvalid += $s->{Total};
 228         }
 229     };
 230     $countvalid->(\@sorted,    '1stpref');
 231     $countvalid->(\@surpluses, 'surplus');
 232
 233     printf "%7s %10s %s\n", 'TOTAL', '-----', pr $totalvalid;
 234
 235     unless ($totalvalid > 0) {
 236         printf "No more votes!\n";
 237         last;
 238     }
 239
 240     my $quota = $totalvalid / ($placesremain + 1);
 241     printf "%7s %10s %s\n", 'quota', '', pr $quota;
 242
 243     my $need_to_transfer_surplus = 1;
 244
 245     my @newsurpluses;
 246
 247     # Look for people to elect.
 248     # We elect as many as we can, rather than recomputing the (lower) quota
 249     # (ERS rules 5.4.9)
 250     for (;;) {
 251         my $s = $sorted[0];
 252         my $topvoters = $s->{Total};
 253         my $surplus = $topvoters - $quota;
 254         last unless $surplus >= 0;
 255         last unless $placesremain;
 256
 257         my @elect = equalpiles 'elect?', @sorted;
 258
 259         if (@elect > $placesremain) {
 260             # oh my god
 261             @elect = historically_prefer +1, @elect;
 262             printf "%7s %10s\n", 'tie!', $elect[0]{Cand};
 263         }
 264
 265         foreach $s (@elect) {
 266             printf "%7s %10s ***************\n", 'ELECTED', $s->{Cand};
 267             push @elected, $s->{Cand};
 268
 269             foreach my $vote (@{ $s->{Votes} }) {
 270                 votelog $vote, "elected $s->{Cand}";
 271             }
 272
 273             $s->{Surplus} = $surplus;
 274             push @newsurpluses, $s;
 275             delete $sorted{ $s->{Cand} };
 276             delete $continuing{ $s->{Cand} };
 277             $placesremain--;
 278         }
 279
 280         $things_update->();
 281     }
 282
 283     foreach my $s (@newsurpluses) {
 284         # calculate the transfer value of each surplus
 285         # we do this simultaneously, but based on the number of
 286         # continuing candidates (excluding all the ones elected already)
 287         # ERS rule 5.3.3
 288
 289         my $votes = $s->{Votes};
 290         my $surplus = $s->{Surplus};
 291         my $transferrable =
 292             sum0
 293             map { $_->{Weight} }
 294             grep { !!voteliveprefs $_ }
 295             @$votes;
 296
 297         my $derate = 1/1;
 298         printf "%7s %10s %s\n", 'xfrable', $s->{Cand}, pr $transferrable;
 299         if ($transferrable > $surplus) {
 300             $derate = $transferrable / $surplus;
 301             printf "%7s %10s %s\n", 'derate', $s->{Cand}, pr $derate;
 302             foreach my $vote (@{ $s->{Votes} }) {
 303                 votelog $vote, "part of surplus, derated ". pr $derate;
 304                 $vote->{Weight} /= $derate;
 305             }
 306         }
 307         $s->{Total} = $transferrable / $derate;
 308
 309         push @surpluses, $s;
 310
 311         $things_update->();
 312         printf "%7s %10s %s\n", 'surplus', $s->{Cand}, pr $s->{Total};
 313
 314         $need_to_transfer_surplus = 0;
 315         # before actually transferring a surplus, we will consider
 316         # eliminating, and then reconsider with a lower quota
 317     }
 318
 319     my $deferredsurplus = sum0 map { $_->{Total} } @surpluses;
 320     printf "%18s %s\n", 'deferred surplus', pr $deferredsurplus;
 321
 322     # Look for people to eliminate
 323     # We eliminate before trying to transfer surpluses
 324     # ERS 5.2.5
 325     my $elimvotebefore = 0/1;
 326     for (;;) {
 327         last unless @sorted;
 328
 329         if ($elimvotebefore) {
 330             printf "%18s %s\n", 'elimination, sofar', pr $elimvotebefore;
 331         } elsif (@surpluses) {
 332             printf "%18s\n", 'elimination, maybe';
 333         } else {
 334             printf "%18s\n", 'elimination, starts';
 335         }
 336
 337         my @elim = equalpiles 'elim?', reverse @sorted;
 338         my $elimvotenow = sum0 map { $_->{Total} } @elim;
 339
 340         if (@surpluses || $elimvotebefore) {
 341             # rule 5.2.2
 342             if (@sorted == @elim) {
 343                 printf "%18s\n", 'no-elim (all-equal)';
 344                 last;
 345             }
 346             my $nextup = $sorted[ $#sorted - @elim ];
 347             printf "%7s %10s %s\n", 'nextup', $nextup->{Cand},
 348                 pr $nextup->{Total};
 349             my $aheadby = $nextup->{Total} - ($elimvotenow + $elimvotebefore);
 350             unless ($deferredsurplus <= $aheadby) {
 351                 # rule 5.2.2 (b)
 352                 printf "%18s %s\n", 'no-elim (nextup)', pr $aheadby;
 353                 last;
 354             }
 355         }
 356
 357         my $elim_tie =
 358             @elim > 1 &&
 359             (scalar keys %continuing) - (scalar @elim) < $placesremain;
 360         if ($elim_tie) {
 361             # eliminate only one then, and try again
 362             printf "elim-tie!\n";
 363             @elim = historically_prefer -1, @elim;
 364         }
 365
 366         foreach my $s (@elim) {
 367             my $c = $s->{Cand};
 368             printf "%7s %10s %s\n", 'ELIM', $c, '----------';
 369             my $votes = $s->{Votes};
 370             votelogfull $_, "failed to stop $c elimination" foreach @$votes;
 371             $elimvotebefore += $s->{Total};
 372             delete $continuing{$c};
 373             delete $sorted{$c};
 374             push @unsorted, @$votes;
 375         }
 376
 377         $things_update->();
 378         $need_to_transfer_surplus = 0;
 379         last if $elim_tie; # no more, then!
 380     }
 381
 382     next unless $need_to_transfer_surplus;
 383
 384     @surpluses = nsort_by { $_->{Total} } @surpluses;
 385     my @surplusxfer = equalpiles 'xfer?', @surpluses;
 386     die unless @surplusxfer;
 387
 388     if (@surplusxfer > 1) {
 389         @surplusxfer = historically_prefer +1, @surplusxfer;
 390     }
 391
 392     my $s = $surplusxfer[0];
 393     my $c = $s->{Cand};
 394     printf "%7s %10s\n", 'xfer', $c;
 395     my $votes = $s->{Votes};
 396     votelogfull $_, "surplus transferred" foreach @$votes;
 397     @surpluses = grep { $_->{Cand} ne $c } @surpluses;
 398     push @unsorted, @$votes;
 399 }
 400
 401 print "done.\n";