chiark / gitweb /
stv: wip
[appendix-a6.git] / stv
1 #!/usr/bin/perl -w
2 #
3 # Does STV according to
4 #  http://www.rosenstiel.co.uk/stvrules/av/index.htm
5
6 use strict;
7 use utf8;
8 use autodie;
9 use bigrat;
10
11 # vote is
12 #  { Voter => opaque,
13 #    Prefs => [ list ],
14 #    Weight => 1.0 }
15
16 our $stage=0;
17 our @allvotes;
18
19 our $places = shift @ARGV;
20 die unless $places eq ($places + 0);
21
22 while (<>) {
23     m/^(\w+) ([A-Z]+)$/ or die;
24     my $prefs = $1;
25     my $vote = {
26         Voter => $1,
27         Weight => 1.0,
28         Prefs => (split //, $prefs),
29     };
30     push @allvotes, $vote;
31 }
32
33 sub pr ($) {
34     my ($f) = @_;
35     return sprintf "%10.6f=%-10s", $f, $f;
36 }
37
38 sub votelog ($$) {
39     my ($vote,$m) = @_;
40     push @{ $vote->{Log} }, "stage $stage: $m";
41 }
42
43 sub filterout ($$) {
44     my ($cand, $why) = @_;
45     foreach my $vote (@allvotes) {
46         my $oldprefs = $vote->{Prefs};
47         my @prefs = grep { $_ ne $cand } $oldprefs;
48         next if @prefs == @$oldprefs;
49         votelog $vote, "crossed out candidate $cand: $why";
50     }
51 }
52
53 for (;;) {
54     $stage++;
55
56     my %sorted;
57     # $sorted{firstpref}{Votes} = [ $vote, ... ]
58     # $sorted{firstpref}{Total} = [ $vote, ... ]
59     for my $vote (@allvotes) {
60         next unless @{ $vote->{Prefs} };
61         my $firstpref = $vote->{Prefs}[0];
62         push @{ $sorted{$firstpref}{Votes} }, $vote;
63     }
64     foreach my $firstpref (sort keys %sorted) {
65         foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
66             votelog $vote, "counted $vote->{Weight] for $firstpref";
67             $sorted{$firstpref}{Total} += $vote->{Weight};
68         }
69     }
70     my @sorted = sort {
71         $sorted{$b}{Total} <=> $sorted{$a}{Total};
72     } keys %sorted;
73
74     my $totalvalid = 0;
75     foreach my $firstpref (@sorted) {
76         $sorted{$firstpref}{Total} += $_->{Weight}
77             foreach @{ $sorted{$firstpref}{Votes} };
78         printf "%10s %s\n", $firstpref, pr $sorted{$firstpref}{Total};
79         $totalvalid += $sorted{$firstpref}{Total};
80     }
81     printf "%10s %s\n", 'TOTAL', pr $totalvalid;
82
83     last unless $totalvalid > 0;
84
85     my $quota = $totalvalid / ($places + 1);
86     printf "\nquota = %10s\n", pr $quota;
87
88     my $topfirst = $sorted[0];
89     my $topvoters = $sorted{  }{Weight};
90     my $surplus = $topvoters - $quota;
91     if ($surplus >= 0) {
92         printf "%10s ELECTED\n", $sorted[0];
93
94         # transfer the surplus
95         my $weightmult = $surplus / $topvoters;
96         foreach my $vote (@{ $sorted{$topfirst}{Votes} }) {
97             votelog $vote, "part of surplus of weight $weightmult";
98             $vote->{Weight} *= $weightmult;
99         }
100         filterout $topfirst, "candidate was elected";
101     } else {
102         my $elim = $sorted{ $#sorted };
103         printf "%10s eliminated\n", $elim;
104         filterout $elim, "candidate was eliminated";
105     }
106 }