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