--- /dev/null
+#!/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;
+
+use Commods;
+
+@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;
+
+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 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);
+ parse_pctb_commodmap() or die;
+
+ 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__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);