3 # helper program for determining pixmap resolution options
5 # This is part of ypp-sc-tools, a set of third-party tools for assisting
6 # players of Yohoho Puzzle Pirates.
8 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
10 # This program is free software: you can redistribute it and/or modify
11 # it under the terms of the GNU General Public License as published by
12 # the Free Software Foundation, either version 3 of the License, or
13 # (at your option) any later version.
15 # This program is distributed in the hope that it will be useful,
16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 # GNU General Public License for more details.
20 # You should have received a copy of the GNU General Public License
21 # along with this program. If not, see <http://www.gnu.org/licenses/>.
23 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
24 # are used without permission. This program is not endorsed or
25 # sponsored by Three Rings.
27 use strict (qw(vars));
33 @ARGV==1 or die "You probably don't want to run this program directly.\n";
34 our ($which) = shift @ARGV;
38 our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'}; die unless $pctb;
39 our ($ua)= LWP::UserAgent->new;
42 our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources
43 our %commods; # eg $commods{'Fine black cloth'}= $sources;
45 # 's' = Special Circumstances; 'l' = local ; B = with Bleach
48 my %colours; # eg $colours{'c'}{'black'}= $sources
49 my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
51 sub parse_master_master1 ($$) {
53 my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!";
61 @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
62 } elsif (m/^commods$/) {
63 @ctx= (sub { push @rawcm, lc $_; });
64 } elsif (m/^ocean (\w+)$/) {
67 $ocean or die; # ref to $ocean needed to work
71 $oceans{$ocean}{$arch}{$_} .= $src;
75 my $indent= length $&;
76 die "wrong indent $indent" unless defined $ctx[$indent-1];
77 &{ $ctx[$indent-1] }();
82 $mm->error and die $!;
85 #print Dumper(\%oceans);
86 print Dumper(\@rawcm);
93 if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; }
94 die "unknown $&" unless defined $colours{$1};
95 foreach my $c (keys %{ $colours{$1} }) {
96 &$ca($`.$c.$', $ss .'%'. $colours{$1}{$c});
99 foreach (@rawcm) { &$ca($_,$src); }
103 sub parse_masters () {
104 parse_master_master1('master-master.txt','s');
107 sub jparsetable ($$) {
109 my $jtab= $jobj->{$wh};
110 die "$jsonresp $wh ?" unless defined $jtab;
111 my $cns= $jtab->{'colNames'}; die "$jsonresp $wh ?" unless defined $cns;
112 my $ad= $jtab->{'arrayData'}; die "$jsonresp $wh ?" unless defined $ad;
114 foreach my $ai (@$ad) {
115 @$ai == @$cns or die "$jsonresp $wh ".scalar(@o)."?";
117 for (my $i=0; $i<@$cns; $i++) {
118 $v->{$cns->[$i]} = $ai->[$i];
126 $a->{'name'} cmp $b->{'name'};
130 sub p ($) { print $_[0] or die $!; }
133 die "$_ $& ?" if m/[^-+'"# 0-9a-z]/i;
137 sub json_convert_shim ($) {
139 # In JSON.pm 2.x, jsonToObj prints a warning to stderr which
140 # our callers don't like at all.
141 if ($JSON::VERSION >= 2.0) {
142 return from_json($json);
144 return jsonToObj($json);
148 sub get_arches_islands_pctb ($) {
150 my $url= "$pctb/islands.php?oceanName=".uc $ocean;
151 my $resp= $ua->get($url);
152 die $resp->status_line unless $resp->is_success;
153 $jsonresp= $resp->content;
154 my $jobj= json_convert_shim($resp->content);
155 my $arches= [ jparsetable($jobj, 'arches') ];
156 my $islands= [ jparsetable($jobj, 'islands') ];
159 foreach my $arch (@$arches) {
160 # print Dumper($arnch);
161 my $aname= $arch->{'name'};
162 die "$jsonresp ?" unless defined $aname;
164 foreach my $island (@$islands) {
165 my $iname= $island->{'name'};
166 die "$jsonresp $aname ?" unless defined $iname;
167 next unless $arch->{'id'} == $island->{'arch'};
169 $oceans{$ocean}{$aname}{$iname} .= 'b';
174 die "$jsonresp $islands_done ?" unless $islands_done == @$islands;
178 my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean;
179 return ucfirst lc $ocean;
182 sub for_islands ($$$$) {
183 my ($ocean,$forarch,$forisle,$endarch) = @_;
185 my $arches= $oceans{$ocean};
186 foreach my $aname (sort keys %$arches) {
187 &$forarch($ocean,$aname);
188 my $islands= $arches->{$aname};
189 foreach my $iname (sort keys %$islands) {
190 &$forisle($ocean,$aname,$iname);
196 sub get_commodmap_pctb_local () {
197 my $f= new IO::File '_commodmap.tsv' or die $!;
199 m/^(\w[^\t]+\w)\t\d+$/ or die;
202 $f->error and die $!;
206 sub for_commods ($) {
207 my ($forcommod) = @_;
208 foreach my $commod (sort keys %commods) { &$forcommod($commod); }
211 sub compare_sources_one ($$) {
212 my ($srcs,$what) = @_;
213 return if $srcs =~ m,^sl?(?:\%sl?)*b$,;
214 print "srcs=$srcs $what\n";
217 sub main__comparesources () {
218 my $ocean= get_ocean();
221 get_arches_islands_pctb($ocean);
222 get_commodmap_pctb_local();
227 my ($ocean,$a,$i)= @_;
228 my $srcs= $oceans{$ocean}{$a}{$i};
229 compare_sources_one($srcs, "island $ocean / $a / $i");
234 my $srcs= $commods{$commod};
235 compare_sources_one($srcs, "commodity $commod");
239 sub main__island () {
240 my $ocean= get_ocean();
243 get_arches_islands_pctb($ocean);
247 my ($ocean,$aname)= @_;
248 ptcl($aname); p(' '); ptcl($aname); p(" {\n");
251 my ($ocean,$aname,$iname)= @_;
252 p(' '); ptcl($iname); p(' '); ptcl($iname); p("\n");
259 sub main__sunshinewidget () {
268 Vessel {On board a ship} {