pctb/database-info-fetch

   1 #!/usr/bin/perl -w
   2
   3 # helper program for determining pixmap resolution options
   4
   5 # This is part of ypp-sc-tools, a set of third-party tools for assisting
   6 # players of Yohoho Puzzle Pirates.
   7 #
   8 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
   9 #
  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.
  14 #
  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.
  19 #
  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/>.
  22 #
  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.
  26
  27 use strict (qw(vars));
  28 use LWP::UserAgent;
  29 use JSON;
  30 #use Data::Dumper;
  31 use IO::File;
  32
  33 @ARGV>=1 or die "You probably don't want to run this program directly.\n";
  34 our ($which) = shift @ARGV;
  35
  36 $which =~ s/\W//g;
  37
  38 our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'};
  39 our ($ua)= LWP::UserAgent->new;
  40 our $jsonresp;
  41
  42 our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources
  43 our %commods; # eg $commods{'Fine black cloth'}= $sources;
  44 # $sources = 's[l]b';
  45 #       's' = Special Circumstances; 'l' = local ; B = with Bleach
  46
  47 BEGIN {
  48     my %colours; # eg $colours{'c'}{'black'}= $sources
  49     my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
  50
  51     sub parse_master_master1 ($$) {
  52         my ($mmfn,$src)= @_;
  53         my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!";
  54         my @ctx= ();
  55         while (<$mm>) {
  56             next if m/^\s*\#/;
  57             next unless m/\S/;
  58             s/\s+$//;
  59             if (m/^\%(\w+)$/) {
  60                 my $colourkind= $1;
  61                 @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
  62             } elsif (m/^commods$/) {
  63                 @ctx= (sub { push @rawcm, lc $_; });
  64             } elsif (m/^ocean (\w+)$/) {
  65                 my $ocean= $1;
  66                 @ctx= (sub {
  67                            $ocean or die; # ref to $ocean needed to work
  68                                           # around a perl bug
  69                            my $arch= $_;
  70                            $ctx[1]= sub {
  71                                $oceans{$ocean}{$arch}{$_} .= $src;
  72                            };
  73                        });
  74             } elsif (s/^ +//) {
  75                 my $indent= length $&;
  76                 die "wrong indent $indent" unless defined $ctx[$indent-1];
  77                 &{ $ctx[$indent-1] }();
  78             } else {
  79                 die "bad syntax";
  80             }
  81         }
  82         $mm->error and die $!;
  83         close $mm or die $!;
  84
  85 #print Dumper(\%oceans);
  86 #print Dumper(\@rawcm);
  87
  88         %commods= ();
  89         my $ca;
  90         $ca= sub {
  91             my ($s,$ss) = @_;
  92 #print "ca($s)\n";
  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});
  97             }
  98         };
  99         foreach (@rawcm) { &$ca($_,$src); }
 100     }
 101 }
 102
 103 sub parse_masters () {
 104     parse_master_master1('master-master.txt','s');
 105 }
 106
 107 sub jparsetable ($$) {
 108     my ($jobj,$wh) = @_;
 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;
 113     my @o=();
 114     foreach my $ai (@$ad) {
 115         @$ai == @$cns or die "$jsonresp $wh ".scalar(@o)."?";
 116         my $v= { };
 117         for (my $i=0; $i<@$cns; $i++) {
 118             $v->{$cns->[$i]} = $ai->[$i];
 119         }
 120         push @o, $v;
 121     }
 122     return @o;
 123 }
 124 sub sort_by_name {
 125     sort {
 126         $a->{'name'} cmp $b->{'name'};
 127     } @_;
 128 }
 129
 130 sub p ($) { print $_[0] or die $!; }
 131 sub ptcl ($) {
 132     local ($_) = @_;
 133     die "$_ $& ?" if m/[^-+'"# 0-9a-z]/i;
 134     p("{$_[0]}");
 135 }
 136
 137 sub json_convert_shim ($) {
 138     my ($json) = @_;
 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);
 143     } else {
 144         return jsonToObj($json);
 145     }
 146 }
 147
 148 sub get_arches_islands_pctb ($) {
 149     my ($ocean)= @_;
 150     die unless $pctb;
 151     my $url= "$pctb/islands.php?oceanName=".uc $ocean;
 152     my $resp= $ua->get($url);
 153     die $resp->status_line unless $resp->is_success;
 154     $jsonresp= $resp->content;
 155     my $jobj= json_convert_shim($resp->content);
 156     my $arches= [ jparsetable($jobj, 'arches') ];
 157     my $islands= [ jparsetable($jobj, 'islands') ];
 158
 159     my $islands_done=0;
 160     foreach my $arch (@$arches) {
 161 #       print Dumper($arnch);
 162         my $aname= $arch->{'name'};
 163         die "$jsonresp ?" unless defined $aname;
 164
 165         foreach my $island (@$islands) {
 166             my $iname= $island->{'name'};
 167             die "$jsonresp $aname ?" unless defined $iname;
 168             next unless $arch->{'id'} == $island->{'arch'};
 169
 170             $oceans{$ocean}{$aname}{$iname} .= 'b';
 171
 172             $islands_done++;
 173         }
 174     }
 175     die "$jsonresp $islands_done ?" unless $islands_done == @$islands;
 176 }
 177
 178 sub get_ocean () {
 179     my $ocean= $ENV{'YPPSC_OCEAN'};  die unless $ocean;
 180     return ucfirst lc $ocean;
 181 }
 182
 183 sub for_islands ($$$$) {
 184     my ($ocean,$forarch,$forisle,$endarch) = @_;
 185
 186     my $arches= $oceans{$ocean};
 187     foreach my $aname (sort keys %$arches) {
 188         &$forarch($ocean,$aname);
 189         my $islands= $arches->{$aname};
 190         foreach my $iname (sort keys %$islands) {
 191             &$forisle($ocean,$aname,$iname);
 192         }
 193         &$endarch();
 194     }
 195 }
 196
 197 sub get_commodmap_pctb_local () {
 198     my $f= new IO::File '_commodmap.tsv' or die $!;
 199     while (<$f>) {
 200         m/^(\w[^\t]+\w)\t\d+$/ or die;
 201         $commods{$1} .= 'b';
 202     }
 203     $f->error and die $!;
 204     close $f or die $!;
 205 }
 206
 207 sub for_commods ($) {
 208     my ($forcommod) = @_;
 209     foreach my $commod (sort keys %commods) { &$forcommod($commod); }
 210 }
 211
 212 sub compare_sources_one ($$) {
 213     my ($srcs,$what) = @_;
 214     return if $srcs =~ m,^sl?(?:\%sl?)*b$,;
 215     print "srcs=$srcs $what\n";
 216 }
 217
 218 sub main__comparesources () {
 219     my $ocean= get_ocean();
 220
 221     parse_masters();
 222     get_arches_islands_pctb($ocean);
 223     get_commodmap_pctb_local();
 224
 225     for_islands($ocean,
 226                 sub { },
 227                 sub {
 228                     my ($ocean,$a,$i)= @_;
 229                     my $srcs= $oceans{$ocean}{$a}{$i};
 230                     compare_sources_one($srcs, "island $ocean / $a / $i");
 231                 },
 232                 sub { });
 233     for_commods(sub {
 234                     my ($commod)= @_;
 235                     my $srcs= $commods{$commod};
 236                     compare_sources_one($srcs, "commodity $commod");
 237                 });
 238 }
 239
 240 sub main__island () {
 241     my $ocean= get_ocean();
 242
 243     parse_masters();
 244     get_arches_islands_pctb($ocean);
 245
 246     for_islands($ocean,
 247                 sub {
 248                     my ($ocean,$aname)= @_;
 249                     ptcl($aname); p(' '); ptcl($aname); p(" {\n");
 250                 },
 251                 sub {
 252                     my ($ocean,$aname,$iname)= @_;
 253                     p('    '); ptcl($iname); p(' '); ptcl($iname); p("\n");
 254                 },
 255                 sub {
 256                     p("}\n");
 257                 });
 258 }
 259
 260 sub main__allowablecommods ($$) {
 261     my ($ocean,$island) = @_;
 262     parse_masters();
 263     my $arches= $oceans{$ocean};
 264     if (!$arches) { print "unknown ocean\n"; exit 1; }
 265     my $found= 0;
 266     foreach my $islands (values %$arches) {
 267         my $sources= $islands->{$island};
 268         next unless $sources;
 269         die if $found;
 270         $found= $sources;
 271     }
 272     if (!$found) { print "unknown island\n"; exit 1; }
 273
 274     print "\n";
 275     foreach my $commod (sort keys %commods) {
 276         print "$commod\n";
 277     }
 278     STDOUT->error and die $!;
 279     close STDOUT or die $!;
 280 }
 281
 282 sub main__sunshinewidget () {
 283     print <<END
 284 Land {On land} {
 285     Crew   Crew
 286     Shoppe Shoppe
 287     Ye     Ye
 288     Booty  Booty
 289     Ahoy!  Ahoy!
 290 }
 291 Vessel {On board a ship} {
 292     Crew   Crew
 293     Vessel Vessel
 294     Ye     Ye
 295     Booty  Booty
 296     Ahoy!  Ahoy!
 297 }
 298 END
 299     or die $!;
 300 }
 301
 302 &{"main__$which"}(@ARGV);