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     next if m/^\w+$/;
  24     m/^(\w+) ([A-Z]+)$/ or die "$_ ?";
  25     my $prefs = $1;
  26     my $vote = {
  27         Voter => $1,
  28         Weight => 1.0,
  29         Prefs => [ split //, $prefs ],
  30     };
  31     push @allvotes, $vote;
  32 }
  33
  34 sub pr ($) {
  35     my ($f) = @_;
  36     return sprintf "%10.6f=%-10s", $f, $f;
  37 }
  38
  39 sub votelog ($$) {
  40     my ($vote,$m) = @_;
  41     push @{ $vote->{Log} }, "stage $stage: $m";
  42 }
  43
  44 sub filterout ($$) {
  45     my ($cand, $why) = @_;
  46     foreach my $vote (@allvotes) {
  47         my $oldprefs = $vote->{Prefs};
  48         my @prefs = grep { $_ ne $cand } $oldprefs;
  49         next if @prefs == @$oldprefs;
  50         votelog $vote, "crossed out candidate $cand: $why";
  51     }
  52 }
  53
  54 for (;;) {
  55     $stage++;
  56
  57     my %sorted;
  58     # $sorted{firstpref}{Votes} = [ $vote, ... ]
  59     # $sorted{firstpref}{Total} = [ $vote, ... ]
  60     for my $vote (@allvotes) {
  61         next unless @{ $vote->{Prefs} };
  62         my $firstpref = $vote->{Prefs}[0];
  63         push @{ $sorted{$firstpref}{Votes} }, $vote;
  64     }
  65     foreach my $firstpref (sort keys %sorted) {
  66         foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
  67             votelog $vote, "counted $vote->{Weight} for $firstpref";
  68             $sorted{$firstpref}{Total} += $vote->{Weight};
  69         }
  70     }
  71     my @sorted = sort {
  72         $sorted{$b}{Total} <=> $sorted{$a}{Total};
  73     } keys %sorted;
  74
  75     my $totalvalid = 0;
  76     foreach my $firstpref (@sorted) {
  77         $sorted{$firstpref}{Total} += $_->{Weight}
  78             foreach @{ $sorted{$firstpref}{Votes} };
  79         printf "%10s %s\n", $firstpref, pr $sorted{$firstpref}{Total};
  80         $totalvalid += $sorted{$firstpref}{Total};
  81     }
  82     printf "%10s %s\n", 'TOTAL', pr $totalvalid;
  83
  84     last unless $totalvalid > 0;
  85
  86     my $quota = $totalvalid / ($places + 1);
  87     printf "\nquota = %10s\n", pr $quota;
  88
  89     my $topfirst = $sorted[0];
  90     my $topvoters = $sorted{$topfirst}{Weight};
  91     my $surplus = $topvoters - $quota;
  92     if ($surplus >= 0) {
  93         printf "%10s ELECTED\n", $sorted[0];
  94
  95         # transfer the surplus
  96         my $weightmult = $surplus / $topvoters;
  97         foreach my $vote (@{ $sorted{$topfirst}{Votes} }) {
  98             votelog $vote, "part of surplus of weight $weightmult";
  99             $vote->{Weight} *= $weightmult;
 100         }
 101         filterout $topfirst, "candidate was elected";
 102     } else {
 103         my $elim = $sorted{ $#sorted };
 104         printf "%10s eliminated\n", $elim;
 105         filterout $elim, "candidate was eliminated";
 106     }
 107 }