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 Carp;
   8 use Data::Dumper;
   9 use Math::BigRat;
  10 use bigrat;
  11
  12 # Data structures:
  13 #
  14 # vote is
  15 #   { Voter => opaque,
  16 #     Prefs => [ [ CAND, ...], ... ],
  17 #     Weight => 1.0 }
  18 # We edit Prefs as we go
  19
  20 # $cands{CAND}{Cand}
  21 # $cands{CAND}{Desc}
  22 # $cands{CAND}{Votes}
  23 # $cands{CAND}{Total}
  24 # $cands{CAND}{NonCont} # undef, or Elected or Eliminated
  25
  26 our $seats=0;
  27
  28 our @allvotes;
  29 our @non_transferable;
  30 our %cands;
  31 our $stage=0;
  32 our $quota;
  33 our %tie;
  34
  35 our $DIGS = 5;
  36 our $F = (new Math::BigRat 10)->bpow($DIGS);
  37
  38 open DEBUG, ">.compute.log" or die $!;
  39 DEBUG->autoflush(1);
  40
  41 sub debug_dump () {
  42     print DEBUG Dumper(\%tie,
  43                        \@non_transferable,
  44                        \%cands,
  45                        \@allvotes,
  46                        $stage, $quota);
  47 }
  48
  49 $SIG{__WARN__} = sub {
  50     $SIG{__DIE__} = undef;
  51     debug_dump;
  52     confess $_[0];
  53 };
  54
  55 $SIG{__DIE__} = sub {
  56     debug_dump;
  57     die $_[0];
  58 };
  59
  60 sub unkopt ($$) {
  61     my ($what,$opt) = @_;
  62     if ($opt =~ m/^[A-Z]/) {
  63         die "unknown option $_ for $what";
  64     } elsif ($opt =~ m/^[a-z]/) {
  65         print STDERR "warning (line $.): unknown option $_ for $what\n";
  66     }
  67 }
  68
  69 for (;;) {
  70     $_ = <>;
  71     if (m/^\| /) {
  72         foreach $_ (split / /, $') {
  73             if (m/^_?[Ss]eats=(\d+)/) {
  74                 $seats = $1;
  75             } elsif (m/^_?[Tt]ie=(.*)\>(.*)$/) {
  76                 my @more = split /\,/, $1;
  77                 my @less = split /\,/, $2;
  78                 my @all = join ',', sort (@more, @less);
  79                 $tie{"@all"}{Win}  = $more[0] if @more == 1;
  80                 $tie{"@all"}{Lose} = $less[0] if @less == 1;
  81             } else {
  82                 unkopt "election", $_;
  83             }
  84         }
  85     } elsif (m/^(\w+) = (\S*) \|/) {
  86         my ($cand,$desc) = ($1,$2);
  87         unkopt "candidate $cand", $_ foreach split / /, $';
  88         $cands{$cand}{Desc} = $desc;
  89     } elsif (m/^(\w*) :\s*(.*)\s*\|(.*)/) {
  90         my ($voter,$prefs,$opts) = ($1,$2,$3);
  91         my $v = { Voter => $voter, Prefs => [ ] };
  92         push @{ $v->{Prefs} }, [ $_ =~ m/\w+/g ]
  93             foreach split /\s+/, $prefs;
  94         foreach $_ (split / /, $opts) {
  95             if (m/^_?[Ww]eight=(\d+)\/(\d+)$/) {
  96                 $v->{Weight} = $1 / $2;
  97             } elsif (m/^_?[Ww]eight=([0-9.]+)$/) {
  98                 $v->{Weight} = new Math::BigRat $1;
  99             } else {
 100                 unkopt "voter $v->{Voter}", $_;
 101             }
 102         }
 103         push @allvotes, $v;
 104     } elsif (m/^\.$/) {
 105         last;
 106     } else {
 107         die "$_ ?";
 108     }
 109 }
 110
 111 $cands{$_}{Cand} = $_ foreach keys %cands;
 112 $_->{Weight} //= 1/1 foreach @allvotes;
 113 $_->{TransferredSurplus} //= [ ] foreach @allvotes;
 114 $_->{OrigPrefs} //= [ @{ $_->{Prefs} } ] foreach @allvotes;
 115
 116 sub votelog ($$) {
 117     my ($vote,$m) = @_;
 118     push @{ $vote->{Log} }, "stage $stage: $m";
 119 }
 120
 121 sub sortballots (@);
 122 sub sortballots (@) {
 123     # Takes each argument, which should be a ballot, sorts
 124     # it into $cand{CAND}{Votes} according to first preference.
 125     # Strips that first preference from the ballot.
 126     # If the first preference has been eliminated, strips it
 127     # and looks for further preferences.
 128     print DEBUG "sortballots ".(scalar @_)."...\n";
 129     foreach my $v (@_) {
 130         my $firstprefs = shift @{ $v->{Prefs} };
 131         my $w = $v->{Weight};
 132         if (!$firstprefs || !@$firstprefs) {
 133             votelog $v, "no more preferences, non transferable";
 134             push @non_transferable, $v;
 135             next;
 136         }
 137         if (@$firstprefs > 1) {
 138             votelog $v, "splitting due to several equal first preferences";
 139             foreach my $fpref (@$firstprefs) {
 140                 my $v2 = {
 141                     %$v,
 142                     Weight => $w / @$firstprefs,
 143                     Prefs => [ [ $fpref ], @{ $v->{Prefs} } ],
 144                 };
 145                 votelog $v, "split for $fpref";
 146             }
 147             next;
 148         }
 149         my $fp = $firstprefs->[0];
 150         my $c = $cands{$fp};
 151         my $noncont = $c->{NonCont};
 152         if ($noncont) {
 153             votelog $v, "dropping pref $fp, $noncont";
 154             sortballots $v;
 155             next;
 156         }
 157         votelog $v, "sorted into pile for candidate $fp weight $w";
 158         push @{ $c->{Votes} }, $v;
 159     }
 160 }
 161
 162 sub floor ($) {
 163     my ($v) = @_;
 164     $v = new Math::BigRat $v; # we need a copy
 165     return $v->bfloor();
 166 }
 167
 168 sub sv ($) {
 169     my ($in) = @_;
 170     my $v = new Math::BigRat $in; # just in case
 171     my $intpart = floor($v);
 172     my $frac = $v - $intpart;
 173     my $good = floor($frac * $F);
 174     my $bad = $frac * $F - $good;
 175     my $s = sprintf "%7d", $intpart;
 176     if ($frac) {
 177         $s .= sprintf ".%0${DIGS}d", $good;
 178         $s .= sprintf "%-4s", ($bad ? "+$bad" : "");
 179     } else {
 180         $s .= sprintf " %${DIGS}s%4s", '', '';
 181     }
 182 #print STDERR "# $in => $s # (intpart=$intpart frac=$frac)\n";
 183     return $s;
 184 }
 185
 186 sub prf {
 187     my $fmt = shift;
 188     printf "stage %d: ".$fmt, $stage, @_;
 189 }
 190
 191 sub countballots () {
 192     foreach my $c (values %cands) {
 193         next if $c->{NonCont};
 194         $c->{Total} = 0/1;
 195         $c->{Total} += $_->{Weight} foreach @{ $c->{Votes} };
 196         print DEBUG "counted $c->{Cand} $c->{Total}\n";
 197         $c->{History}[$stage-1] = $c->{Total};
 198     }
 199
 200     foreach my $c (reverse sort total_history_cmp
 201                    grep { !$_->{NonCont} } values %cands) {
 202         prf "candidate %-10s: %s votes\n", $c->{Cand}, sv $c->{Total};
 203     }
 204 }
 205
 206 sub computequota () {
 207     my $totalvalid = 0/1;
 208     $totalvalid += $_->{Total} foreach values %cands;
 209     $quota = floor($totalvalid / (1 + $seats));
 210     prf "quota %s\n", sv $quota;
 211 }
 212
 213 sub total_history_cmp () {
 214     my $ha = $a->{History};
 215     my $hb = $b->{History};
 216     my $m = "stage $stage history cmp $a->{Cand} $b->{Cand}";
 217     print DEBUG  "$m...\n";
 218     foreach my $s (reverse 0 .. $stage-1) {
 219         my $d = $ha->[$s] <=> $hb->[$s];
 220         next unless $d;
 221         print DEBUG "$m => $d (#$s $ha->[$s] $hb->[$s])\n";
 222         return $d;
 223     }
 224     print DEBUG "$m => 0\n";
 225     return 0;
 226 }
 227
 228 sub continuing () {
 229     grep { !$_->{NonCont} } values %cands;
 230 }
 231
 232 sub select_best_worst ($$$$) {
 233     my ($wantcand, $wanttiebreak, $signum, $what) = @_;
 234     # $wantcand->($c) = boolish
 235     # $wanttiebreak->($total) = boolish
 236     # Firstly candidates not meeting $wantcand are ignored
 237     # Then we pick the best (worst) candiate by Total (or vote history).
 238     # (SLGEO 49(2) and 51(2).
 239     # If this does not help then totals are equal and we call wanttiebreak.
 240     # If it returns 0 we return alphabetically first CAND.  Otherwise
 241     # we tie break.
 242
 243     my @maybe = grep { $wantcand->($_) } continuing();
 244     @maybe = sort total_history_cmp @maybe;
 245     @maybe = reverse @maybe if $signum > 0;
 246
 247     return undef unless @maybe;
 248
 249     my $nequal = 1;
 250
 251     for (;;) {
 252         my $nextc = $maybe[$nequal];
 253         last unless $nextc;
 254
 255         # Only interested in those who compare equal according to the
 256         # history (SLGEO 49(2)); NB our history includes the current
 257         # round.
 258
 259         last if $signum*($a = $maybe[0], $b = $nextc, total_history_cmp) > 0;
 260         $nequal++;
 261     }
 262
 263     if ($nequal > 1 && !$wanttiebreak->($maybe[0]{Total})) {
 264         # ... if equal for election we can do them one by one, since
 265         # order does not matter (SLGEO 49 talks about `two or more
 266         # ... exceeds').
 267         $nequal = 1;
 268     }
 269
 270     my $selectcand;
 271     if ($nequal > 1) {
 272         my @all = map { $_->{Cand} } @maybe[0 .. $nequal-1];
 273         my $tiekey = $signum > 0 ? 'Win' : 'Lose';
 274         $selectcand = $tie{"@all"}{$tiekey};
 275         die "need tie break, want $tiekey from @all"
 276             unless defined $selectcand;
 277         prf "$what %s due to tie break amongst %s\n",
 278             $selectcand, "@all";
 279     } else {
 280         $selectcand = $maybe[0]{Cand};
 281         prf "$what %s\n", $selectcand;
 282     }
 283
 284     return $cands{$selectcand};
 285 }
 286
 287 sub elect_core ($) {
 288     my ($c) = @_;
 289     prf "*** ELECT %s \`%s' ***\n", $c->{Cand}, $c->{Desc};
 290     $c->{NonCont} = 'Elected';
 291 }
 292
 293 $stage = 0;
 294
 295 for (;;) {
 296     $stage++;
 297
 298     sortballots @allvotes if $stage == 1;
 299
 300     my $seats_remain = $seats
 301         - grep { ($_->{NonCont} // '') eq 'Elected' } values %cands;
 302     if (continuing() <= $seats_remain) {
 303         foreach my $c (continuing()) {
 304             prf "electing %s to fill remaining place(s)\n", $c->{Cand};
 305             elect_core $c;
 306         }
 307         last;
 308     }
 309
 310     countballots();
 311
 312     computequota if $stage == 1;
 313
 314     my $c = select_best_worst
 315         sub { $_->{Total} >= $quota },
 316         sub { $_ > $quota },
 317         +1, 'electing';
 318
 319     if ($c) {
 320         elect_core $c;
 321         votelog $_, "helped elect $c->{Cand}" foreach @{ $c->{Votes} };
 322
 323         # SLGEO 48
 324         my $surplus = $c->{Total} - $quota;
 325
 326         if ($surplus <= 0/1) {
 327             prf "no surplus\n";
 328             next;
 329         }
 330
 331         my $B = $c->{Total};
 332         my %tspr;
 333
 334         prf "surplus %s\n", sv $surplus;
 335
 336         foreach my $v (@{ $c->{Votes} }) {
 337             my $previously = $v->{TransferredSurplus};
 338             push @$previously, $c->{Cand};
 339
 340             my $A = $surplus * $v->{Weight};
 341             my $xfervalue = floor(($A * $F) / $B) / $F;
 342             # SLGEO 48(3): we do arithmetic to 5 d3ecimal places,
 343             # but always rounding down
 344             votelog $v, "transferring with value $xfervalue (A=$A B=$B)";
 345             $v->{Weight} = $xfervalue;
 346
 347             if (defined $tspr{"@$previously"}) {
 348                 die unless $tspr{"@$previously"} == $xfervalue;
 349             } else {
 350                 $tspr{"@$previously"} = $xfervalue;
 351                 prf "transfer value of ballots %s: %s\n",
 352                     "@$previously", sv $xfervalue;
 353             }
 354         }
 355         sortballots @{ $c->{Votes} };
 356
 357         $c->{Votes} = { }; # will crash if we access it again
 358         next;
 359     }
 360
 361     # No-one to elect, must eliminate
 362     $c = select_best_worst
 363         sub { 1; },
 364         sub { 1; },
 365         -1, 'eliminating';
 366
 367     if ($c) {
 368         prf "=== eliminating %s \`%s' ===\n", $c->{Cand}, $c->{Desc};
 369         $c->{NonCont} = 'Eliminated';
 370
 371         sortballots @{ $c->{Votes} };
 372         next;
 373     }
 374
 375     die;
 376 }
 377
 378 print "done.\n";