use LWP::UserAgent;
use JSON;
use Data::Dumper;
+use IO::File;
@ARGV==1 or die "You probably don't want to run this program directly.\n";
our ($which) = shift @ARGV;
our ($ua)= LWP::UserAgent->new;
our $jsonresp;
+our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources
+our %commods; # eg $commods{'Fine black cloth'}= $sources;
+# $sources = 's[l]b';
+# 's' = Special Circumstances; 'l' = local ; B = with Bleach
+
+BEGIN {
+ my %colours; # eg $colours{'c'}{'black'}= $sources
+ my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
+
+ sub parse_master_master1 ($$) {
+ my ($mmfn,$src)= @_;
+ my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!";
+ my @ctx= ();
+ while (<$mm>) {
+ next if m/^\s*\#/;
+ next unless m/\S/;
+ s/\s+$//;
+ if (m/^\%(\w+)$/) {
+ my $colourkind= $1;
+ @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
+ } elsif (m/^commods$/) {
+ @ctx= (sub { push @rawcm, lc $_; });
+ } elsif (m/^ocean (\w+)$/) {
+ my $ocean= $1;
+ @ctx= (sub {
+ $ocean or die; # ref to $ocean needed to work
+ # around a perl bug
+ my $arch= $_;
+ $ctx[1]= sub {
+ $oceans{$ocean}{$arch}{$_} .= $src;
+ };
+ });
+ } elsif (s/^ +//) {
+ my $indent= length $&;
+ die "wrong indent $indent" unless defined $ctx[$indent-1];
+ &{ $ctx[$indent-1] }();
+ } else {
+ die "bad syntax";
+ }
+ }
+ $mm->error and die $!;
+ close $mm or die $!;
+
+#print Dumper(\%oceans);
+print Dumper(\@rawcm);
+
+ %commods= ();
+ my $ca;
+ $ca= sub {
+ my ($s,$ss) = @_;
+#print "ca($s)\n";
+ if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; }
+ die "unknown $&" unless defined $colours{$1};
+ foreach my $c (keys %{ $colours{$1} }) {
+ &$ca($`.$c.$', $ss .'%'. $colours{$1}{$c});
+ }
+ };
+ foreach (@rawcm) { &$ca($_,$src); }
+ }
+}
+
+sub parse_masters () {
+ parse_master_master1('master-master.txt','s');
+}
+
sub jparsetable ($$) {
my ($jobj,$wh) = @_;
my $jtab= $jobj->{$wh};
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) {
+ if ($JSON::VERSION >= 2.0) {
return from_json($json);
} else {
return jsonToObj($json);
}
}
-sub get_arches_islands () {
- my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean;
+sub get_arches_islands_pctb ($) {
+ my ($ocean)= @_;
my $url= "$pctb/islands.php?oceanName=".uc $ocean;
my $resp= $ua->get($url);
die $resp->status_line unless $resp->is_success;
my $jobj= json_convert_shim($resp->content);
my $arches= [ jparsetable($jobj, 'arches') ];
my $islands= [ jparsetable($jobj, 'islands') ];
- return ($arches,$islands);
-}
-sub main__island () {
- my ($arches, $islands) = get_arches_islands();
-# print Dumper(\@arches, \@islands);
my $islands_done=0;
- foreach my $arch (sort_by_name(@$arches)) {
-# print Dumper($arch);
+ foreach my $arch (@$arches) {
+# print Dumper($arnch);
my $aname= $arch->{'name'};
die "$jsonresp ?" unless defined $aname;
- ptcl($aname); p(' '); ptcl($aname); p(" {\n");
- foreach my $island (sort_by_name(@$islands)) {
+
+ foreach my $island (@$islands) {
my $iname= $island->{'name'};
die "$jsonresp $aname ?" unless defined $iname;
next unless $arch->{'id'} == $island->{'arch'};
- p(' '); ptcl($iname); p(' '); ptcl($iname); p("\n");
+
+ $oceans{$ocean}{$aname}{$iname} .= 'b';
+
$islands_done++;
}
- p("}\n");
}
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 get_commodmap_pctb_local () {
+ my $f= new IO::File '_commodmap.tsv' or die $!;
+ while (<$f>) {
+ m/^(\w[^\t]+\w)\t\d+$/ or die;
+ $commods{$1} .= 'b';
+ }
+ $f->error and die $!;
+ close $f or die $!;
+}
+
+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);
+ get_commodmap_pctb_local();
+
+ 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} {
~yarrgweb / ypp-sc-tools.web-live.git / blobdiff