#!/usr/bin/perl
#require 5.010;
my $THIS = "calc_bonus_bookmark_point.pl";
my $VERSION = "0.03"; # Time-stamp: "2011-03-31T03:20:13Z"

## License:
##
##   I in a provincial state made this program intended to be public-domain. 
##   But it might be better for you like me to treat this program as such 
##   under the BSD-License or under the Artistic License.
##
## Author's Link:
##
##   http://jrf.cocolog-nifty.com/column/2011/03/post.html
##   (The page is written in Japanese.)
##

use utf8; # Japanese
use strict;
use warnings;

use Encode;
use URI;
use XML::Parser;
use HTML::Entities;
use Time::Piece;
use Time::Seconds;

use Getopt::Long;

our $DEBUG = 0;
our $BOOKMARKS = glob "~/doc/diary/jrf-bookmark.atom.xml";
#our $BOOKMARKS = "test.atom.xml";
our $FUND;
our $HATENA_TAX = 0.05;
our $BONUS_PENSION_RATIO = 1.0 / 2.0;
our @PENSION;
our $PENSION_FEE = 5;
our $ID_CONDENSER = 0.05;
our $ID_PRESCRIPTION = 15 * ONE_YEAR;
#our $ID_PRESCRIPTION = 1 * ONE_DAY;

our $CUR_TIME = Time::Piece::localtime();

our %UNIFY;
our %UNIFY_DATE;
our %UNIFY_REQ_DATE;

for my $l
  (
   ["http://blog.livedoor.jp/dankogai/" => "dankogai"],
   ["http://transact.seesaa.net/" => "kumicit"],
   ["http://watcher.moe-nifty.com/" => "tsupo"],
   ["http://www.macska.org/" => "macska"],
   ["http://twitter.com/emigrl/" => "macska"],
   ["http://finalvent.cocolog-nifty.com/" => "finalvent"],
   ["http://twitter.com/finalvent/" => "finalvent"],
   ["http://himagine9.cocolog-nifty.com/" => "himagine_no9"],
   ["http://twitter.com/himagine_no9/" => "himagine_no9"],
   ["http://informatics.cocolog-nifty.com/" => "infobloga"],
   ["http://benli.cocolog-nifty.com/" => "OguraHideo"],
  ) {
  register_url_table($l->[0], $l->[1], undef);
}

our $ID_PAT = qr([-a-zA-Z01-9_]+);

Getopt::Long::Configure("bundling", "auto_version");
GetOptions(
	   "f=s" => \$BOOKMARKS,
	   "t=s" => \$HATENA_TAX,
	   "pension=s" => \@PENSION,
	   "ratio=s" => \$BONUS_PENSION_RATIO,

	   "debug|d:1" => \$DEBUG,
	   "h|help" => sub { usage(0); },
	  );

sub usage {
  my ($ext) = @_ || 0;
  print <<"EOU";
Usage: $0 -f [BOOKMARK_XML] [FUND]

OPTIONS:
  -f BOOKMARK_XML       The bookmark log exported in Atom Feed form.
  -t HATENA_TAX         The rate of Hatena point charge.
  --pension=ID1,ID2,... Requested IDs for pension.
EOU
  exit($ext);
}

if (@ARGV > 0) {
  $FUND = $ARGV[0];
} else {
  usage(1);
}

sub uniq {
  my %x;
  my @r;
  foreach my $a (@_) {
    push(@r, $a) if ! exists $x{$a};
    $x{$a} = 1;
  }
  return @r;
}

my %URL_TABLE;
sub register_url_table {
  my ($_url, $id, $date) = @_;

  my $url = URI->new($_url);
  $URL_TABLE{$url->host()} = [] if ! exists $URL_TABLE{$url->host()};
  push(@{$URL_TABLE{$url->host()}}, [$_url, $id, $date]);
}

