--- /dev/null
+#!/usr/bin/perl -w
+#
+# Does STV according to
+# http://www.rosenstiel.co.uk/stvrules/av/index.htm
+
+use strict;
+use utf8;
+use autodie;
+use bigrat;
+
+# vote is
+# { Voter => opaque,
+# Prefs => [ list ],
+# Weight => 1.0 }
+
+our $stage=0;
+our @allvotes;
+
+our $places = shift @ARGV;
+die unless $places eq ($places + 0);
+
+while (<>) {
+ m/^(\w+) ([A-Z]+)$/ or die;
+ my $prefs = $1;
+ my $vote = {
+ Voter => $1,
+ Weight => 1.0,
+ Prefs => (split //, $prefs),
+ };
+ push @allvotes, $vote;
+}
+
+sub pr ($) {
+ my ($f) = @_;
+ return sprintf "%10.6f=%-10s", $f, $f;
+}
+
+sub votelog ($$) {
+ my ($vote,$m) = @_;
+ 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";
+ }
+}
+
+for (;;) {
+ $stage++;
+
+ my %sorted;
+ # $sorted{firstpref}{Votes} = [ $vote, ... ]
+ # $sorted{firstpref}{Total} = [ $vote, ... ]
+ for my $vote (@allvotes) {
+ next unless @{ $vote->{Prefs} };
+ my $firstpref = $vote->{Prefs}[0];
+ push @{ $sorted{$firstpref}{Votes} }, $vote;
+ }
+ foreach my $firstpref (sort keys %sorted) {
+ foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
+ votelog $vote, "counted $vote->{Weight] for $firstpref";
+ $sorted{$firstpref}{Total} += $vote->{Weight};
+ }
+ }
+ my @sorted = sort {
+ $sorted{$b}{Total} <=> $sorted{$a}{Total};
+ } keys %sorted;
+
+ my $totalvalid = 0;
+ foreach my $firstpref (@sorted) {
+ $sorted{$firstpref}{Total} += $_->{Weight}
+ foreach @{ $sorted{$firstpref}{Votes} };
+ printf "%10s %s\n", $firstpref, pr $sorted{$firstpref}{Total};
+ $totalvalid += $sorted{$firstpref}{Total};
+ }
+ printf "%10s %s\n", 'TOTAL', pr $totalvalid;
+
+ last unless $totalvalid > 0;
+
+ my $quota = $totalvalid / ($places + 1);
+ printf "\nquota = %10s\n", pr $quota;
+
+ my $topfirst = $sorted[0];
+ my $topvoters = $sorted{ }{Weight};
+ my $surplus = $topvoters - $quota;
+ if ($surplus >= 0) {
+ printf "%10s ELECTED\n", $sorted[0];
+
+ # transfer the surplus
+ my $weightmult = $surplus / $topvoters;
+ foreach my $vote (@{ $sorted{$topfirst}{Votes} }) {
+ votelog $vote, "part of surplus of weight $weightmult";
+ $vote->{Weight} *= $weightmult;
+ }
+ filterout $topfirst, "candidate was elected";
+ } else {
+ my $elim = $sorted{ $#sorted };
+ printf "%10s eliminated\n", $elim;
+ filterout $elim, "candidate was eliminated";
+ }
+}