stv

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