#!/usr/bin/perl
# ---------------------------------------------
# 
#  Copyright (C) 2002-2008 Guillaume Cottenceau http://zarb.org/~gc/resource/gc_mail.png
# 
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License version 2, as
#  published by the Free Software Foundation.
# 
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
# 
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# 
#
#  (Sparse) documentation at http://zarb.org/~gc/html/tunes.html
#
# ---------------------------------------------

@ARGV = map { /^-?-(\S+)$/ ? do { $options{$1} = 1; () } : $_ } @ARGV;
-r $ARGV[0] or die "Usage: $0 [OPTION]... description_file\n";

sub parse_file {
    my %o = @_;

    my $pay = sub {
	my ($amount, $to, $opts) = @_;
	my @persons = ref($to) eq 'ARRAY' ? @$to : split /\s/, $to;
	my @opts = split /\s/, $opts;
	my @groups = grep { member($_, keys %groups) } @persons;
	if (@groups) {
	    @persons = difference2(\@persons, \@groups);
	    push @persons, @{$groups{$_}} foreach @groups;
	}
        foreach my $opt (@opts) {
            member($opt, keys %currency) and $amount /= $currency{$opt};
        }
	member('each', @opts) or $amount /= int(@persons);
	defined $current_person or print(STDERR "Warning, amount defined before a person zone\n"), return;
	push @{$o{paid}{$current_person}}, [ $_, $amount ] foreach @persons;
    };
    my $declare_person = sub {
	my ($person) = @_;
	member($person, @{$o{people}}) or push @{$o{people}}, $person;
    };

    foreach (cat_($ARGV[0])) {
	s/#.*//;
	next if /^\s*$/;
	/^%(\S+)\s+(.*)/ and do {
	    #- directive
	    if ($1 eq 'group') {
		$2 =~ /^(\S+)\s+(.*)/;
		$groups{$1} = [ split /\s/, $2 ];
		$declare_person->($_) foreach @{$groups{$1}};
		next;
	    }
	    if ($1 eq 'payfor') {
		$2 =~ /^(\S+)\s+(\S+)/;
                $payfor{$1} = $2;
		next;
	    }
            if ($1 eq 'currency') {
                $2 =~ /^(\S+)\s+(\S+)/;
                $currency{$1} = $2;
                next;
            }
	    print STDERR "Unknown directive '$1'\n";
	    next;
	};
	/^(\S+)\s*$/ and do {
	    #- person payments
	    $current_person = $1;
	    $declare_person->($current_person);
	    next;
	};
	/^\s+(.*)/ and do {
	    #- payment line
	    if ($1 =~ /^\s*([\d,\.]+)\s*(\s+.*)?$/) {
		#- pays for all people
		$pay->($1, $o{people}, $2);
		next;
	    } elsif ($1 =~ /^\s*(\S.*)\s+([\d,\.]+)\s*(\s+.*)?$/) {
		#- pays for one person or a group
		$pay->($2, $1, $3);
		next;
	    }
	    next;
	};
    }
    %o;
}


#- first pass to discover all the people
my %results = parse_file();

#- second pass to divide amounts correctly among all the previously-discovered people
%results = parse_file(people => $results{people});

#- compute owes
#- 1. sum per-person owes
foreach my $p (@{$results{people}}) {
    foreach my $paid (@{$results{paid}{$p}}) {
	$paid->[0] eq $p and next;
	$results{paid_total}{$p} += $paid->[1];
	$results{owes}{$paid->[0]}{$p} += $paid->[1];
    }
}
#- 2. substract one-to-one owes
foreach my $a (@{$results{people}}) {
    foreach my $b (keys %{$results{owes}{$a}}) {
	if (exists $results{owes}{$b}{$a}) {
	    my $owa = \$results{owes}{$b}{$a};
	    my $owb = \$results{owes}{$a}{$b};
 	    $$owa > $$owb and ($owa, $owb) = ($owb, $owa);
	    $$owb -= $$owa;
	    $results{paid_total}{$_} -= $$owa foreach $a, $b;
	    $$owa = 0;
	}
    }
}

