#!/usr/bin/perl -w

# helper program for determining pixmap resolution options

# This is part of ypp-sc-tools, a set of third-party tools for assisting
# players of Yohoho Puzzle Pirates.
#
# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# 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, see <http://www.gnu.org/licenses/>.
#
# Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
# are used without permission.  This program is not endorsed or
# sponsored by Three Rings.

use strict (qw(vars));
use LWP::UserAgent;
use JSON;
#use Data::Dumper;
use IO::File;

@ARGV>=1 or die "You probably don't want to run this program directly.\n";
our ($which) = shift @ARGV;

$which =~ s/\W//g;

our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'};
our ($ua)= LWP::UserAgent->new;
our $jsonresp;

our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources
our %commods; # eg $commods{'Fine black cloth'}= $sources;
# $sources = 's[l]b';
#       's' = Special Circumstances; 'l' = local ; B = with Bleach

BEGIN {
    my %colours; # eg $colours{'c'}{'black'}= $sources
    my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'

    sub parse_master_master1 ($$) {
	my ($mmfn,$src)= @_;
	my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!";
	my @ctx= ();
	while (<$mm>) {
	    next if m/^\s*\#/;
	    next unless m/\S/;
	    s/\s+$//;
	    if (m/^\%(\w+)$/) {
		my $colourkind= $1;
		@ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
	    } elsif (m/^commods$/) {
		@ctx= (sub { push @rawcm, lc $_; });
	    } elsif (m/^ocean (\w+)$/) {
		my $ocean= $1;
		@ctx= (sub {
			   $ocean or die; # ref to $ocean needed to work
			                  # around a perl bug
			   my $arch= $_;
			   $ctx[1]= sub {
			       $oceans{$ocean}{$arch}{$_} .= $src;
			   };
		       });
	    } elsif (s/^ +//) {
		my $indent= length $&;
		die "wrong indent $indent" unless defined $ctx[$indent-1];
		&{ $ctx[$indent-1] }();
	    } else {
		die "bad syntax";
	    }
	}
	$mm->error and die $!;
	close $mm or die $!;

#print Dumper(\%oceans);
#print Dumper(\@rawcm);
	
	%commods= ();
	my $ca;
	$ca= sub {
	    my ($s,$ss) = @_;
#print "ca($s)\n";
	    if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; }
	    die "unknown $&" unless defined $colours{$1};
	    foreach my $c (keys %{ $colours{$1} }) {
		&$ca($`.$c.$', $ss .'%'. $colours{$1}{$c});
	    }
	};
	foreach (@rawcm) { &$ca($_,$src); }
    }
}

sub parse_masters () {
    parse_master_master1('master-master.txt','s');
}

sub jparsetable ($$) {
    my ($jobj,$wh) = @_;
    my $jtab= $jobj->{$wh};
    die "$jsonresp $wh ?" unless defined $jtab;
    my $cns= $jtab->{'colNames'};  die "$jsonresp $wh ?" unless defined $cns;
    my $ad= $jtab->{'arrayData'};  die "$jsonresp $wh ?" unless defined $ad;
    my @o=();
    foreach my $ai (@$ad) {
	@$ai == @$cns or die "$jsonresp $wh ".scalar(@o)."?";
	my $v= { };
	for (my $i=0; $i<@$cns; $i++) {
	    $v->{$cns->[$i]} = $ai->[$i];
	}
	push @o, $v;
    }
    return @o;
}
sub sort_by_name {
    sort {
	$a->{'name'} cmp $b->{'name'};
    } @_;
}

sub p ($) { print $_[0] or die $!; }
sub ptcl ($) {
    local ($_) = @_;
    die "$_ $& ?" if m/[^-+'"# 0-9a-z]/i;
    p("{$_[0]}");
}

sub json_convert_shim ($) {
    my ($json) = @_;
    # In JSON.pm 2.x, jsonToObj prints a warning to stderr which
    # our callers don't like at all.
    if ($JSON::VERSION >= 2.0) {
	return from_json($json);
    } else {
	return jsonToObj($json);
    }
}

sub get_arches_islands_pctb ($) {
    my ($ocean)= @_;
    die unless $pctb;
    my $url= "$pctb/islands.php?oceanName=".uc $ocean;
    my $resp= $ua->get($url);
    die $resp->status_line unless $resp->is_success;
    $jsonresp= $resp->content;
    my $jobj= json_convert_shim($resp->content);
    my $arches= [ jparsetable($jobj, 'arches') ];
    my $islands= [ jparsetable($jobj, 'islands') ];

    my $islands_done=0;
    foreach my $arch (@$arches) {
#	print Dumper($arnch);
	my $aname= $arch->{'name'};
	die "$jsonresp ?" unless defined $aname;

	foreach my $island (@$islands) {
	    my $iname= $island->{'name'};
	    die "$jsonresp $aname ?" unless defined $iname;
	    next unless $arch->{'id'} == $island->{'arch'};

	    $oceans{$ocean}{$aname}{$iname} .= 'b';
	    
	    $islands_done++;
	}
    }
    die "$jsonresp $islands_done ?" unless $islands_done == @$islands;
}

sub get_ocean () {
    my $ocean= $ENV{'YPPSC_OCEAN'};  die unless $ocean;
    return ucfirst lc $ocean;
}

sub for_islands ($$$$) {
    my ($ocean,$forarch,$forisle,$endarch) = @_;

    my $arches= $oceans{$ocean};
    foreach my $aname (sort keys %$arches) {
	&$forarch($ocean,$aname);
	my $islands= $arches->{$aname};
	foreach my $iname (sort keys %$islands) {
	    &$forisle($ocean,$aname,$iname);
	}
	&$endarch();
    }
}

sub get_commodmap_pctb_local () {
    my $f= new IO::File '_commodmap.tsv' or die $!;
    while (<$f>) {
	m/^(\w[^\t]+\w)\t\d+$/ or die;
	$commods{$1} .= 'b';
    }
    $f->error and die $!;
    close $f or die $!;
}

sub for_commods ($) {
    my ($forcommod) = @_;
    foreach my $commod (sort keys %commods) { &$forcommod($commod); }
}

sub compare_sources_one ($$) {
    my ($srcs,$what) = @_;
    return if $srcs =~ m,^sl?(?:\%sl?)*b$,;
    print "srcs=$srcs $what\n";
}

sub main__comparesources () {
    my $ocean= get_ocean();
    
    parse_masters();
    get_arches_islands_pctb($ocean);
    get_commodmap_pctb_local();

    for_islands($ocean,
		sub { },
		sub {
		    my ($ocean,$a,$i)= @_;
		    my $srcs= $oceans{$ocean}{$a}{$i};
		    compare_sources_one($srcs, "island $ocean / $a / $i");
		},
		sub { });
    for_commods(sub {
		    my ($commod)= @_;
		    my $srcs= $commods{$commod};
		    compare_sources_one($srcs, "commodity $commod");
		});
}

sub main__island () {
    my $ocean= get_ocean();
    
    parse_masters();
    get_arches_islands_pctb($ocean);

    for_islands($ocean,
		sub {
		    my ($ocean,$aname)= @_;
		    ptcl($aname); p(' '); ptcl($aname); p(" {\n");
		},
		sub {
		    my ($ocean,$aname,$iname)= @_;
		    p('    '); ptcl($iname); p(' '); ptcl($iname); p("\n");
		},
		sub {
		    p("}\n");
		});
}

sub main__allowablecommods ($$) {
    my ($ocean,$island) = @_;
    parse_masters();
    my $arches= $oceans{$ocean};
    if (!$arches) { print "unknown ocean\n"; exit 1; }
    my $found= 0;
    foreach my $islands (values %$arches) {
	my $sources= $islands->{$island};
	next unless $sources;
	die if $found;
	$found= $sources;
    }
    if (!$found) { print "unknown island\n"; exit 1; }

    print "\n";
    foreach my $commod (sort keys %commods) {
	print "$commod\n";
    }
    STDOUT->error and die $!;
    close STDOUT or die $!;
}

sub main__sunshinewidget () {
    print <<END
Land {On land} {
    Crew   Crew
    Shoppe Shoppe
    Ye     Ye
    Booty  Booty
    Ahoy!  Ahoy!
}
Vessel {On board a ship} {
    Crew   Crew
    Vessel Vessel
    Ye     Ye
    Booty  Booty
    Ahoy!  Ahoy!
}
END
    or die $!;
}

&{"main__$which"}(@ARGV);