4 # The Scottish Local Government Elections Order 2007
13 # Prefs => [ [ CAND, ...], ... ],
15 # We edit Prefs as we go
21 # $cands{CAND}{NonCont} # undef, or Elected or Eliminated
31 if ($opt =~ m/^[A-Z]/) {
32 die "unknown option $_ for $what";
33 } elsif ($opt =~ m/^[a-z]/) {
34 print STDERR "warning (line $.): unknown option $_ for $what\n";
41 foreach $_ (split / /, $') {
42 if (m/^_?[Ss]eats=(\d+)/) {
44 } elsif (m/^_?[Tt]ie=(.*)\>(.*)$/) {
45 my @more = split /\,/, $1;
46 my @less = split /\,/, $2;
47 my @all = join ',', sort (@more, @less);
48 $tie{"@all"}{Win} = $more[0] if @more == 1;
49 $tie{"@all"}{Lose} = $less[0] if @less == 1;
51 unkopt "election", $_;
54 } elsif (m/^(\w+) = (\S*) \|/) {
55 my ($cand,$desc) = @_;
56 unkopt "candidate $cand", $_ foreach split / /, $';
57 $cands{$cand}{Desc} = $desc;
58 } elsif (m/^(\w*) :\s*(.*)\s*\|(.*)/) {
59 my ($voter,$prefs,$opts) = ($1,$2,$3);
60 $v = { Voter => $voter };
61 push @{ $v->{Prefs} }, [ $_ =~ m/\w+/g ]
62 foreach split /\s+/, $prefs;
63 foreach $_ (split / /, $opts) {
64 if (m/^_?[Ww]eight=(\d+)/(\d+)$/) {
65 $v->{Weight} = $1 / $2;
66 } elsif (m/^_?[Ww]eight=([0-9.]+)$/) {
67 $v->{Weight} = new Math::BigRat $1;
69 unkopt "voter $v->{Voter}", $_;
80 $cands{$_}{Cand} = $_foreach keys %cands;
83 # Takes each argument, which should be a ballot, sorts
84 # it into $cand{CAND}{Votes} according to first preference.
85 # Strips that first preference from the ballot.
86 # If the first preference has been eliminated, strips it
87 # and looks for further preferences.
89 my $firstprefs = shift @{ $v->{Prefs} };
91 if (!$firstprefs || !@$firstprefs) {
92 vlog $v, "no more preferences, non transferable";
93 push @non_transferable, $v;
96 if (@$firstprefs > 1) {
97 vlog $v, "splitting due to several equal first preferences";
98 foreach my $fpref (@$firstprefs) {
101 Weight => $w / @$firstprefs,
102 Prefs => [ [ $fpref ], @{ $v->{Prefs} } ],
104 vlog $v, "split for $fpref";
108 my $fp = $firstprefs[0];
110 my $noncont = $c->{NonCont};
112 vlog $v, "dropping pref $fp, $noncont";
116 vlog $v, "sorted into pile for candidate $fp weight $w";
117 push @{ $c->{Votes} }, $v;
123 printf "stage %d: ".$_, $stage, @_;
126 sub countballots () {
127 foreach my $c (values %cand) {
129 $c->{Total} += $_->{Weight} foreach @{ $c->{Voters} };
131 foreach my $cand (sort keys %cand) {
133 next if $c->{NonCont};
134 prf "cand %s: %s votes\n", $stage, $cand, $c->{Total};
135 $c->{History}[$stage-1] = $c->{Total};
139 sub computequota () {
141 $totalvalid += $_->{Total} foreach keys %cands;
142 $quota = floor($totalvalid / (1 + $seats));
145 sub total_history_cmp () {
146 my $ha = $a->{History};
147 my $hb = $b->{History};
148 foreach my $s (reverse 1 .. $stage) {
149 my $d = $ha->[$s] <=> $hb->[$s];
151 print DEBUG "history cmp $a->{Cand} $b->[Cand}"
152 ." => $d (#$s $ha->[$s] $hb->[$s])\n";
159 grep { !$_->{NonCont} } values %cands;
162 sub select_best_worst ($$$$) {
163 my ($wantcand, $wanttiebreak, $signum, $what) = @_;
164 # $wantcand->($c) = boolish
165 # $wanttiebreak->($total) = boolish
166 # Firstly candidates not meeting $wantcand are ignored
167 # Then we pick the best (worst) candiate by Total (or vote history).
168 # (SLGEO 49(2) and 51(2).
169 # If this does not help then totals are equal and we call wanttiebreak.
170 # If it returns 0 we return alphabetically first CAND. Otherwise
173 my @maybe = grep { $wantcand->($_) } @continuing;
174 @maybe = sort total_history_cmp @maybe;
175 @maybe = reverse @maybe if $signum > 0;
177 return undef unless @maybe;
182 my $nextc = $maybe[$nequal];
184 # Only interested in those who compare equal according to the
185 # history (SLGEO 49(2)); NB our history includes the current
187 last if $signum*(total_history_cmp $maybe[0], $nextc) > 0;
191 if ($nequal > 1 && !$wanttiebreak->($maybe[0]{Total})) {
192 # ... if equal for election we can do them one by one, since
193 # order does not matter (SLGEO 49 talks about `two or more
200 my @all = map { $_->{Cand} } @maybe_elect[0 .. $nelect-1];
201 my $tiekey = $signum > 0 ? 'Win' : 'Lose';
202 my $win = $tie{"@all"}{$tiekey};
203 die "need tie break, want $tiekey from @all" unless defined $win;
204 prf "$what %s due to tie break amongst %s\n",
207 $selectcand = $maybe[0];
211 return $cands{$electcand};
216 prf "*** ELECT %s \`%s' ***\n", $c->{Cand}, $c->{Desc};
217 $c->{NonCont} = 'Elected';
220 sortballots @allvotes;
225 my $seats_remain = $seats
226 - grep { $_->{NonCont} eq 'Elected' } values %cands;
227 if (continuing() <= $seats_remain) {
228 foreach my $c (continuing()) {
229 prf "electing %s to fill remaining place(s)\n", $c->{Cand};
237 my $c = select_best_worst
238 sub { $_->{Total} >= $quota },
244 votelog $_, "helped elect $c->{Cand}" foreach @{ $c->{Votes} };
247 my $surplus = $c->{Total} - $quota;
254 my $B = $c->{Weight};
256 foreach my $v (@{ $c->{Votes} }) {
257 my $A = $surplus * $v->{Weight};
259 my $xfervalue = floor(($A * $F) / $B) / $f;
260 # SLGEO 48(3): we do arithmetic to 5 d3ecimal places,
261 # but always rounding down
262 votelog $v, "transferring with value $xfervalue (A=$A B=$B)";
263 $v->{Weight} = $xfervalue;
266 $c->{Votes} = { }; # will crash if we access it again
270 # No-one to elect, must eliminate
271 my $c = select_best_worst
277 prf "=== eliminating %s (%s) ===\n", $c->{Cand}, $c->{Desc};
278 $c->{NonCont} = 'Eliminated';