X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=appendix-a6.git;a=blobdiff_plain;f=compute-scottish-stv;h=81dc6adeafb10d553c50b2153a250a530bfc8966;hp=77e00da9d3c2b8f2ca5f9880815b113d2637bf33;hb=5b395082d4e913cd3049505065af086380c0016c;hpb=440eafd9205a4cbee5ab4ee0b0cf9c4e41b25bf1 diff --git a/compute-scottish-stv b/compute-scottish-stv old mode 100644 new mode 100755 index 77e00da..81dc6ad --- a/compute-scottish-stv +++ b/compute-scottish-stv @@ -4,21 +4,61 @@ # The Scottish Local Government Elections Order 2007 use strict; +use Carp; +use Data::Dumper; +use Math::BigRat; +use bigrat; # Data structures: # # vote is # { Voter => opaque, -# Prefs => [ list ], +# Prefs => [ [ CAND, ...], ... ], # Weight => 1.0 } # We edit Prefs as we go +# $cands{CAND}{Cand} # $cands{CAND}{Desc} # $cands{CAND}{Votes} +# $cands{CAND}{Total} +# $cands{CAND}{NonCont} # undef, or Elected or Eliminated +our $seats=0; + +our @allvotes; +our @non_transferable; +our %cands; our $stage=0; +our $quota; +our %tie; +our @elected; -our $seats=0; +our $DIGS = 5; +our $F = (new Math::BigRat 10)->bpow($DIGS); + +open DEBUG, ">.compute.log" or die $!; +DEBUG->autoflush(1); + +sub debug_dump () { + print DEBUG Dumper(\%tie, + \@non_transferable, + \%cands, + \@allvotes, + $stage, $quota); +} + +$SIG{__WARN__} = sub { + $SIG{__DIE__} = undef; + debug_dump; + confess $_[0]; +}; + +$SIG{__DIE__} = sub { + debug_dump; + die $_[0]; +}; + +sub total_history_cmp (); sub unkopt ($$) { my ($what,$opt) = @_; @@ -29,27 +69,46 @@ sub unkopt ($$) { } } +my $display_cmp = \&total_history_cmp; + +while (@ARGV && $ARGV[0] =~ m/^\-/) { + $_ = shift @ARGV; + if (m/^--$/) { + last; + } elsif (m/^--sort=alpha$/) { + $display_cmp = sub { $b->{Cand} cmp $a->{Cand} }; + } else { + die; + } +} + for (;;) { $_ = <>; if (m/^\| /) { foreach $_ (split / /, $') { if (m/^_?[Ss]eats=(\d+)/) { $seats = $1; + } elsif (m/^_?[Tt]ie=(.*)\>(.*)$/) { + my @more = split /\,/, $1; + my @less = split /\,/, $2; + my @all = join ',', sort (@more, @less); + $tie{"@all"}{Win} = $more[0] if @more == 1; + $tie{"@all"}{Lose} = $less[0] if @less == 1; } else { unkopt "election", $_; } } } elsif (m/^(\w+) = (\S*) \|/) { - my ($cand,$desc) = @_; + my ($cand,$desc) = ($1,$2); unkopt "candidate $cand", $_ foreach split / /, $'; $cands{$cand}{Desc} = $desc; } elsif (m/^(\w*) :\s*(.*)\s*\|(.*)/) { my ($voter,$prefs,$opts) = ($1,$2,$3); - $v = { Voter => $voter }; + my $v = { Voter => $voter, Prefs => [ ] }; push @{ $v->{Prefs} }, [ $_ =~ m/\w+/g ] foreach split /\s+/, $prefs; foreach $_ (split / /, $opts) { - if (m/^_?[Ww]eight=(\d+)/(\d+)$/) { + if (m/^_?[Ww]eight=(\d+)\/(\d+)$/) { $v->{Weight} = $1 / $2; } elsif (m/^_?[Ww]eight=([0-9.]+)$/) { $v->{Weight} = new Math::BigRat $1; @@ -65,38 +124,285 @@ for (;;) { } } +$cands{$_}{Cand} = $_ foreach keys %cands; +$_->{Weight} //= 1/1 foreach @allvotes; +$_->{TransferredSurplus} //= [ ] foreach @allvotes; +$_->{OrigPrefs} //= [ @{ $_->{Prefs} } ] foreach @allvotes; + +sub votelog ($$) { + my ($vote,$m) = @_; + push @{ $vote->{Log} }, "stage $stage: $m"; +} + +sub sortballots (@); sub sortballots (@) { # Takes each argument, which should be a ballot, sorts # it into $cand{CAND}{Votes} according to first preference. # Strips that first preference from the ballot. # If the first preference has been eliminated, strips it # and looks for further preferences. + print DEBUG "sortballots ".(scalar @_)."...\n"; foreach my $v (@_) { my $firstprefs = shift @{ $v->{Prefs} }; + my $w = $v->{Weight}; if (!$firstprefs || !@$firstprefs) { - vlog $v, "no more preferences, non transferable"; + votelog $v, "no more preferences, non transferable"; push @non_transferable, $v; next; } if (@$firstprefs > 1) { - vlog $v, "splitting due to several equal first preferences"; + votelog $v, "splitting due to several equal first preferences"; foreach my $fpref (@$firstprefs) { my $v2 = { %$v, - Weight => $v->{Weight} / @$firstprefs, + Weight => $w / @$firstprefs, Prefs => [ [ $fpref ], @{ $v->{Prefs} } ], - }; - vlog $v, "split for $fpref"; - - - Voter => $ - - my @prefs - my $nprefs = scalar @{ $v->{Prefs} - my @input = @_; - - -# $cands + }; + votelog $v, "split for $fpref"; + } + next; + } + my $fp = $firstprefs->[0]; + my $c = $cands{$fp}; + my $noncont = $c->{NonCont}; + if ($noncont) { + votelog $v, "dropping pref $fp, $noncont"; + sortballots $v; + next; + } + votelog $v, "sorted into pile for candidate $fp weight $w"; + push @{ $c->{Votes} }, $v; + } +} + +sub floor ($) { + my ($v) = @_; + $v = new Math::BigRat $v; # we need a copy + return $v->bfloor(); +} + +sub sv ($) { + my ($in) = @_; + my $v = new Math::BigRat $in; # just in case + my $intpart = floor($v); + my $frac = $v - $intpart; + my $good = floor($frac * $F); + my $bad = $frac * $F - $good; + my $s = sprintf "%7d", $intpart; + if ($frac) { + $s .= sprintf ".%0${DIGS}d", $good; + $s .= sprintf "%-4s", ($bad ? "+$bad" : ""); + } else { + $s .= sprintf " %${DIGS}s%4s", '', ''; + } +#print STDERR "# $in => $s # (intpart=$intpart frac=$frac)\n"; + return $s; +} + +sub prf { + my $fmt = shift; + printf "stage %d: ".$fmt, $stage, @_; +} + +sub countballots () { + foreach my $c (values %cands) { + next if $c->{NonCont}; + $c->{Total} = 0/1; + $c->{Total} += $_->{Weight} foreach @{ $c->{Votes} }; + print DEBUG "counted $c->{Cand} $c->{Total}\n"; + $c->{History}[$stage-1] = $c->{Total}; + } + + foreach my $c (reverse sort $display_cmp + grep { !$_->{NonCont} } values %cands) { + prf "candidate %-10s: %s votes\n", $c->{Cand}, sv $c->{Total}; + } +} + +sub computequota () { + my $totalvalid = 0/1; + $totalvalid += $_->{Total} foreach values %cands; + $quota = floor($totalvalid / (1 + $seats) + 1); + prf "total valid %s quota %s\n", (sv $totalvalid), (sv $quota); +} + +sub total_history_cmp () { + my $ha = $a->{History}; + my $hb = $b->{History}; + my $m = "stage $stage history cmp $a->{Cand} $b->{Cand}"; + print DEBUG "$m...\n"; + foreach my $s (reverse 0 .. $stage-1) { + my $d = $ha->[$s] <=> $hb->[$s]; + next unless $d; + print DEBUG "$m => $d (#$s $ha->[$s] $hb->[$s])\n"; + return $d; + } + print DEBUG "$m => 0\n"; + return 0; +} + +sub continuing () { + grep { !$_->{NonCont} } values %cands; +} + +sub select_best_worst ($$$$) { + my ($wantcand, $wanttiebreak, $signum, $what) = @_; + # $wantcand->($c) = boolish + # $wanttiebreak->($total) = boolish + # Firstly candidates not meeting $wantcand are ignored + # Then we pick the best (worst) candiate by Total (or vote history). + # (SLGEO 49(2) and 51(2). + # If this does not help then totals are equal and we call wanttiebreak. + # If it returns 0 we return alphabetically first CAND. Otherwise + # we tie break. + + my @maybe = grep { $wantcand->($_) } continuing(); + @maybe = sort total_history_cmp @maybe; + @maybe = reverse @maybe if $signum > 0; + + return undef unless @maybe; + + my $nequal = 1; + + for (;;) { + my $nextc = $maybe[$nequal]; + last unless $nextc; + + # Only interested in those who compare equal according to the + # history (SLGEO 49(2)); NB our history includes the current + # round. + + last if $signum*($a = $maybe[0], $b = $nextc, total_history_cmp) > 0; + $nequal++; + } + + if ($nequal > 1 && !$wanttiebreak->($maybe[0]{Total})) { + # ... if equal for election we can do them one by one, since + # order does not matter (SLGEO 49 talks about `two or more + # ... exceeds'). + $nequal = 1; + } + + my $selectcand; + if ($nequal > 1) { + my @all = map { $_->{Cand} } @maybe[0 .. $nequal-1]; + my $tiekey = $signum > 0 ? 'Win' : 'Lose'; + $selectcand = $tie{"@all"}{$tiekey}; + die "need tie break, want $tiekey from @all" + unless defined $selectcand; + prf "$what %s due to tie break amongst %s\n", + $selectcand, "@all"; + } else { + $selectcand = $maybe[0]{Cand}; + prf "$what %s\n", $selectcand; + } + + return $cands{$selectcand}; +} + +sub elect_core ($) { + my ($c) = @_; + prf "*** ELECT %s \`%s' ***\n", $c->{Cand}, $c->{Desc}; + $c->{NonCont} = 'Elected'; + push @elected, $c; +} + +$stage = 0; for (;;) { - + $stage++; + + sortballots @allvotes if $stage == 1; + + my $seats_remain = $seats - @elected; + + prf "seats remaining %d\n", $seats_remain; + + last unless $seats_remain; + + if (continuing() <= $seats_remain) { + foreach my $c (continuing()) { + prf "electing %s to fill remaining place(s)\n", $c->{Cand}; + elect_core $c; + } + last; + } + + countballots(); + + computequota if $stage == 1; + + my $c = select_best_worst + sub { $_->{Total} >= $quota }, + sub { $_ > $quota }, + +1, 'electing'; + + if ($c) { + elect_core $c; + votelog $_, "helped elect $c->{Cand}" foreach @{ $c->{Votes} }; + + # SLGEO 48 + my $surplus = $c->{Total} - $quota; + + if ($surplus <= 0/1) { + prf "no surplus\n"; + next; + } + + last if $seats_remain == 1; # don't bother doing more transfers + + my $B = $c->{Total}; + my %tspr; + + prf "surplus %s\n", sv $surplus; + + foreach my $v (@{ $c->{Votes} }) { + my $previously = $v->{TransferredSurplus}; + push @$previously, $c->{Cand}; + + my $A = $surplus * $v->{Weight}; + my $xfervalue = floor(($A * $F) / $B) / $F; + # SLGEO 48(3): we do arithmetic to 5 d3ecimal places, + # but always rounding down + votelog $v, "transferring with value $xfervalue (A=$A B=$B)"; + $v->{Weight} = $xfervalue; + + if (defined $tspr{"@$previously"}) { + die unless $tspr{"@$previously"} == $xfervalue; + } else { + $tspr{"@$previously"} = $xfervalue; + prf "transfer value of ballots %20s: %s\n", + "@$previously", sv $xfervalue; + } + } + sortballots @{ $c->{Votes} }; + + $c->{Votes} = { }; # will crash if we access it again + next; + } + + # No-one to elect, must eliminate + $c = select_best_worst + sub { 1; }, + sub { 1; }, + -1, 'eliminating'; + + if ($c) { + prf "=== eliminating %s \`%s' ===\n", $c->{Cand}, $c->{Desc}; + $c->{NonCont} = 'Eliminated'; + + sortballots @{ $c->{Votes} }; + next; + } + + die; +} + +print "Winners:\n"; + +foreach my $i (0..$#elected) { + my $c = $elected[$i]; + printf " %3d. %-10s %s\n", $i+1, $c->{Cand}, $c->{Desc}; +} + +print "done.\n";