#!/usr/bin/perl -w

# Reference:
# The Scottish Local Government Elections Order 2007

use strict;
use bigrat;

# Data structures:
#
# vote is
#   { Voter => opaque,
#     Prefs => [ [ CAND, ...], ... ],
#     Weight => 1.0 }
# We edit Prefs as we go

# $cands{CAND}{Cand}
# $cands{CAND}{Desc}
# $cands{CAND}{Votes}
# $cands{CAND}{Total}
# $cands{CAND}{NonCont} # undef, or Elected or Eliminated

our $seats=0;

our @allvotes;
our @non_transferable;
our %cands;
our $stage=0;
our $quota;
our %tie;

sub unkopt ($$) {
    my ($what,$opt) = @_;
    if ($opt =~ m/^[A-Z]/) {
	die "unknown option $_ for $what";
    } elsif ($opt =~ m/^[a-z]/) {
	print STDERR "warning (line $.): unknown option $_ for $what\n";
    }
}

for (;;) {
    $_ = <>;
    if (m/^\| /) {
	foreach $_ (split / /, $') {
	    if (m/^_?[Ss]eats=(\d+)/) {
		$seats = $1;
	    } elsif (m/^_?[Tt]ie=(.*)\>(.*)$/) {
		my @more = split /\,/, $1;
		my @less = split /\,/, $2;
		my @all = join ',', sort (@more, @less);
		$tie{"@all"}{Win}  = $more[0] if @more == 1;
		$tie{"@all"}{Lose} = $less[0] if @less == 1;
	    } else {
		unkopt "election", $_;
	    }
	}
    } elsif (m/^(\w+) = (\S*) \|/) {
	my ($cand,$desc) = @_;
	unkopt "candidate $cand", $_ foreach split / /, $';
	$cands{$cand}{Desc} = $desc;
    } elsif (m/^(\w*) :\s*(.*)\s*\|(.*)/) {
	my ($voter,$prefs,$opts) = ($1,$2,$3);
	my $v = { Voter => $voter };
	push @{ $v->{Prefs} }, [ $_ =~ m/\w+/g ]
	    foreach split /\s+/, $prefs;
	foreach $_ (split / /, $opts) {
	    if (m/^_?[Ww]eight=(\d+)\/(\d+)$/) {
		$v->{Weight} = $1 / $2;
	    } elsif (m/^_?[Ww]eight=([0-9.]+)$/) {
		$v->{Weight} = new Math::BigRat $1;
	    } else {
		unkopt "voter $v->{Voter}", $_;
	    }
	}
	push @allvotes, $v;
    } elsif (m/^\.$/) {
	last;
    } else {
	die "$_ ?";
    }
}

$cands{$_}{Cand} = $_ foreach keys %cands;

sub votelog ($$) {
    my ($vote,$m) = @_;
    push @{ $vote->{Log} }, "stage $stage: $m";
}

sub sortballots (@) {
    # Takes each argument, which should be a ballot, sorts
    # it into $cand{CAND}{Votes} according to first preference.
    # Strips that first preference from the ballot.
    # If the first preference has been eliminated, strips it
    # and looks for further preferences.
    foreach my $v (@_) {
	my $firstprefs = shift @{ $v->{Prefs} };
	my $w = $v->{Weight};
	if (!$firstprefs || !@$firstprefs) {
	    votelog $v, "no more preferences, non transferable";
	    push @non_transferable, $v;
	    next;
	}
	if (@$firstprefs > 1) {
	    votelog $v, "splitting due to several equal first preferences";
	    foreach my $fpref (@$firstprefs) {
		my $v2 = {
		    %$v,
		    Weight => $w / @$firstprefs,
		    Prefs => [ [ $fpref ], @{ $v->{Prefs} } ],
                };
		votelog $v, "split for $fpref";
	    }
	    next;
	}
	my $fp = $firstprefs->[0];
	my $c = $cands{$fp};
	my $noncont = $c->{NonCont};
	if ($noncont) {
	    votelog $v, "dropping pref $fp, $noncont";
	    sortvallots $v;
	    next;
	}
	votelog $v, "sorted into pile for candidate $fp weight $w";
	push @{ $c->{Votes} }, $v;
    }
}

sub prf {
    my $fmt = shift;
    printf "stage %d: ".$_, $stage, @_;
}

sub countballots () {
    foreach my $cand (sort keys %cands) {
	my $c = $cands{$cand};
	next if $c->{NonCont};
	$c->{Total} = 0;
	$c->{Total} += $_->{Weight} foreach @{ $c->{Voters} };
	prf "cand %s: %s votes\n", $stage, $cand, $c->{Total};
	$c->{History}[$stage-1] = $c->{Total};
    }
}

