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 }