From c5d3c490b9992b0b7adb00d0cd4d8aa53721c57b Mon Sep 17 00:00:00 2001 From: Ian Jackson Date: Thu, 16 Jul 2009 19:09:45 +0100 Subject: [PATCH] WIP our own database --- pctb/database-info-fetch | 170 ++++++++++++++++++++++++++++++++++++--- pctb/master-master.txt | 165 +++++++++++++++++++++++++++++++++++++ 2 files changed, 322 insertions(+), 13 deletions(-) create mode 100644 pctb/master-master.txt diff --git a/pctb/database-info-fetch b/pctb/database-info-fetch index 3b8db77..8b464a1 100755 --- a/pctb/database-info-fetch +++ b/pctb/database-info-fetch @@ -28,6 +28,7 @@ use strict (qw(vars)); 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; @@ -38,6 +39,71 @@ our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'}; die unless $pctb; 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}; @@ -79,8 +145,8 @@ sub json_convert_shim ($) { } } -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; @@ -88,30 +154,108 @@ sub get_arches_islands () { 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 <