sub computequota () {
    my $totalvalid = 0;
    $totalvalid += $_->{Total} foreach keys %cands;
    $quota = floor($totalvalid / (1 + $seats));
}

sub total_history_cmp () {
    my $ha = $a->{History};
    my $hb = $b->{History};
    foreach my $s (reverse 1 .. $stage) {
	my $d = $ha->[$s] <=> $hb->[$s];
	next unless $d;
	print DEBUG "history cmp $a->{Cand} $b->{Cand}".
	    " => $d (#$s $ha->[$s] $hb->[$s])\n";
	return $d;
    }
    return 0;
}

sub continuing () {
    grep { !$_->{NonCont} } values %cands;
}

sub select_best_worst ($$$$) {
    my ($wantcand, $wanttiebreak, $signum, $what) = @_;
    # $wantcand->($c) = boolish
    # $wanttiebreak->($total) = boolish
    # Firstly candidates not meeting $wantcand are ignored
    # Then we pick the best (worst) candiate by Total (or vote history).
    # (SLGEO 49(2) and 51(2).
    # If this does not help then totals are equal and we call wanttiebreak.
    # If it returns 0 we return alphabetically first CAND.  Otherwise
    # we tie break.

    my @maybe = grep { $wantcand->($_) } continuing();
    @maybe = sort total_history_cmp @maybe;
    @maybe = reverse @maybe if $signum > 0;

    return undef unless @maybe;

    my $nequal = 1;

    for (;;) {
	my $nextc = $maybe[$nequal];

	# Only interested in those who compare equal according to the
	# history (SLGEO 49(2)); NB our history includes the current
	# round.
	
	last if $signum*($a = $maybe[0], $b = $nextc, total_history_cmp) > 0;
	$nextc++;
    }

    if ($nequal > 1 && !$wanttiebreak->($maybe[0]{Total})) {
	# ... if equal for election we can do them one by one, since
	# order does not matter (SLGEO 49 talks about `two or more
	# ... exceeds').
	$nequal = 1;
    }

    my $selectcand;
    if ($nequal > 1) {
	my @all = map { $_->{Cand} } @maybe[0 .. $nequal-1];
	my $tiekey = $signum > 0 ? 'Win' : 'Lose';
	my $win = $tie{"@all"}{$tiekey};
	die "need tie break, want $tiekey from @all" unless defined $win;
	prf "$what %s due to tie break amongst %s\n",
	    $selectcand, "@all";
    } else {
	$selectcand = $maybe[0];
	prf "$what %s\n";
    }

    return $cands{$selectcand};
}

sub elect_core ($) {
    my ($c) = @_;
    prf "*** ELECT %s \`%s' ***\n", $c->{Cand}, $c->{Desc};
    $c->{NonCont} = 'Elected';
}

sortballots @allvotes;

for (;;) {
    $stage++;

    my $seats_remain = $seats
	- grep { $_->{NonCont} eq 'Elected' } values %cands;
    if (continuing() <= $seats_remain) {
	foreach my $c (continuing()) {
	    prf "electing %s to fill remaining place(s)\n", $c->{Cand};
	    elect_core $c;
	}
	last;
    }

    countballots();

    my $c = select_best_worst
	sub { $_->{Total} >= $quota },
	sub { $_ > $quota },
	+1, 'electing';

    if ($c) {
	elect_core $c;
	votelog $_, "helped elect $c->{Cand}" foreach @{ $c->{Votes} };
	
	# SLGEO 48
	my $surplus = $c->{Total} - $quota;

	if ($surplus <= 0) {
	    prf "no surplus\n";
	    next;
	}

	my $B = $c->{Weight};

	foreach my $v (@{ $c->{Votes} }) {
	    my $A = $surplus * $v->{Weight};
	    my $F = 100000;
	    my $xfervalue = floor(($A * $F) / $B) / $F;
	    # SLGEO 48(3): we do arithmetic to 5 d3ecimal places,
	    # but always rounding down
	    votelog $v, "transferring with value $xfervalue (A=$A B=$B)";
	    $v->{Weight} = $xfervalue;
	    sortballots $v;
	}
	$c->{Votes} = { }; # will crash if we access it again
	next;
    }

    # No-one to elect, must eliminate
    $c = select_best_worst
	sub { 1; },
	sub { 1; },
	-1, 'eliminating';

    if ($c) {
	prf "=== eliminating %s (%s) ===\n", $c->{Cand}, $c->{Desc};
	$c->{NonCont} = 'Eliminated';
	next;
    }

    die;
}

print "done.\n";