X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;f=stv;h=bd952628c01ba1021a2294ef5295f24b4a585222;hb=24bf2bad96f040aacd4dd9ccdab7a300e812513b;hp=762da6359ed848ee63833b25f827df381ec128c6;hpb=530e6a27004910679481ad4a8e52f4beca643c32;p=appendix-a6.git diff --git a/stv b/stv index 762da63..bd95262 100755 --- a/stv +++ b/stv @@ -7,6 +7,9 @@ use strict; use utf8; use autodie; use bigrat; +use Carp; +use Data::Dumper; +use List::Util qw(sum0); use List::MoreUtils qw(nsort_by); # vote is @@ -20,10 +23,12 @@ our @allvotes; our $places = shift @ARGV; die unless $places eq ($places + 0); +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, @@ -34,7 +39,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 ($$) { @@ -60,7 +66,6 @@ our %sorted; # $sorted{$firstpref}{Votes} = [ $vote, ... ] # $sorted{$firstpref}{Cand} = $firstpref # $sorted{$firstpref}{Total} = $totalweight -our @sorted; # values same as %sorted our @surpluses; # values same as %sorted our @exhausted; # votes @@ -79,15 +84,51 @@ sub equalpiles ($@) { my $s = $sorted[0]; my $eqtotal = $s->{Total}; my $count = 0; - while ($count < @$sorted && $sorted[$count]{Total} == $eqtotal) { - printf "%7s %10s\n", $how, $sorted[$count]{Cand}; + while ($count < @sorted && $sorted[$count]{Total} == $eqtotal) { + printf "%7s %10s %s\n", $how, $sorted[$count]{Cand}, + pr $sorted[$count]{Total}; $count++; } - + return @sorted[ 0 .. $count-1 ]; +} + +sub historically_prefer ($@) { + my ($signum, @choices) = @_; + + 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; + } + return 0; + }; + + @choices = sort $compare, @choices; + $a = $choices[0]; + my $numequal = 0; + for (;;) { + last unless $numequal >= @choices; + $b = $choices[$numequal]; + last if $compare->(); + } + + die 'random choice unimplemented' if $numequal > 1; + return $choices[0]; +} 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 )] + ); + while (my $vote = shift @unsorted) { my ($firstpref) = grep { $continuing{$_} } @{ $vote->{Prefs} }; if (!defined $firstpref) { @@ -99,6 +140,7 @@ for (;;) { } $sorted{$_}{Cand} = $_ foreach keys %sorted; foreach my $firstpref (sort keys %sorted) { + $sorted{$firstpref}{Total} = 0; # recount foreach my $vote (@{ $sorted{$firstpref}{Votes} }) { votelog $vote, "counted $vote->{Weight} for $firstpref"; $sorted{$firstpref}{Total} += $vote->{Weight}; @@ -110,6 +152,8 @@ for (;;) { }; $sort_update->(); + print DEBUG "SORTED\n", Dumper(\@sorted); + push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted }; my $totalvalid = 0; @@ -123,7 +167,7 @@ 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"; @@ -138,7 +182,7 @@ for (;;) { } 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; @@ -147,22 +191,22 @@ for (;;) { # (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; - printf "%7s %10s\n", 'ELECTED', $s->{Cand}; + printf "%7s %10s ***************\n", 'ELECTED', $s->{Cand}; push @elected, $s->{Cand}; my $derate = $topvoters / $surplus; - printf "%7s %10s\n", 'derate', $s->{Cand}, pr $derate; + printf "%7s %10s %s\n", 'derate', $s->{Cand}, pr $derate; foreach my $vote (@{ $s->{Votes} }) { - votelog $vote, "elected $s->{Cand}, derated $weightmult"; + votelog $vote, "elected $s->{Cand}, derated $derate"; $vote->{Weight} /= $derate; } push @surpluses, $s; - delete %sorted{ $s->{Cand} }; + delete $sorted{ $s->{Cand} }; delete $continuing{ $s->{Cand} }; $sort_update->(); @@ -171,8 +215,8 @@ for (;;) { # 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 @@ -180,13 +224,25 @@ for (;;) { for (;;) { last unless @sorted; - my @elim = equalpiles 'elim?', reverse @sorted; - my $elimvote = sum map { $_->{Total} } @elim; - my $elimvotetotal = $elimvote * scalar @elim; + printf "%18s\n", 'elimination round'; - if (@surpluses and $elimvotetotal > $deferredsurplus) { - printf "no-elim, un-defer\n"; - last; + my @elim = equalpiles 'elim?', reverse @sorted; + my $elimvotetotal = sum0 map { $_->{Total} } @elim; + + if (@surpluses) { + if (@sorted == @elim) { + printf "%18s\n", 'no-elim, un-defer, (all-equal)'; + last; + } + my $nextup = $sorted[ $#sorted - @elim ]; + printf "%7s %10s %s\n", 'nextup', $nextup->{Cand}, + pr $nextup->{Total}; + my $aheadby = $nextup->{Total} - $elimvotetotal; + unless ($deferredsurplus <= $aheadby) { + # rule 5.2.2 (b) + printf "%18s %s\n", 'no-elim, un-defer', pr $aheadby; + last; + } } if ((scalar keys %continuing) - (scalar @elim) < $placesremain) { @@ -197,11 +253,11 @@ 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; - delete %continuing{$c}; - delete %sorted{$c}; + delete $continuing{$c}; + delete $sorted{$c}; push @unsorted, @$votes; } @@ -211,7 +267,7 @@ for (;;) { next unless $need_to_transfer_surplus; - @surpluses = nsort_by { $_->{Total} }, @surpluses; + @surpluses = nsort_by { $_->{Total} } @surpluses; my @surplusxfer = equalpiles 'xfer?', @surpluses; die unless @surplusxfer;