sub lookup_url_table {
  my ($_url) = @_;
  my $url = URI->new($_url);
  return () if ! exists $URL_TABLE{$url->host()};
  foreach my $l (@{$URL_TABLE{$url->host()}}) {
    my $u = $l->[0];
    return ($l->[1], $l->[2]) if substr($_url, 0, length($u)) eq $u;
  }
  return ();
}

sub hatena_id_from_url {
  my ($url) = @_;
  if ($url =~ /^http:\/\/[a-z\.]+\.hatena\.ne\.jp\/($ID_PAT)\//) {
    return $1;
  } else {
    return undef;
  }
}

sub strptime_UTC {
  my ($s) = @_;
  my $tz = 0;
  if ($s =~ s/Z$//) {
    $tz = 0;
  } elsif ($s =~ s/([+-][012]?[01-9])\:?([01-9][01-9])$//) {
    $tz = $1 * ONE_HOUR + $2 * ONE_MINUTE;
  }
  return Time::Piece->strptime($s, "%Y-%m-%dT%T") + $tz;
}

sub date_compare {
  my ($_a, $_b) = @_;
  my $a = (ref $_a)? $_a : strptime_UTC($_a);
  my $b = (ref $_b)? $_b : strptime_UTC($_b);
  return $a - $b;
}

