3 # Does STV according to
4 # http://www.rosenstiel.co.uk/stvrules/av/index.htm
10 use List::MoreUtils qw(nsort_by);
20 our $places = shift @ARGV;
21 die unless $places eq ($places + 0);
25 m/^(\w+) ([A-Z]+)$/ or die "$_ ?";
30 Prefs => [ split //, $prefs ],
32 push @allvotes, $vote;
37 return sprintf "%10.6f=%-10s", $f, $f;
42 push @{ $vote->{Log} }, "stage $stage: $m";
46 my ($cand, $why) = @_;
47 foreach my $vote (@allvotes) {
48 my $oldprefs = $vote->{Prefs};
49 my @prefs = grep { $_ ne $cand } $oldprefs;
50 next if @prefs == @$oldprefs;
51 votelog $vote, "crossed out candidate $cand: $why";
55 our @elected; # $elected[] = $candidate
57 our @unsorted = @allvotes;
60 # $sorted{$firstpref}{Votes} = [ $vote, ... ]
61 # $sorted{$firstpref}{Cand} = $firstpref
62 # $sorted{$firstpref}{Total} = $totalweight
63 our @sorted; # values same as %sorted
64 our @surpluses; # values same as %sorted
66 our @exhausted; # votes
68 our %continuing; # $continuing{$candidate}=1
70 our @stagerecord; # $stagerecord[]{$candidate} = $total
72 foreach my $vote (@allvotes) {
73 $continuing{$_}=1 foreach @{ $vote->{Prefs} };
79 while (my $vote = shift @unsorted) {
80 my ($firstpref) = grep { $continuing{$_} } @{ $vote->{Prefs} };
81 if (!defined $firstpref) {
82 votelog $vote, "ballot exhausted";
83 push @exhausted, $vote;
85 push @{ $sorted{$firstpref}{Votes} }, $vote;
88 $sorted{$_}{Cand} = $_ foreach keys %sorted;
89 foreach my $firstpref (sort keys %sorted) {
90 foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
91 votelog $vote, "counted $vote->{Weight} for $firstpref";
92 $sorted{$firstpref}{Total} += $vote->{Weight};
95 my @sorted = nsort_by { -$_->{Total} } values %sorted;
97 push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted };
100 my $countvalid = sub {
102 foreach my $s (@$l) {
103 printf "%-7s %10s %s\n", $what, $s->{Cand}, pr $s->{Total};
104 $totalvalid += $s->{Total};
107 $countvalid->(\@sorted, '1stpref');
108 $countvalid->(\@surpluses, 'surplus');
110 printf "%7s %10s %s\n", 'TOTAL', '', pr $totalvalid;
112 unless ($totalvalid > 0) {
113 printf "No more votes!\n";
117 my $placesremain = $places - @elected;
119 unless ($placesremain > 0) {
120 printf "Complete.\n";
124 my $quota = $totalvalid / ($placesremain + 1);
125 printf "%7s %10s %s\n", '', 'quota', pr $quota;
127 my $need_to_transfer_surplus = 1;
129 # Look for people to elect.
130 # We elect as many as we can, rather than recomputing the (lower) quota
134 my $topvoters = $s->{Weight};
135 my $surplus = $topvoters - $quota;
136 last unless $surplus > 0;
138 printf "%7s %10s\n", 'ELECTED', $s->{Cand};
139 push @elected, $s->{Cand};
141 my $derate = $topvoters / $surplus;
142 printf "%7s %10s\n", 'derate', $s->{Cand}, pr $derate;
144 foreach my $vote (@{ $s->{Votes} }) {
145 votelog $vote, "elected $s->{Cand}, derated $weightmult";
146 $vote->{Weight} /= $derate;
150 delete %sorted->{ $s->{Cand} };
151 delete $continuing{ $s->{Cand} };
153 $need_to_transfer_surplus = 0;
154 # before actually transferring a surplus, we will consider
155 # eliminating, and then reconsider with a lower quota
158 # Look for people to eliminate
159 # We eliminate before trying to transfer surpluses
163 # transfer the surplus
164 filterout $topfirst, "candidate was elected";
166 my $elim = $sorted{ $#sorted };
167 printf "%10s eliminated\n", $elim;
168 filterout $elim, "candidate was eliminated";