#!/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 $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);
	$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 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) {
	    vlog $v, "no more preferences, non transferable";
	    push @non_transferable, $v;
	    next;
	}
	if (@$firstprefs > 1) {
	    vlog $v, "splitting due to several equal first preferences";
	    foreach my $fpref (@$firstprefs) {
		my $v2 = {
		    %$v,
		    Weight => $w / @$firstprefs,
		    Prefs => [ [ $fpref ], @{ $v->{Prefs} } ],
                };
		vlog $v, "split for $fpref";
	    }
	    next;
	}
	my $fp = $firstprefs[0];
	my $c = $cands{$fp};
	my $noncont = $c->{NonCont};
	if ($noncont) {
	    vlog $v, "dropping pref $fp, $noncont";
	    sortvallots $v;
	    next;
	}
	vlog $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 $c (values %cand) {
	$c->{Total} = 0;
	$c->{Total} += $_->{Weight} foreach @{ $c->{Voters} };
    }
    foreach my $cand (sort keys %cand) {
	$c = $cands{$cand};
	next if $c->{NonCont};
	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 $e;
    }
    return 0;
}

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

sortballots @allvotes;

for (;;) {
    $stage++;

    my @continuing = grep { !$_->{NonCont} } values %cands;
    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 @maybe_elect = reverse sort total_history_cmp @continuing;
    my $nelect=0;
    for (;;) {
	my $nextc = $maybe_elect[$nelect];

	# We certainly only consider those who meet quota
	last unless $nextc->{Total} >= $quota;
	last unless $nextc->{Total} > $quota && $nextel;
	# ... if equal we can do them one by one, since order
	# does not matter (SLGEO 49 talks about `two or more ... exceeds')

	last if $nelect &&
	    (total_history_cmp $maybe_elect[0], $nextc) > 0;
	# ... only interested in those who compare equal
	# according ot the history (SLGEO 49(2)); NB our history
	# includes the current round.

	$nelect++;
    }

    if ($nelect) {
	my $electcand;
	if ($nelect > 1) {
	    my @all = map { $_->{Cand} } @maybe_elect[0 .. $nelect-1];
	    my $elect = $tie{"@all"}{Win};
	    die "need tie break, want winner from @all" unless defined $win;
	    prf "electing %s due to tie break amongst %s\n",
		$electcand, "@all";
	} else {
	    $electcand = $maybe_elect[0];
	    prf "electing %s\n";
	}

	my $c = $cands{$electcand};
	elect_core $c;
	votelog $_, "helped elect $electcand" 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