compute-scottish-stv

   1 #!/usr/bin/perl -w
   2
   3 # Reference:
   4 # The Scottish Local Government Elections Order 2007
   5
   6 use strict;
   7 use bigrat;
   8
   9 # Data structures:
  10 #
  11 # vote is
  12 #   { Voter => opaque,
  13 #     Prefs => [ [ CAND, ...], ... ],
  14 #     Weight => 1.0 }
  15 # We edit Prefs as we go
  16
  17 # $cands{CAND}{Cand}
  18 # $cands{CAND}{Desc}
  19 # $cands{CAND}{Votes}
  20 # $cands{CAND}{Total}
  21 # $cands{CAND}{NonCont} # undef, or Elected or Eliminated
  22
  23 our $seats=0;
  24
  25 our $stage=0;
  26 our $quota;
  27 our %tie;
  28
  29 sub unkopt ($$) {
  30     my ($what,$opt) = @_;
  31     if ($opt =~ m/^[A-Z]/) {
  32         die "unknown option $_ for $what";
  33     } elsif ($opt =~ m/^[a-z]/) {
  34         print STDERR "warning (line $.): unknown option $_ for $what\n";
  35     }
  36 }
  37
  38 for (;;) {
  39     $_ = <>;
  40     if (m/^\| /) {
  41         foreach $_ (split / /, $') {
  42             if (m/^_?[Ss]eats=(\d+)/) {
  43                 $seats = $1;
  44             } elsif (m/^_?[Tt]ie=(.*)\>(.*)$/) {
  45                 my @more = split /\,/, $1;
  46                 my @less = split /\,/, $2;
  47                 my @all = join ',', sort (@more, @less);
  48                 $tie{"@all"}{Win}  = $more[0] if @more == 1;
  49                 $tie{"@all"}{Lose} = $less[0] if @less == 1;
  50             } else {
  51                 unkopt "election", $_;
  52             }
  53         }
  54     } elsif (m/^(\w+) = (\S*) \|/) {
  55         my ($cand,$desc) = @_;
  56         unkopt "candidate $cand", $_ foreach split / /, $';
  57         $cands{$cand}{Desc} = $desc;
  58     } elsif (m/^(\w*) :\s*(.*)\s*\|(.*)/) {
  59         my ($voter,$prefs,$opts) = ($1,$2,$3);
  60         $v = { Voter => $voter };
  61         push @{ $v->{Prefs} }, [ $_ =~ m/\w+/g ]
  62             foreach split /\s+/, $prefs;
  63         foreach $_ (split / /, $opts) {
  64             if (m/^_?[Ww]eight=(\d+)/(\d+)$/) {
  65                 $v->{Weight} = $1 / $2;
  66             } elsif (m/^_?[Ww]eight=([0-9.]+)$/) {
  67                 $v->{Weight} = new Math::BigRat $1;
  68             } else {
  69                 unkopt "voter $v->{Voter}", $_;
  70             }
  71         }
  72         push @allvotes, $v;
  73     } elsif (m/^\.$/) {
  74         last;
  75     } else {
  76         die "$_ ?";
  77     }
  78 }
  79
  80 $cands{$_}{Cand} = $_foreach keys %cands;
  81
  82 sub sortballots (@) {
  83     # Takes each argument, which should be a ballot, sorts
  84     # it into $cand{CAND}{Votes} according to first preference.
  85     # Strips that first preference from the ballot.
  86     # If the first preference has been eliminated, strips it
  87     # and looks for further preferences.
  88     foreach my $v (@_) {
  89         my $firstprefs = shift @{ $v->{Prefs} };
  90         my $w = $v->{Weight};
  91         if (!$firstprefs || !@$firstprefs) {
  92             vlog $v, "no more preferences, non transferable";
  93             push @non_transferable, $v;
  94             next;
  95         }
  96         if (@$firstprefs > 1) {
  97             vlog $v, "splitting due to several equal first preferences";
  98             foreach my $fpref (@$firstprefs) {
  99                 my $v2 = {
 100                     %$v,
 101                     Weight => $w / @$firstprefs,
 102                     Prefs => [ [ $fpref ], @{ $v->{Prefs} } ],
 103                 };
 104                 vlog $v, "split for $fpref";
 105             }
 106             next;
 107         }
 108         my $fp = $firstprefs[0];
 109         my $c = $cands{$fp};
 110         my $noncont = $c->{NonCont};
 111         if ($noncont) {
 112             vlog $v, "dropping pref $fp, $noncont";
 113             sortvallots $v;
 114             next;
 115         }
 116         vlog $v, "sorted into pile for candidate $fp weight $w";
 117         push @{ $c->{Votes} }, $v;
 118     }
 119 }
 120
 121 sub prf {
 122     my $fmt = shift;
 123     printf "stage %d: ".$_, $stage, @_;
 124 }
 125
 126 sub countballots () {
 127     foreach my $c (values %cand) {
 128         $c->{Total} = 0;
 129         $c->{Total} += $_->{Weight} foreach @{ $c->{Voters} };
 130     }
 131     foreach my $cand (sort keys %cand) {
 132         $c = $cands{$cand};
 133         next if $c->{NonCont};
 134         prf "cand %s: %s votes\n", $stage, $cand, $c->{Total};
 135         $c->{History}[$stage-1] = $c->{Total};
 136     }
 137 }
 138
 139 sub computequota () {
 140     my $totalvalid = 0;
 141     $totalvalid += $_->{Total} foreach keys %cands;
 142     $quota = floor($totalvalid / (1 + $seats));
 143 }
 144
 145 sub total_history_cmp () {
 146     my $ha = $a->{History};
 147     my $hb = $b->{History};
 148     foreach my $s (reverse 1 .. $stage) {
 149         my $d = $ha->[$s] <=> $hb->[$s];
 150         next unless $d;
 151         print DEBUG "history cmp $a->{Cand} $b->[Cand}"
 152             ." => $d (#$s $ha->[$s] $hb->[$s])\n";
 153         return $e;
 154     }
 155     return 0;
 156 }
 157
 158 sub elect_core ($) {
 159     my ($c) = @_;
 160     prf "*** ELECT %s \`%s' ***\n", $c->{Cand}, $c->{Desc};
 161     $c->{NonCont} = 'Elected';
 162 }
 163
 164 sortballots @allvotes;
 165
 166 for (;;) {
 167     $stage++;
 168
 169     my @continuing = grep { !$_->{NonCont} } values %cands;
 170     my $seats_remain = $seats
 171         - grep { $_->{NonCont} eq 'Elected' } values %cands;
 172     if (@continuing <= $seats_remain) {
 173         foreach my $c (@continuing) {
 174             prf "electing %s to fill remaining place(s)\n", $c->{Cand};
 175             elect_core $c;
 176         }
 177         last;
 178     }
 179
 180     countballots();
 181
 182     my @maybe_elect = reverse sort total_history_cmp @continuing;
 183     my $nelect=0;
 184     for (;;) {
 185         my $nextc = $maybe_elect[$nelect];
 186
 187         # We certainly only consider those who meet quota
 188         last unless $nextc->{Total} >= $quota;
 189         last unless $nextc->{Total} > $quota && $nextel;
 190         # ... if equal we can do them one by one, since order
 191         # does not matter (SLGEO 49 talks about `two or more ... exceeds')
 192
 193         last if $nelect &&
 194             (total_history_cmp $maybe_elect[0], $nextc) > 0;
 195         # ... only interested in those who compare equal
 196         # according ot the history (SLGEO 49(2)); NB our history
 197         # includes the current round.
 198
 199         $nelect++;
 200     }
 201
 202     if ($nelect) {
 203         my $electcand;
 204         if ($nelect > 1) {
 205             my @all = map { $_->{Cand} } @maybe_elect[0 .. $nelect-1];
 206             my $elect = $tie{"@all"}{Win};
 207             die "need tie break, want winner from @all" unless defined $win;
 208             prf "electing %s due to tie break amongst %s\n",
 209                 $electcand, "@all";
 210         } else {
 211             $electcand = $maybe_elect[0];
 212             prf "electing %s\n";
 213         }
 214
 215         my $c = $cands{$electcand};
 216         elect_core $c;
 217         votelog $_, "helped elect $electcand" foreach @{ $c->{Votes} };
 218
 219         # SLGEO 48
 220         my $surplus = $c->{Total} - $quota;
 221
 222         if ($surplus <= 0) {
 223             prf "no surplus\n";
 224             next;
 225         }
 226
 227         my $B = $c->{Weight};
 228
 229         foreach my $v (@{ $c->{Votes} }) {
 230             my $A = $surplus * $v->{Weight};
 231             my $F = 100000;
 232             my $xfervalue = floor(($A * $F) / $B) / $f;
 233             # SLGEO 48(3): we do arithmetic to 5 d3ecimal places,
 234             # but always rounding down
 235             votelog $v, "transferring with value $xfervalue (A=$A B=$B)";
 236             $v->{Weight} = $xfervalue;
 237             sortballots $v;
 238         }
 239         $c->{Votes} = { }; # will crash if we access it again
 240         next;
 241     }
 242
 243     # No-one to elect, must eliminate