X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=appendix-a6.git;a=blobdiff_plain;f=stv;h=3c6160e979f27ffa7f026ed59d20a4b2dabf2710;hp=47984e80dc4bdb286f8d2f271d4e3701e7089b72;hb=2251d06cbf7d16682040782d415c371a43fdf275;hpb=83ac3d9b8d6e365ca3f7083db8f37034456da0be diff --git a/stv b/stv index 47984e8..3c6160e 100755 --- a/stv +++ b/stv @@ -3,12 +3,26 @@ # Does STV according to # http://www.rosenstiel.co.uk/stvrules/av/index.htm +# Usage: +# ./stv [TIEBREAK ...] PLACES [INPUT-FILES ...] +# +# PLACES is the number of seats to be filled +# +# INPUT-FILES are in the format: +# VOTER PQRST +# where P, Q, R, etc. are candidates. Candidates +# must be single letters. +# +# Each TIEBREAK is +# P,Q,... + use strict; use utf8; use autodie; -#use bigrat; +use bigrat; +use Carp; use Data::Dumper; -use List::Util qw(sum); +use List::Util qw(sum0); use List::MoreUtils qw(nsort_by); # vote is @@ -19,6 +33,25 @@ use List::MoreUtils qw(nsort_by); our $stage=0; our @allvotes; +our %tiebreak; # $tiebreak{ winningcand }{ losingcand } = 1 + +while (@ARGV && $ARGV[0] =~ m/[<>]/) { + my ($losers, $winners) = ($? eq '<' ? ($`, $') : ($', $`)); + my @losers = sort split /\,/, $losers; + my @winners = sort split /\,/, $winners; + die "@losers @winners" if @losers>1 && @winners>1; + my @all = sort @losers, @winners; + my $record = sub { + my ($how, $howers) = @_; + return unless @$howers == 1; + die "@all $how" if defined $tiebreak{$how}{"@all"}; + $tiebreak{$how}{"@all"} = $howers->[0]; + }; + $record->('winner', \@winners); + $record->('loser', \@losers); + shift @ARGV; +} + our $places = shift @ARGV; die unless $places eq ($places + 0); @@ -27,7 +60,7 @@ open DEBUG, ">.stv.log" or die $!; while (<>) { next if m/^\w+$/; m/^(\w+) ([A-Z]+)$/ or die "$_ ?"; - my $prefs = $1; + my $prefs = $2; my $vote = { Voter => $1, Weight => 1.0, @@ -38,7 +71,8 @@ while (<>) { sub pr ($) { my ($f) = @_; - return sprintf "%10.6f=%-10s", $f, $f; + confess unless defined $f; + return sprintf "%10.6f = %-10s", $f, $f; } sub votelog ($$) { @@ -46,16 +80,6 @@ sub votelog ($$) { push @{ $vote->{Log} }, "stage $stage: $m"; } -sub filterout ($$) { - my ($cand, $why) = @_; - foreach my $vote (@allvotes) { - my $oldprefs = $vote->{Prefs}; - my @prefs = grep { $_ ne $cand } $oldprefs; - next if @prefs == @$oldprefs; - votelog $vote, "crossed out candidate $cand: $why"; - } -} - our @elected; # $elected[] = $candidate our @unsorted = @allvotes; @@ -72,6 +96,17 @@ our %continuing; # $continuing{$candidate}=1 our @stagerecord; # $stagerecord[]{$candidate} = $total +sub voteliveprefs ($) { + my ($vote) = @_; + grep { $continuing{$_} } @{ $vote->{Prefs} }; +} + +sub votelogfull ($$) { + my ($vote,$m) = @_; + votelog $vote, $m; + votelog $vote, ("continuing prefs: ". join ' ', voteliveprefs $vote); +} + foreach my $vote (@allvotes) { $continuing{$_}=1 foreach @{ $vote->{Prefs} }; } @@ -81,9 +116,10 @@ sub equalpiles ($@) { return () unless @sorted; my $s = $sorted[0]; my $eqtotal = $s->{Total}; - my $count = 0; + my $count = 0/1; while ($count < @sorted && $sorted[$count]{Total} == $eqtotal) { - printf "%7s %10s\n", $how, $sorted[$count]{Cand}; + printf "%7s %10s %s\n", $how, $sorted[$count]{Cand}, + pr $sorted[$count]{Total}; $count++; } return @sorted[ 0 .. $count-1 ]; @@ -91,41 +127,86 @@ sub equalpiles ($@) { sub historically_prefer ($@) { my ($signum, @choices) = @_; + # $signum==+1 means choose candidates with more early preferences return $choices[0] if @choices < 2; my $compare = sub { foreach my $sr (@stagerecord) { - my $d = $sr->{ $a->{Cand} } <=> $sr->{ $b->{Cand} }; - return $d * $signum if $d; + my $d = ($sr->{ $a->{Cand} }//0) <=> ($sr->{ $b->{Cand} }//0); + return -$d * $signum if $d; } return 0; }; - @choices = sort $compare, @choices; + @choices = sort $compare @choices; + + print DEBUG "historically_prefer\n", + Data::Dumper->Dump([\@choices, \@stagerecord], + [qw(_@choices _@stagerecord)]); + + foreach my $s (@choices) { + my $c = $s->{Cand}; + printf " %6s %10s |", 'tiebrk', $c; + foreach my $sr (@stagerecord) { + my $p = pr($sr->{$c} // 0); + $p =~ s/\.0+\b//g; + $p =~ s/ //g; + print "$p|"; + } + print "\n"; + } + $a = $choices[0]; - my $numequal = 0; + my $numequal = 1; for (;;) { - last unless $numequal >= @choices; + last if $numequal >= @choices; $b = $choices[$numequal]; last if $compare->(); + $numequal++; + } + + if ($numequal > 1) { + my $how = $signum > 0 ? 'winner' : 'loser'; + my @all = sort map { $_->{Cand} } @choices[ 0 .. $numequal-1 ]; + my $hower = $tiebreak{$how}{"@all"}; + if (defined $hower) { + printf "%7.7s %10s !!!!!!!!!!\n", "TIE".(uc $how), $hower; + return grep { $_->{Cand} eq $hower } @choices; + } + die "need tie break for $how between @all\n"; } - die 'random choice unimplemented' if $numequal > 1; return $choices[0]; } +foreach my $c (keys %continuing) { + $sorted{$c} = { + Cand => $c, + Votes => [], + }; +} + for (;;) { $stage++; + printf "----- stage %d -----\n", $stage; + print DEBUG "#################### $stage ####################\n", Data::Dumper->Dump( [ \@stagerecord, \@elected, \@unsorted, \%sorted, \@surpluses, \%continuing ], [qw( _@stagerecord _@elected _@unsorted _%sorted _@surpluses _%continuing )] ); + my $placesremain = $places - @elected; + + unless ($placesremain > 0) { + printf "Complete: @elected\n"; + last; + } + while (my $vote = shift @unsorted) { - my ($firstpref) = grep { $continuing{$_} } @{ $vote->{Prefs} }; + my ($firstpref) = voteliveprefs $vote; if (!defined $firstpref) { votelog $vote, "ballot exhausted"; push @exhausted, $vote; @@ -133,22 +214,25 @@ for (;;) { push @{ $sorted{$firstpref}{Votes} }, $vote; } } - $sorted{$_}{Cand} = $_ foreach keys %sorted; foreach my $firstpref (sort keys %sorted) { foreach my $vote (@{ $sorted{$firstpref}{Votes} }) { - votelog $vote, "counted $vote->{Weight} for $firstpref"; - $sorted{$firstpref}{Total} += $vote->{Weight}; + votelog $vote, "counted for $firstpref ".pr $vote->{Weight}; } } my @sorted; - my $sort_update = sub { + my $things_update = sub { + foreach my $s (values %sorted) { + $s->{Total} = sum0 map { $_->{Weight} } @{ $s->{Votes } }; + } @sorted = nsort_by { -$_->{Total} } values %sorted; }; - $sort_update->(); + $things_update->(); + + print DEBUG "SORTED\n", Dumper(\@sorted); push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted }; - my $totalvalid = 0; + my $totalvalid = 0/1; my $countvalid = sub { my ($l, $what) = @_; foreach my $s (@$l) { @@ -159,73 +243,134 @@ for (;;) { $countvalid->(\@sorted, '1stpref'); $countvalid->(\@surpluses, 'surplus'); - printf "%7s %10s %s\n", 'TOTAL', '', pr $totalvalid; + printf "%7s %10s %s\n", 'TOTAL', '-----', pr $totalvalid; unless ($totalvalid > 0) { printf "No more votes!\n"; last; } - my $placesremain = $places - @elected; - - unless ($placesremain > 0) { - printf "Complete.\n"; - last; - } - my $quota = $totalvalid / ($placesremain + 1); - printf "%7s %10s %s\n", '', 'quota', pr $quota; + printf "%7s %10s %s\n", 'quota', '', pr $quota; my $need_to_transfer_surplus = 1; + my @newsurpluses; + # Look for people to elect. # We elect as many as we can, rather than recomputing the (lower) quota # (ERS rules 5.4.9) for (;;) { my $s = $sorted[0]; - my $topvoters = $s->{Weight}; + my $topvoters = $s->{Total}; my $surplus = $topvoters - $quota; - last unless $surplus > 0; + last unless $surplus >= 0; + last unless $placesremain; + + my @elect = equalpiles 'elect?', @sorted; - printf "%7s %10s\n", 'ELECTED', $s->{Cand}; - push @elected, $s->{Cand}; + if (@elect > $placesremain) { + # oh my god + @elect = historically_prefer +1, @elect; + printf "%7s %10s\n", 'tie!', $elect[0]{Cand}; + } - my $derate = $topvoters / $surplus; - printf "%7s %10s\n", 'derate', $s->{Cand}, pr $derate; + foreach $s (@elect) { + printf "%7s %10s ***************\n", 'ELECTED', $s->{Cand}; + push @elected, $s->{Cand}; - foreach my $vote (@{ $s->{Votes} }) { - votelog $vote, "elected $s->{Cand}, derated $derate"; - $vote->{Weight} /= $derate; + foreach my $vote (@{ $s->{Votes} }) { + votelog $vote, "elected $s->{Cand}"; + } + + $s->{Surplus} = $surplus; + push @newsurpluses, $s; + delete $sorted{ $s->{Cand} }; + delete $continuing{ $s->{Cand} }; + $placesremain--; } + + $things_update->(); + } + + foreach my $s (@newsurpluses) { + # calculate the transfer value of each surplus + # we do this simultaneously, but based on the number of + # continuing candidates (excluding all the ones elected already) + # ERS rule 5.3.3 + + my $votes = $s->{Votes}; + my $surplus = $s->{Surplus}; + my $transferrable = + sum0 + map { $_->{Weight} } + grep { !!voteliveprefs $_ } + @$votes; + + my $derate = 1/1; + printf "%7s %10s %s\n", 'xfrable', $s->{Cand}, pr $transferrable; + if ($transferrable > $surplus) { + $derate = $transferrable / $surplus; + printf "%7s %10s %s\n", 'derate', $s->{Cand}, pr $derate; + foreach my $vote (@{ $s->{Votes} }) { + votelog $vote, "part of surplus, derated ". pr $derate; + $vote->{Weight} /= $derate; + } + } + $s->{Total} = $transferrable / $derate; + push @surpluses, $s; - delete $sorted{ $s->{Cand} }; - delete $continuing{ $s->{Cand} }; - $sort_update->(); + $things_update->(); + printf "%7s %10s %s\n", 'surplus', $s->{Cand}, pr $s->{Total}; + $need_to_transfer_surplus = 0; # before actually transferring a surplus, we will consider # eliminating, and then reconsider with a lower quota } - my $deferredsurplus = sum map { $_->{Total} } @surpluses; - printf "%7s %10s %s\n", 'def.srp', 'total', pr $deferredsurplus; + my $deferredsurplus = sum0 map { $_->{Total} } @surpluses; + printf "%18s %s\n", 'deferred surplus', pr $deferredsurplus; # Look for people to eliminate # We eliminate before trying to transfer surpluses # ERS 5.2.5 + my $elimvotebefore = 0/1; for (;;) { last unless @sorted; - my @elim = equalpiles 'elim?', reverse @sorted; - my $elimvote = sum map { $_->{Total} } @elim; - my $elimvotetotal = $elimvote * scalar @elim; + if ($elimvotebefore) { + printf "%18s %s\n", 'elimination, sofar', pr $elimvotebefore; + } elsif (@surpluses) { + printf "%18s\n", 'elimination, maybe'; + } else { + printf "%18s\n", 'elimination, starts'; + } - if (@surpluses and $elimvotetotal > $deferredsurplus) { - printf "no-elim, un-defer\n"; - last; + my @elim = equalpiles 'elim?', reverse @sorted; + my $elimvotenow = sum0 map { $_->{Total} } @elim; + + if (@surpluses || $elimvotebefore) { + # rule 5.2.2 + if (@sorted == @elim) { + printf "%18s\n", 'no-elim (all-equal)'; + last; + } + my $nextup = $sorted[ $#sorted - @elim ]; + printf "%7s %10s %s\n", 'nextup', $nextup->{Cand}, + pr $nextup->{Total}; + my $aheadby = $nextup->{Total} - ($elimvotenow + $elimvotebefore); + unless ($deferredsurplus <= $aheadby) { + # rule 5.2.2 (b) + printf "%18s %s\n", 'no-elim (nextup)', pr $aheadby; + last; + } } - if ((scalar keys %continuing) - (scalar @elim) < $placesremain) { + my $elim_tie = + @elim > 1 && + (scalar keys %continuing) - (scalar @elim) < $placesremain; + if ($elim_tie) { # eliminate only one then, and try again printf "elim-tie!\n"; @elim = historically_prefer -1, @elim; @@ -233,21 +378,23 @@ for (;;) { foreach my $s (@elim) { my $c = $s->{Cand}; - printf "%7s %10s\n", 'ELIM', $c; + printf "%7s %10s %s\n", 'ELIM', $c, '----------'; my $votes = $s->{Votes}; - votelog $_, "failed to stop $c elimination" foreach @$votes; + votelogfull $_, "failed to stop $c elimination" foreach @$votes; + $elimvotebefore += $s->{Total}; delete $continuing{$c}; delete $sorted{$c}; push @unsorted, @$votes; } - $sort_update->(); + $things_update->(); $need_to_transfer_surplus = 0; + last if $elim_tie; # no more, then! } next unless $need_to_transfer_surplus; - @surpluses = nsort_by { $_->{Total} }, @surpluses; + @surpluses = nsort_by { $_->{Total} } @surpluses; my @surplusxfer = equalpiles 'xfer?', @surpluses; die unless @surplusxfer; @@ -259,9 +406,19 @@ for (;;) { my $c = $s->{Cand}; printf "%7s %10s\n", 'xfer', $c; my $votes = $s->{Votes}; - votelog $_, "surplus transferred" foreach @$votes; + votelogfull $_, "surplus transferred" foreach @$votes; @surpluses = grep { $_->{Cand} ne $c } @surpluses; push @unsorted, @$votes; } +open VL, ">.stv.votes" or die $!; +foreach my $vote (@allvotes) { + print VL "----------------------------------------\n"; + print VL "voter $vote->{Voter}\n"; + print VL "prefs ". (join " ", @{ $vote->{Prefs} }). "\n"; + print VL $_, "\n" foreach @{ $vote->{Log} }; +} +print VL "========================================\n"; +close VL; + print "done.\n";