chiark / gitweb /
WIP our own database
[ypp-sc-tools.web-live.git] / 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'};  die unless $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     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') ];
157
158     my $islands_done=0;
159     foreach my $arch (@$arches) {
160 #       print Dumper($arnch);
161         my $aname= $arch->{'name'};
162         die "$jsonresp ?" unless defined $aname;
163
164         foreach my $island (@$islands) {
165             my $iname= $island->{'name'};
166             die "$jsonresp $aname ?" unless defined $iname;
167             next unless $arch->{'id'} == $island->{'arch'};
168
169             $oceans{$ocean}{$aname}{$iname} .= 'b';
170             
171             $islands_done++;
172         }
173     }
174     die "$jsonresp $islands_done ?" unless $islands_done == @$islands;
175 }
176
177 sub get_ocean () {
178     my $ocean= $ENV{'YPPSC_OCEAN'};  die unless $ocean;
179     return ucfirst lc $ocean;
180 }
181
182 sub for_islands ($$$$) {
183     my ($ocean,$forarch,$forisle,$endarch) = @_;
184
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);
191         }
192         &$endarch();
193     }
194 }
195
196 sub get_commodmap_pctb_local () {
197     my $f= new IO::File '_commodmap.tsv' or die $!;
198     while (<$f>) {
199         m/^(\w[^\t]+\w)\t\d+$/ or die;
200         $commods{$1} .= 'b';
201     }
202     $f->error and die $!;
203     close $f or die $!;
204 }
205
206 sub for_commods ($) {
207     my ($forcommod) = @_;
208     foreach my $commod (sort keys %commods) { &$forcommod($commod); }
209 }
210
211 sub compare_sources_one ($$) {
212     my ($srcs,$what) = @_;
213     return if $srcs =~ m,^sl?(?:\%sl?)*b$,;
214     print "srcs=$srcs $what\n";
215 }
216
217 sub main__comparesources () {
218     my $ocean= get_ocean();
219     
220     parse_masters();
221     get_arches_islands_pctb($ocean);
222     get_commodmap_pctb_local();
223
224     for_islands($ocean,
225                 sub { },
226                 sub {
227                     my ($ocean,$a,$i)= @_;
228                     my $srcs= $oceans{$ocean}{$a}{$i};
229                     compare_sources_one($srcs, "island $ocean / $a / $i");
230                 },
231                 sub { });
232     for_commods(sub {
233                     my ($commod)= @_;
234                     my $srcs= $commods{$commod};
235                     compare_sources_one($srcs, "commodity $commod");
236                 });
237 }
238
239 sub main__island () {
240     my $ocean= get_ocean();
241     
242     parse_masters();
243     get_arches_islands_pctb($ocean);
244
245     for_islands($ocean,
246                 sub {
247                     my ($ocean,$aname)= @_;
248                     ptcl($aname); p(' '); ptcl($aname); p(" {\n");
249                 },
250                 sub {
251                     my ($ocean,$aname,$iname)= @_;
252                     p('    '); ptcl($iname); p(' '); ptcl($iname); p("\n");
253                 },
254                 sub {
255                     p("}\n");
256                 });
257 }
258
259 sub main__sunshinewidget () {
260     print <<END
261 Land {On land} {
262     Crew   Crew
263     Shoppe Shoppe
264     Ye     Ye
265     Booty  Booty
266     Ahoy!  Ahoy!
267 }
268 Vessel {On board a ship} {
269     Crew   Crew
270     Vessel Vessel
271     Ye     Ye
272     Booty  Booty
273     Ahoy!  Ahoy!
274 }
275 END
276     or die $!;
277 }
278
279 &{"main__$which"}();