#- display results
@{$results{people}} = sort { $results{paid_total}{$b} <=> $results{paid_total}{$a} } @{$results{people}};
foreach my $p (@{$results{people}}) {
    print "Person $p:\n";
    my $amount_paid = 0;
    $amount_paid += $_->[1] foreach @{$results{paid}{$p}};
    printf            "\tPaid in total:         %7.2f\n", $amount_paid;
    printf            "\tOwed to him/her total: %7.2f\n", $results{paid_total}{$p};
    while (my ($k, $v) = each %{$results{owes}{$p}}) {
        $v and printf "\tOwe to: %-12s   %7.2f\n", $k, $v;
    }
    if ($options{v}) {
        foreach my $paid (@{$results{paid}{$p}}) {
            print "\t\tpaid for $paid->[0]: $paid->[1]\n";
        }
    }
}

#- transmit payments if needed
if (%payfor) {
    foreach my $paying (keys %payfor) {
        my $notpaying = $payfor{$paying};
        $results{paid_total}{$paying} += delete $results{paid_total}{$notpaying};
        my $owes = delete $results{owes}{$notpaying};
        #- transfert owes of $notpaying to others
        foreach my $person (keys %$owes) {
            $results{owes}{$paying}{$person} += $owes->{$person};
        }
        #- transfer owes of others to $notpaying
        foreach my $person (keys %{$results{owes}}) {
            my $owe = $results{owes}{$person};
            $owe->{$paying} += delete $owe->{$notpaying};
        }
        #- an owe of $paying to $paying is some less actually paid by $paying 
        $results{paid_total}{$paying} -= delete $results{owes}{$paying}{$paying};
        #- remove $notpaying from people's list
        @{$results{people}} = difference2($results{people}, [ $notpaying ]);
    }
    delete $results{paid};
    print "\nAfter transfers:\n";
    foreach my $p (@{$results{people}}) {
        print "Person $p:\n";
        while (my ($k, $v) = each %{$results{owes}{$p}}) {
            $v and printf "\tOwe to: %-12s   %7.2f\n", $k, $v;
        }
    }
}

#- propose simpler owes solving
print "\nProposed owes solving:\n";
$results{total_owes}{$_} = sum(values %{$results{owes}{$_}}) foreach @{$results{people}};
$results{balance}{$_} = $results{paid_total}{$_} - $results{total_owes}{$_} foreach @{$results{people}};
my $sort_owes_solving = sub {
    @{$results{people}} = sort { $results{balance}{$b} <=> $results{balance}{$a} } @{$results{people}};
};
$sort_owes_solving->();

$options{v} and do {
    foreach (@{$results{people}}) {
	printf "\t\t%-12s owes totally %7.2f  owed to him/her %7.2f  balance %7.2f\n",
	  $_, $results{total_owes}{$_}, $results{paid_total}{$_}, $results{balance}{$_}
    }
};

while (@{$results{people}} > 1) {
    my $first_p = ${$results{people}}[0];
    my $last_p = ${$results{people}}[-1];
    my $display_movement = sub {
	my ($clears_who) = @_;
	printf "\t%-12s gives %7.2f to $first_p %s\n",
	  $last_p, abs($results{balance}{$clears_who}), $options{v} && "(clears $clears_who out)";
    };
    if (abs($results{balance}{$last_p}) < abs($results{balance}{$first_p})) {
	$display_movement->($last_p);
	$results{balance}{$first_p} += $results{balance}{$last_p};
	pop @{$results{people}};
    } else {
	$display_movement->($first_p);
	$results{balance}{$last_p} += $results{balance}{$first_p};
	shift @{$results{people}};
    }
    $sort_owes_solving->();
}



#- internalize MDK-Common
sub cat_ { my @l = map { my $F; open($F, '<', $_) ? <$F> : () } @_; wantarray() ? @l : join '', @l }
sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 }
sub difference2 { my %l; @l{@{$_[1]}} = (); grep { !exists $l{$_} } @{$_[0]} }
sub sum  { my $n = 0; $n  += $_ foreach @_; $n }