MAIN:
{
  my @ENTRIES;
  my %BASE;
  my %BONUS;
  my %PENSION;
  my %PENSION_PLAN;
  my %PAID_BASE;
  my %PAID_BONUS;

  my $cur = {};
  my $cur_str;

  sub start_handler {
    shift;
    my ($tag, @rest) = @_;
    if (lc($tag) eq "link") {
#      print $tag . "->\n";
      my %attr = @rest;
      if (exists $attr{rel} && $attr{rel} eq "related") {
	$cur->{url} = decode_entities($attr{href});
      }
    }
    $cur_str = undef;
  }

  sub end_handler {
    shift;
    my ($tag) = @_;
    if (lc($tag) eq "dc:subject") {
      if (defined $cur_str) {
	if ($cur_str =~ /^(\d+)p$/) {
	  $cur->{point} = $1;
	} elsif ($cur_str =~ /^b(\d+)p$/) {
	  $cur->{bonus} = $1;
	} elsif ($cur_str =~ /^p(\d+)p$/) {
	  $cur->{pension} = $1;
	} elsif ($cur_str =~ /^u(\d+)p$/) {
	  $cur->{unpaid_partially} = $1;
	} elsif ($cur_str =~ /^n(\d+)p$/) {
	  $cur->{not_payable_partially} = $1;
	} elsif ($cur_str =~ /ポイント/) {
	  $cur->{state} = $cur_str;
	} elsif ($cur_str =~ /ペンション/) {
	  $cur->{pension_plan} = $cur_str;
	}
      }
    } elsif (lc($tag) eq "issued") {
      $cur->{date} = $cur_str;
    } elsif (lc($tag) eq "summary") {
      $cur->{summary} = $cur_str;
    } elsif (lc($tag) eq "entry") {
      if (defined $cur->{summary}) {
	my $s = $cur->{summary};
	$s =~ s/^\s+//;
	while ($s ne "") {
	  if ($s =~ s/^\(?(?:はてなでは\s*)?($ID_PAT)\s*氏\)?\s*//) {
	    $s = $';
	    $cur->{id} = $1;
	  } elsif ($s =~ s/^\(処理用別名\s*\*($ID_PAT)\s*氏?\)\s*//) {
	    $s = $';
	    $cur->{id} = "*" . $1;
	  } elsif ($s =~ s/^\(ID\s*統合申請→\s*($ID_PAT)\s*\)\s*//) {
	    $s = $';
	    my $uid = $1;
	    my $id;
	    $id = $cur->{id} if exists $cur->{id};
	    $id = hatena_id_from_url($cur->{url}) if ! defined $id;

	    if (! defined $id) {
	      warn "Illegal request for unifying $uid of $cur->{url}\n";
	      next;
	    }
	    $UNIFY{$id} = $uid;
	    $UNIFY_REQ_DATE{$id} = $cur->{date};
	  } elsif ($s =~ s/^\(受取申請\s*([^\)]+)\)\s*//) {
	    $s = $';
	    my @url = split(/,\s*/, $1);
	    my $id;
	    $id = $cur->{id} if exists $cur->{id};
	    $id = hatena_id_from_url($cur->{url}) if ! defined $id;

	    if (! @url || ! defined $id) {
	      warn "Illegal point request: $cur->{url}\n";
	      next;
	    }
	    foreach my $u (@url) {
	      $u =~ s/^\s+//;
	      $u =~ s/\s+$//;
	      register_url_table($u, $id, $cur->{date}) if $u ne "";
	    }
	  } else {
	    last;
	  }
	}
      }

      if ($DEBUG > 1) {
	print "entry \n";
	foreach my $k (sort keys %$cur) {
	  print "  $k  = $cur->{$k}\n";
	}
      }

      push(@ENTRIES, $cur);

      $cur ={};
    }
    $cur_str = undef;
  }

  open(my $fh, "<", $BOOKMARKS) or die $!;
  binmode($fh, ":encoding(utf8)");
  my $parser = new XML::Parser;
  $parser->setHandlers(
		       Start => \&start_handler,
		       Char => sub {shift;
				    $cur_str = decode_entities($_[0])},
		       End => \&end_handler,
		      );
  $parser->parse(join("", <$fh>));
  close($fh);

  foreach my $entry (@ENTRIES) {
    my $hid = hatena_id_from_url($entry->{url});
    my ($lid, $ldate) = lookup_url_table($entry->{url});
    my $eid;
    $eid = $entry->{id} if exists $entry->{id};
    $eid = $lid if ! defined $eid;
    $eid = $hid if ! defined $eid;
    $entry->{id} = $eid if defined $eid;
    $hid = $lid if defined $lid && ! defined $ldate;

    if (defined $ldate
	&& exists $UNIFY_REQ_DATE{$lid}
	&& date_compare($UNIFY_REQ_DATE{$lid}, $ldate) > 0) {
      $UNIFY_REQ_DATE{$lid} = $ldate;
      if (exists $UNIFY_DATE{$lid}
	  && date_compare($UNIFY_DATE{$lid}, $ldate) > 0) {
	delete $UNIFY_DATE{$lid};
      }
    }

    if (defined $eid
	&& exists $UNIFY_REQ_DATE{$eid}
	&& date_compare($UNIFY_REQ_DATE{$eid}, $entry->{date}) > 0) {
      if (! exists $UNIFY_DATE{$eid}
	  || (defined $hid
	      && date_compare($UNIFY_DATE{$eid}, $entry->{date}) > 0)
	  || (! defined $hid
	      && date_compare($entry->{date}, $UNIFY_DATE{$eid}) > 0)) {
	$UNIFY_DATE{$eid} = $entry->{date};
      }
    }
  }

  foreach my $id (keys %UNIFY_REQ_DATE) {
    $UNIFY_DATE{$id} = $UNIFY_REQ_DATE{$id} if ! exists $UNIFY_DATE{$id};
  }

  foreach my $entry (@ENTRIES) {
    if (exists $entry->{id}) {
      my $id = $entry->{id};
      if (exists $UNIFY_DATE{$id}
	  && date_compare($CUR_TIME, strptime_UTC($UNIFY_DATE{$id})
			  + $ID_PRESCRIPTION) > 0) {
	$entry->{id} = $UNIFY{$id};
      }
    }
  }

  foreach my $entry (@ENTRIES) {
    next if ! exists $entry->{state};

    my $unpaid;
    my $paid_base;
    my $paid_bonus;
    my $paid_pension;

    if ($entry->{state} eq "IDポイント未送") {
      if (! defined $entry->{id}) {
	warn "Id is unknown for $entry->{url}\n";
	next;
      }
      if (! exists $entry->{point}) {
	warn "Point is unknown for $entry->{url}\n";
	next;
      }
      $unpaid = $entry->{point};
    } elsif ($entry->{state} eq "IDポイント一部未送") {
      if (! defined $entry->{id}) {
	warn "Id is unknown for $entry->{url}\n";
	next;
      }
      if (! exists $entry->{point}) {
	warn "Point is unknown for $entry->{url}\n";
	next;
      }
      if (! exists $entry->{unpaid_partially}) {
	warn "Unpaid point is unknown for $entry->{url}\n";
	next;
      }
      $unpaid = $entry->{unpaid_partially};
      $paid_base = $entry->{point} - $unpaid;
    } elsif ($entry->{state} eq "IDポイント済"
	     || $entry->{state} eq "ポイント済") {
      if (! exists $entry->{id}) {
	warn "Id is unknown of $entry->{url}\n";
	next;
      }
      $paid_base = $entry->{point};
    } elsif ($entry->{state} eq "IDポイント一部不可"
	    || $entry->{state} eq "ポイント一部不可") {
      if (! exists $entry->{id}) {
	warn "Id is unknown of $entry->{url}\n";
	next;
      }
      if (! exists $entry->{not_payable_partially}) {
	warn "Not-payable point is unknown for $entry->{url}\n";
	next;
      }
      $paid_base = $entry->{point} - $entry->{not_payable_partially};
    }
    if (defined $unpaid) {
      $BASE{$entry->{id}} = 0 if ! exists $BASE{$entry->{id}};
      $BASE{$entry->{id}} += $unpaid;
    }
    if (defined $paid_base) {
      if ((! exists $entry->{pension_plan})
	  || $entry->{pension_plan} ne "ペンション除外") {
	$PAID_BASE{$entry->{id}} = 0 if ! exists $PAID_BASE{$entry->{id}};
	$PAID_BASE{$entry->{id}} += $paid_base;
      }
      $PAID_BONUS{$entry->{id}} = 0 if ! exists $PAID_BONUS{$entry->{id}};
      $PAID_BONUS{$entry->{id}} += $entry->{bonus} if exists $entry->{bonus};
      $PAID_BONUS{$entry->{id}} += $entry->{pension} if exists $entry->{pension};
      if (exists $entry->{pension_plan}
	  && $entry->{pension_plan} eq "ペンション登録") {
	$PENSION_PLAN{$entry->{id}} = 0
	  if ! exists $PENSION_PLAN{$entry->{id}};
	$PENSION_PLAN{$entry->{id}} += $paid_base;
      }
    }
  }

  my $bonus_fund = ($BONUS_PENSION_RATIO / (1 + $BONUS_PENSION_RATIO))
    * $FUND / (1 + $HATENA_TAX);

  my $sqrt_total = 0;
  foreach my $id (keys %BASE) {
    $sqrt_total += sqrt($BASE{$id});
  }
  my $bonus_total = 0;
  my $tax_total = 0;
  my $min_bonus_rate;
  foreach my $id (keys %BASE) {
    my $b = $bonus_fund * sqrt($BASE{$id}) / $sqrt_total;
    $b = int($b / 10) * 10;
    $BONUS{$id} = $b if $b > 0;
    $bonus_total += $b;
    $min_bonus_rate = $b / $BASE{$id}
      if ! defined $min_bonus_rate || $min_bonus_rate > $b / $BASE{$id};
    $tax_total += int(($b + $BASE{$id}) * $HATENA_TAX) - int($BASE{$id} * $HATENA_TAX) if $b > 0;
  }

  foreach my $id (keys %BONUS) {
    $PAID_BONUS{$id} = 0 if ! exists $PAID_BONUS{$id};
    $PAID_BONUS{$id} += $BONUS{$id};
  }

  my $pension_fund = ($FUND - $bonus_total - $tax_total) / (1 + $HATENA_TAX);
  @PENSION = map {split(/\s*,\s*/, $_)} (@PENSION);
  foreach my $id (@PENSION) {
    if (exists $PENSION_PLAN{$id}) {
      $PENSION_PLAN{$id} = $PAID_BASE{$id};
    }
  }
  @PENSION = uniq(@PENSION, keys %PENSION_PLAN);

  my $paid_base_total = 0;
  foreach my $id (keys %PAID_BASE) {
    $paid_base_total += $PAID_BASE{$id};
  }
  foreach my $id (@PENSION) {
    if (exists $PAID_BASE{$id}) {
      my $b = $PAID_BASE{$id};
      $b = $PENSION_PLAN{$id} if exists $PENSION_PLAN{$id};
      my $p = $pension_fund * $b / $paid_base_total;
      my $limit = ($b ** (1 + $ID_CONDENSER)) * $min_bonus_rate;
      if ($p + $PAID_BONUS{$id} > $limit) {
	$p = $limit - $PAID_BONUS{$id};
      }
      $p = int($p);
      my $f = 0;
      $f = $PENSION_FEE if exists $PENSION_PLAN{$id};
      $PENSION{$id} = $p if $p > $f;
    }
  }
  my $pension_total = 0;
  foreach my $id (keys %PENSION) {
    my $f = 0;
    $f = $PENSION_FEE if exists $PENSION_PLAN{$id};
    $pension_total += $PENSION{$id} - $f;
    my $o = 0;
    $o += $BASE{$id} if exists $BASE{$id};
    $o += $BONUS{$id} if exists $BONUS{$id};
    $tax_total += int(($o + $PENSION{$id} - $f) * $HATENA_TAX)
      - int($o * $HATENA_TAX);
  }

  print "RESULT:\n";
  my %RESULT;
  my %PAY;
  foreach my $id (keys %BASE) {
    $RESULT{$id} = "" if ! exists $RESULT{$id};
    $RESULT{$id} .= " " . $BASE{$id} . "p";
    $PAY{$id} = 0 if ! exists $PAY{$id};
    $PAY{$id} += $BASE{$id};
  }
  foreach my $id (keys %BONUS) {
    $RESULT{$id} = "" if ! exists $RESULT{$id};
    $RESULT{$id} .= " b" . $BONUS{$id} . "p";
    $PAY{$id} = 0 if ! exists $PAY{$id};
    $PAY{$id} += $BONUS{$id};
  }
  foreach my $id (keys %PENSION) {
    $RESULT{$id} = "" if ! exists $RESULT{$id};
    $RESULT{$id} .= " p" . $PENSION{$id} . "p";
    $PAY{$id} = 0 if ! exists $PAY{$id};
    my $f = 0;
    $f = $PENSION_FEE if exists $PENSION_PLAN{$id};
    $PAY{$id} += $PENSION{$id} - $f;
  }

  foreach my $id (sort keys %RESULT) {
    print " $id  $PAY{$id}  ($RESULT{$id} )\n";
  }

  print "--\n";
  print "  BONUS  $bonus_total\n";
  print "  PENSION  $pension_total\n";
  print "  TAX  $tax_total\n";
  print "  REST  " . ($FUND - $bonus_total - $tax_total - $pension_total) . "\n";

  my $base_total = 0;
  foreach my $id (keys %BASE) {
    $base_total += $BASE{$id};
  }
  my $base_tax = int($base_total * $HATENA_TAX);
  my $total = $base_total + $base_tax
    + $bonus_total + $pension_total + $tax_total;

  print "  BASE  $base_total + tax $base_tax\n";
  print "  TOTAL  $total\n";
}

## 受取申請 and ID統合申請 are not tested well, because they have been unnecessary so far.

## Translation Example:
##   ポイント -> point
##   ペンション -> pension
##   未送 -> unpaid
##   済 -> paid
##   不可 -> not payable
##   登録 -> registered
##   除外 -> excluded
##   一部未送 -> unpaid partially
##   一部不可 -> not payable partially
##   はてなでは XXX 氏 -> XXX in Hatena
##   受取申請 -> (recipient) application
##   ID統合申請 -> (application of) ID unification