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 use Commods;
  34
  35 @ARGV>=1 or die "You probably don't want to run this program directly.\n";
  36 our ($which) = shift @ARGV;
  37
  38 $which =~ s/\W//g;
  39
  40 our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'};
  41 our ($ua)= LWP::UserAgent->new;
  42 our $jsonresp;
  43
  44 sub jparsetable ($$) {
  45     my ($jobj,$wh) = @_;
  46     my $jtab= $jobj->{$wh};
  47     die "$jsonresp $wh ?" unless defined $jtab;
  48     my $cns= $jtab->{'colNames'};  die "$jsonresp $wh ?" unless defined $cns;
  49     my $ad= $jtab->{'arrayData'};  die "$jsonresp $wh ?" unless defined $ad;
  50     my @o=();
  51     foreach my $ai (@$ad) {
  52         @$ai == @$cns or die "$jsonresp $wh ".scalar(@o)."?";
  53         my $v= { };
  54         for (my $i=0; $i<@$cns; $i++) {
  55             $v->{$cns->[$i]} = $ai->[$i];
  56         }
  57         push @o, $v;
  58     }
  59     return @o;
  60 }
  61 sub sort_by_name {
  62     sort {
  63         $a->{'name'} cmp $b->{'name'};
  64     } @_;
  65 }
  66
  67 sub p ($) { print $_[0] or die $!; }
  68 sub ptcl ($) {
  69     local ($_) = @_;
  70     die "$_ $& ?" if m/[^-+'"# 0-9a-z]/i;
  71     p("{$_[0]}");
  72 }
  73
  74 sub json_convert_shim ($) {
  75     my ($json) = @_;
  76     # In JSON.pm 2.x, jsonToObj prints a warning to stderr which
  77     # our callers don't like at all.
  78     if ($JSON::VERSION >= 2.0) {
  79         return from_json($json);
  80     } else {
  81         return jsonToObj($json);
  82     }
  83 }
  84
  85 sub get_arches_islands_pctb ($) {
  86     my ($ocean)= @_;
  87     die unless $pctb;
  88     my $url= "$pctb/islands.php?oceanName=".uc $ocean;
  89     my $resp= $ua->get($url);
  90     die $resp->status_line unless $resp->is_success;
  91     $jsonresp= $resp->content;
  92     my $jobj= json_convert_shim($resp->content);
  93     my $arches= [ jparsetable($jobj, 'arches') ];
  94     my $islands= [ jparsetable($jobj, 'islands') ];
  95
  96     my $islands_done=0;
  97     foreach my $arch (@$arches) {
  98 #       print Dumper($arnch);
  99         my $aname= $arch->{'name'};
 100         die "$jsonresp ?" unless defined $aname;
 101
 102         foreach my $island (@$islands) {
 103             my $iname= $island->{'name'};
 104             die "$jsonresp $aname ?" unless defined $iname;
 105             next unless $arch->{'id'} == $island->{'arch'};
 106
 107             $oceans{$ocean}{$aname}{$iname} .= 'b';
 108
 109             $islands_done++;
 110         }
 111     }
 112     die "$jsonresp $islands_done ?" unless $islands_done == @$islands;
 113 }
 114
 115 sub get_ocean () {
 116     my $ocean= $ENV{'YPPSC_OCEAN'};  die unless $ocean;
 117     return ucfirst lc $ocean;
 118 }
 119
 120 sub for_islands ($$$$) {
 121     my ($ocean,$forarch,$forisle,$endarch) = @_;
 122
 123     my $arches= $oceans{$ocean};
 124     foreach my $aname (sort keys %$arches) {
 125         &$forarch($ocean,$aname);
 126         my $islands= $arches->{$aname};
 127         foreach my $iname (sort keys %$islands) {
 128             &$forisle($ocean,$aname,$iname);
 129         }
 130         &$endarch();
 131     }
 132 }
 133
 134 sub get_commodmap_pctb_local () {
 135     my $f= new IO::File '_commodmap.tsv' or die $!;
 136     while (<$f>) {
 137         m/^(\w[^\t]+\w)\t\d+$/ or die;
 138         $commods{$1} .= 'b';
 139     }
 140     $f->error and die $!;
 141     close $f or die $!;
 142 }
 143
 144 sub for_commods ($) {
 145     my ($forcommod) = @_;
 146     foreach my $commod (sort keys %commods) { &$forcommod($commod); }
 147 }
 148
 149 sub compare_sources_one ($$) {
 150     my ($srcs,$what) = @_;
 151     return if $srcs =~ m,^sl?(?:\%sl?)*b$,;
 152     print "srcs=$srcs $what\n";
 153 }
 154
 155 sub main__comparesources () {
 156     my $ocean= get_ocean();
 157
 158     parse_masters();
 159     get_arches_islands_pctb($ocean);
 160     get_commodmap_pctb_local();
 161
 162     for_islands($ocean,
 163                 sub { },
 164                 sub {
 165                     my ($ocean,$a,$i)= @_;
 166                     my $srcs= $oceans{$ocean}{$a}{$i};
 167                     compare_sources_one($srcs, "island $ocean / $a / $i");
 168                 },
 169                 sub { });
 170     for_commods(sub {
 171                     my ($commod)= @_;
 172                     my $srcs= $commods{$commod};
 173                     compare_sources_one($srcs, "commodity $commod");
 174                 });
 175 }
 176
 177 sub main__island () {
 178     my $ocean= get_ocean();
 179
 180     parse_masters();
 181     get_arches_islands_pctb($ocean);
 182
 183     for_islands($ocean,
 184                 sub {
 185                     my ($ocean,$aname)= @_;
 186                     ptcl($aname); p(' '); ptcl($aname); p(" {\n");
 187                 },
 188                 sub {
 189                     my ($ocean,$aname,$iname)= @_;
 190                     p('    '); ptcl($iname); p(' '); ptcl($iname); p("\n");
 191                 },
 192                 sub {
 193                     p("}\n");
 194                 });
 195 }
 196
 197 sub main__allowablecommods ($$) {
 198     my ($ocean,$island) = @_;
 199     parse_masters();
 200     my $arches= $oceans{$ocean};
 201     if (!$arches) { print "unknown ocean\n"; exit 1; }
 202     my $found= 0;
 203     foreach my $islands (values %$arches) {
 204         my $sources= $islands->{$island};
 205         next unless $sources;
 206         die if $found;
 207         $found= $sources;
 208     }
 209     if (!$found) { print "unknown island\n"; exit 1; }
 210
 211     print "\n";
 212     foreach my $commod (sort keys %commods) {
 213         print "$commod\n";
 214     }
 215     STDOUT->error and die $!;
 216     close STDOUT or die $!;
 217 }
 218
 219 sub main__sunshinewidget () {
 220     print <<END
 221 Land {On land} {
 222     Crew   Crew
 223     Shoppe Shoppe
 224     Ye     Ye
 225     Booty  Booty
 226     Ahoy!  Ahoy!
 227 }
 228 Vessel {On board a ship} {
 229     Crew   Crew
 230     Vessel Vessel
 231     Ye     Ye
 232     Booty  Booty
 233     Ahoy!  Ahoy!
 234 }
 235 END
 236     or die $!;
 237 }
 238
 239 &{"main__$which"}(@ARGV);