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 for (;;) {
  77     $stage++;
  78
  79     while (my $vote = shift @unsorted) {
  80         my ($firstpref) = grep { $continuing{$_} } @{ $vote->{Prefs} };
  81         if (!defined $firstpref) {
  82             votelog $vote, "ballot exhausted";
  83             push @exhausted, $vote;
  84         } else {
  85             push @{ $sorted{$firstpref}{Votes} }, $vote;
  86         }
  87     }
  88     $sorted{$_}{Cand} = $_ foreach keys %sorted;
  89     foreach my $firstpref (sort keys %sorted) {
  90         foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
  91             votelog $vote, "counted $vote->{Weight} for $firstpref";
  92             $sorted{$firstpref}{Total} += $vote->{Weight};
  93         }
  94     }
  95     my @sorted = nsort_by { -$_->{Total} } values %sorted;
  96
  97     push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted };
  98
  99     my $totalvalid = 0;
 100     my $countvalid = sub {
 101         my ($l, $what) = @_;
 102         foreach my $s (@$l) {
 103             printf "%-7s %10s %s\n", $what, $s->{Cand}, pr $s->{Total};
 104             $totalvalid += $s->{Total};
 105         }
 106     };
 107     $countvalid->(\@sorted,    '1stpref');
 108     $countvalid->(\@surpluses, 'surplus');
 109
 110     printf "%7s %10s %s\n", 'TOTAL', '', pr $totalvalid;
 111
 112     unless ($totalvalid > 0) {
 113         printf "No more votes!\n";
 114         last;
 115     }
 116
 117     my $placesremain = $places - @elected;
 118
 119     unless ($placesremain > 0) {
 120         printf "Complete.\n";
 121         last;
 122     }
 123
 124     my $quota = $totalvalid / ($placesremain + 1);
 125     printf "%7s %10s %s\n", '', 'quota', pr $quota;
 126
 127     my $need_to_transfer_surplus = 1;
 128
 129     # Look for people to elect.
 130     # We elect as many as we can, rather than recomputing the (lower) quota
 131     # (ERS rules 5.4.9)
 132     for (;;) {
 133         my $s = $sorted[0];
 134         my $topvoters = $s->{Weight};
 135         my $surplus = $topvoters - $quota;
 136         last unless $surplus > 0;
 137
 138         printf "%7s %10s\n", 'ELECTED', $s->{Cand};
 139         push @elected, $s->{Cand};
 140
 141         my $derate = $topvoters / $surplus;
 142         printf "%7s %10s\n", 'derate', $s->{Cand}, pr $derate;
 143
 144         foreach my $vote (@{ $s->{Votes} }) {
 145             votelog $vote, "elected $s->{Cand}, derated $weightmult";
 146             $vote->{Weight} /= $derate;
 147         }
 148         shift @sorted;
 149         push @surpluses, $s;
 150         delete %sorted->{ $s->{Cand} };
 151         delete $continuing{ $s->{Cand} };
 152
 153         $need_to_transfer_surplus = 0;
 154         # before actually transferring a surplus, we will consider
 155         # eliminating, and then reconsider with a lower quota
 156     }
 157
 158     # Look for people to eliminate
 159     # We eliminate before trying to transfer surpluses
 160     # ERS 5.2.5
 161
 162
 163         # transfer the surplus
 164         filterout $topfirst, "candidate was elected";
 165     } else {
 166         my $elim = $sorted{ $#sorted };
 167         printf "%10s eliminated\n", $elim;
 168         filterout $elim, "candidate was eliminated";
 169     }
 170 }