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 continuing () {
 159     grep { !$_->{NonCont} } values %cands;
 160 }
 161
 162 sub select_best_worst ($$$$) {
 163     my ($wantcand, $wanttiebreak, $signum, $what) = @_;
 164     # $wantcand->($c) = boolish
 165     # $wanttiebreak->($total) = boolish
 166     # Firstly candidates not meeting $wantcand are ignored
 167     # Then we pick the best (worst) candiate by Total (or vote history).
 168     # (SLGEO 49(2) and 51(2).
 169     # If this does not help then totals are equal and we call wanttiebreak.
 170     # If it returns 0 we return alphabetically first CAND.  Otherwise
 171     # we tie break.
 172
 173     my @maybe = grep { $wantcand->($_) } @continuing;
 174     @maybe = sort total_history_cmp @maybe;
 175     @maybe = reverse @maybe if $signum > 0;
 176
 177     return undef unless @maybe;
 178
 179     my $nequal = 1;
 180
 181     for (;;) {
 182         my $nextc = $maybe[$nequal];
 183
 184         # Only interested in those who compare equal according to the
 185         # history (SLGEO 49(2)); NB our history includes the current
 186         # round.
 187         last if $signum*(total_history_cmp $maybe[0], $nextc) > 0;
 188         $nextc++;
 189     }
 190
 191     if ($nequal > 1 && !$wanttiebreak->($maybe[0]{Total})) {
 192         # ... if equal for election we can do them one by one, since
 193         # order does not matter (SLGEO 49 talks about `two or more
 194         # ... exceeds').
 195         $nequal = 1;
 196     }
 197
 198     my $selectcand;
 199     if ($nequal > 1) {
 200         my @all = map { $_->{Cand} } @maybe_elect[0 .. $nelect-1];
 201         my $tiekey = $signum > 0 ? 'Win' : 'Lose';
 202         my $win = $tie{"@all"}{$tiekey};
 203         die "need tie break, want $tiekey from @all" unless defined $win;
 204         prf "$what %s due to tie break amongst %s\n",
 205             $eslectcand, "@all";
 206     } else {
 207         $selectcand = $maybe[0];
 208         prf "$what %s\n";
 209     }
 210
 211     return $cands{$electcand};
 212 }
 213
 214 sub elect_core ($) {
 215     my ($c) = @_;
 216     prf "*** ELECT %s \`%s' ***\n", $c->{Cand}, $c->{Desc};
 217     $c->{NonCont} = 'Elected';
 218 }
 219
 220 sortballots @allvotes;
 221
 222 for (;;) {
 223     $stage++;
 224
 225     my $seats_remain = $seats
 226         - grep { $_->{NonCont} eq 'Elected' } values %cands;
 227     if (continuing() <= $seats_remain) {
 228         foreach my $c (continuing()) {
 229             prf "electing %s to fill remaining place(s)\n", $c->{Cand};
 230             elect_core $c;
 231         }
 232         last;
 233     }
 234
 235     countballots();
 236
 237     my $c = select_best_worst
 238         sub { $_->{Total} >= $quota },
 239         sub { $_ > $quota },
 240         +1, 'electing';
 241
 242     if ($c) {
 243         elect_core $c;
 244         votelog $_, "helped elect $c->{Cand}" foreach @{ $c->{Votes} };
 245
 246         # SLGEO 48
 247         my $surplus = $c->{Total} - $quota;
 248
 249         if ($surplus <= 0) {
 250             prf "no surplus\n";
 251             next;
 252         }
 253
 254         my $B = $c->{Weight};
 255
 256         foreach my $v (@{ $c->{Votes} }) {
 257             my $A = $surplus * $v->{Weight};
 258             my $F = 100000;
 259             my $xfervalue = floor(($A * $F) / $B) / $f;
 260             # SLGEO 48(3): we do arithmetic to 5 d3ecimal places,
 261             # but always rounding down
 262             votelog $v, "transferring with value $xfervalue (A=$A B=$B)";
 263             $v->{Weight} = $xfervalue;
 264             sortballots $v;
 265         }
 266         $c->{Votes} = { }; # will crash if we access it again
 267         next;
 268     }
 269
 270     # No-one to elect, must eliminate
 271     my $c = select_best_worst
 272         sub { 1; },
 273         sub { 1; },
 274         -1, 'eliminating';
 275
 276     if ($c) {
 277         prf "=== eliminating %s (%s) ===\n", $c->{Cand}, $c->{Desc};
 278         $c->{NonCont} = 'Eliminated';
 279         next;
 280     }
 281
 282     die;
 283 }
 284
 285 print "done.\n";