X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=appendix-a6.git;a=blobdiff_plain;f=stv;h=3c6160e979f27ffa7f026ed59d20a4b2dabf2710;hp=a9636096ae9f90e1f1d58666bc2f5815360b7a04;hb=5fc4bc0993f2f2dc97c43217b3c0bfc51cdf9415;hpb=79268be36a253e1396688eb9956e021bbfca53ef diff --git a/stv b/stv index a963609..3c6160e 100755 --- a/stv +++ b/stv @@ -3,6 +3,19 @@ # 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; @@ -20,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); @@ -48,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; @@ -74,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} }; } @@ -83,7 +116,7 @@ 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 %s\n", $how, $sorted[$count]{Cand}, pr $sorted[$count]{Total}; @@ -94,27 +127,56 @@ 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]; } @@ -139,12 +201,12 @@ for (;;) { my $placesremain = $places - @elected; unless ($placesremain > 0) { - printf "Complete.\n"; + 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; @@ -154,12 +216,12 @@ for (;;) { } foreach my $firstpref (sort keys %sorted) { foreach my $vote (@{ $sorted{$firstpref}{Votes} }) { - votelog $vote, "counted $vote->{Weight} for $firstpref"; + votelog $vote, "counted for $firstpref ".pr $vote->{Weight}; } } my @sorted; my $things_update = sub { - foreach my $s (@surpluses, values %sorted) { + foreach my $s (values %sorted) { $s->{Total} = sum0 map { $_->{Weight} } @{ $s->{Votes } }; } @sorted = nsort_by { -$_->{Total} } values %sorted; @@ -170,7 +232,7 @@ for (;;) { push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted }; - my $totalvalid = 0; + my $totalvalid = 0/1; my $countvalid = sub { my ($l, $what) = @_; foreach my $s (@$l) { @@ -193,6 +255,8 @@ for (;;) { 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) @@ -200,21 +264,62 @@ for (;;) { my $s = $sorted[0]; my $topvoters = $s->{Total}; my $surplus = $topvoters - $quota; - last unless $surplus > 0; + last unless $surplus >= 0; + last unless $placesremain; - printf "%7s %10s ***************\n", 'ELECTED', $s->{Cand}; - push @elected, $s->{Cand}; + my @elect = equalpiles 'elect?', @sorted; - my $derate = $topvoters / $surplus; - printf "%7s %10s %s\n", 'derate', $s->{Cand}, pr $derate; + if (@elect > $placesremain) { + # oh my god + @elect = historically_prefer +1, @elect; + printf "%7s %10s\n", 'tie!', $elect[0]{Cand}; + } + + 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} }; $things_update->(); printf "%7s %10s %s\n", 'surplus', $s->{Cand}, pr $s->{Total}; @@ -230,7 +335,7 @@ for (;;) { # Look for people to eliminate # We eliminate before trying to transfer surpluses # ERS 5.2.5 - my $elimvotebefore = 0; + my $elimvotebefore = 0/1; for (;;) { last unless @sorted; @@ -275,7 +380,7 @@ for (;;) { my $c = $s->{Cand}; 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}; @@ -301,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";