chiark / gitweb /
Notice if $expected_total_profit parsing failed; don't break if it is an integer
[ypp-sc-tools.db-live.git] / yarrg / commod-results-processor
1 #!/usr/bin/perl -w
2
3 # helper program for processing commodity output
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
28 use strict (qw(vars));
29 use HTTP::Request;
30 use IO::File;
31 use POSIX;
32 use XML::Parser;
33
34 use Commods;
35
36 # $commod{'Hemp'}{Buy|Sell}{'stall'}{Stall}
37 # $commod{'Hemp'}{Buy|Sell}{'stall'}{Price}
38 # $commod{'Hemp'}{Buy|Sell}{'stall'}{Qty}
39 # $commod{'Hemp'}{Hold}
40
41 our @v;
42 our ($commod,$stall,%commod);
43
44 @ARGV==1 or die "You probably don't want to run this program directly.\n";
45 our ($mode) = shift @ARGV;
46
47 # ./yppsc-commod-processor tsv <t |less -x40,80,90,100,110
48
49 sub bs_read ($$) {
50     my ($bs,$c) = @_;
51     return if @v <= $c;
52     my ($price,$qty) = @v[$c..$c+1];
53     return if !length($price) && !length($qty);
54     die "$_ ?" unless length($price) && length($qty);
55     $commod{$commod}{$bs}{$stall}= {
56         Stall => $stall,
57         Price => $price,
58         Qty => $qty,
59     };
60 }
61
62 while (<>) {
63     chomp;
64     @v= split /\t/;
65 #print STDERR "[".join("|",@v)."]\n";
66     ($commod,$stall) = @v;
67     bs_read(Buy,  2);
68     bs_read(Sell, 4);
69     $commod{$commod}{Hold}= $v[6]+0 if @v>6;
70 }
71
72 our $current;
73
74 sub bs_p ($$$) {
75     my ($commod,$bs,$sortmul) = @_;
76     my $ary= $current->{$bs};
77     my $r= [ ];
78 #print Dumper($ary);
79     foreach my $stall (sort {
80         $sortmul * ($ary->{$a}{Price} <=> $ary->{$b}{Price});
81     } keys %$ary) {
82         push @$r, $ary->{$stall};
83     }
84     return $r;
85 }
86
87 sub bs_p_bestprice ($) {
88     my ($l) = @_;
89     if (@$l) {
90         printf("| %-25.25s %4d", $l->[0]{Stall}, $l->[0]{Price}) or die $!;
91     } else {
92         printf("| %25s %4s","","") or die $!;
93     }
94 }
95
96 sub main__arbitrage () {
97     my @arbs= ();
98     foreach $commod (sort keys %commod) {
99         $current= $commod{$commod};
100         my @buys=  @{ bs_p($commod,Buy, -1) };
101         my @sells= @{ bs_p($commod,Sell,+1) };
102         my $profit= 0;
103         my $cqty= 0;
104         my $info= '';
105         my $arbs= [];
106         for (;;) {
107 #print Dumper($commod,\@buys,\@sells);
108             last unless @buys;
109             last unless @sells;
110             my $pricediff= $buys[0]{Price} - $sells[0]{Price};
111             last unless $pricediff > 0;
112             our $qty= 1000;
113             sub arb_check_qty (\@) {
114                 my ($verbs) = @_;
115                 my $vqty= $verbs->[0]{Qty};
116                 return if $vqty =~ m/^\>/;
117                 $qty= $vqty if $qty > $vqty;
118                 return if $vqty;
119                 my $verb= shift @$verbs;
120             }
121             arb_check_qty(@buys);
122             arb_check_qty(@sells);
123             next unless $qty;
124             my $tprofit= $qty*$pricediff;
125             $profit += $tprofit;
126             $cqty += $qty;
127             
128             $info.=
129                 sprintf("%-13.13s| %-19.19s %4d| %-19.19s %4d|%3d x%3d =%3d\n",
130                        $commod,
131                        $sells[0]{Stall},$sells[0]{Price},
132                        $buys[0]{Stall},$buys[0]{Price},
133                        $qty, $pricediff, $tprofit);
134             sub arb_subtract_qty (\@) {
135                 my ($verbs) = @_;
136                 my $verb= shift @$verbs;
137                 my $vqty= $verb->{Qty};
138                 $vqty =~ s/^\>//;
139                 unshift @$verbs, {
140                     Stall => $verb->{Stall},
141                     Price => $verb->{Price},
142                     Qty => $vqty - $qty
143                 };
144             }
145             arb_subtract_qty(@buys);
146             arb_subtract_qty(@sells);
147         }
148         next unless $profit;
149         $info.=
150             sprintf("%-13.13s| %19s %4s| %19s %4s|%3d      %4d\n",
151                     $commod, '','', '','', $cqty, $profit);
152         push @arbs, { Profit => $profit, Info => $info };
153     }
154     my $allprofit;
155
156     if (!@arbs) {
157         print "No arbitrage opportunities.\n" or die $!;
158         return;
159     }
160     my $bigdiv= <<END;
161 =============+=========================+=========================+=============
162 END
163
164     print <<END or die $!;
165
166 commodity    | seller             price| buyer              price| qty  ea prof
167 END
168
169     my $div= $bigdiv;
170     foreach my $arb (sort {
171         $b->{Profit} <=> $a->{Profit};
172     } @arbs) {
173         print $div,$arb->{Info} or die $1;
174         $div= <<END;
175 -------------+-------------------------+-------------------------+-------------
176 END
177         $allprofit += $arb->{Profit};
178     }
179     print $bigdiv or die $!;
180     printf("%-13.13s  %19s %4s  %19s %4s %-5s %7d\n",
181            '', '','', '','', 'TOTAL', $allprofit)
182         or die $!;
183 }
184
185 sub main__bestprices () {
186     foreach $commod (sort keys %commod) {
187         $current= $commod{$commod};
188         my $buys=  bs_p($commod,Buy, -1);
189         my $sells= bs_p($commod,Sell,+1);
190         printf("%-15.15s", $commod) or die $!;
191         bs_p_bestprice($buys);
192         bs_p_bestprice($sells);
193         print("\n") or die $!;
194     }
195 }
196
197 sub bs_p_tsv ($$) {
198     my ($f, $bs) = @_;
199     if (exists $current->{$bs}{$stall}) {
200         my $si= $current->{$bs}{$stall};
201         printf($f "\t%d\t%s", $si->{Price}, $si->{Qty}) or die $!;
202     } else {
203         printf($f "\t\t") or die $!;
204     }
205 }
206
207 sub write_tsv ($) {
208     my ($f) = @_;
209     foreach $commod (sort keys %commod) {
210         $current= $commod{$commod};
211         my %stalls;
212         map { $stalls{$_}=1; } keys %{ $current->{Buy}  };
213         map { $stalls{$_}=1; } keys %{ $current->{Sell} };
214         foreach $stall (sort keys %stalls) {
215             printf($f "%s\t%s", $commod, $stall) or die $!;
216             bs_p_tsv($f, Buy);
217             bs_p_tsv($f, Sell);
218             print($f "\n") or die $!;
219         }
220     }
221     $f->error and die $!;
222     $f->flush or die $!;
223 }
224
225 sub main__tsv () {
226     write_tsv(\*STDOUT);
227 }
228
229
230 our ($pctb) = $ENV{'YPPSC_YARRG_PCTB'};
231
232 our ($ua)= http_useragent("commod-results-processor $mode");
233
234 sub refresh_commodmap() {
235     die unless $pctb;
236     $pctb =~ s,/*$,,;
237     my $resp= $ua->get("$pctb/commodmap.php?version=2");
238     die $resp->status_line unless $resp->is_success;
239
240     my $cdata='';
241     my $incommodmap=0;
242     my $intag='';
243     my %got;
244     my $o= new IO::File "_commodmap.tsv.tmp",'w' or die $!;
245     undef %pctb_commodmap;
246
247     my $xp= new XML::Parser
248         (Handlers =>
249          {
250              Start => sub {
251                  $_=$_[1];
252 #print STDERR "START [$_] intag=$intag icm=$incommodmap\n";
253                  if (m/^commodmap$/i) {
254                      $incommodmap++;
255                      undef %got;
256                  } elsif (m/^(?:name|index)$/i) {
257                      $cdata='';
258                      $intag=lc($_) if $incommodmap;
259 #print STDERR "START RECOGNISED $intag icm=$incommodmap\n";
260 #                } else {
261 #print STDERR "START UNRECOGNISED\n";
262                  }
263              },
264              End => sub {
265                  $_=$_[1];
266 #print STDERR "END [$_] intag=$intag icm=$incommodmap\n";
267                  if (m/^commodmap$/i) {
268                      $incommodmap--;
269                      die unless exists $got{'name'};
270                      die unless exists $got{'index'};
271                      die unless $got{'index'} =~ m/^\s*([1-9]\d{0,3})\s*$/;
272                      my $index= $1;
273                      $_= $got{'name'};
274                      s/^\s+//; s/\s+$//; s/\n/ /g; s/\s+/ /;
275                      die "$_ ?" if exists $pctb_commodmap{$_};
276                      $pctb_commodmap{$_}= $index;
277                      print $o "$_\t$index\n" or die $!;
278                  } elsif (lc $_ eq $intag) {
279                      $got{$intag}= $cdata;
280                  }
281              },
282              Char => sub {
283 #print STDERR "CHAR [$_[1]] intag=$intag icm=$incommodmap\n";
284                  $cdata .= $_[1];
285              }
286          }) or die;
287     my $content= $resp->content;
288
289 #    print STDERR "[[[$content]]]\n";
290     my $commodmapxmltmp= '_commodmap.xml';
291     if (!eval {
292         $xp->parse($content); 1;
293     }) {
294         open R, ">./$commodmapxmltmp" or die $!;
295         print R $content or die $!;
296         close R or die $!;
297         die "$@ parsing commodmap";
298     }
299     unlink $commodmapxmltmp or $!==&ENOENT or die $!;
300     close $o or die $!;
301     rename "_commodmap.tsv.tmp","_commodmap.tsv" or die $!;
302 }
303
304 our %newcommods;
305
306 sub read_newcommods ($) {
307     my ($file) = @_;
308     if (!open NC, "< $file") {
309         $!==&ENOENT or die $!;
310         return;
311     }
312     while (<NC>) {
313         chomp; s/^\s*//; s/\s+$//;
314         next if m/^\#/;
315         next unless m/\S/;
316         $newcommods{$_}= 1;
317     }
318     NC->error and die $!;
319     close NC or die $!;
320 }
321
322 sub refresh_newcommods() {
323     my $master= fetch_with_rsync('newcommods');
324     read_newcommods($master);
325     read_newcommods('_local-newcommods.txt');
326 }
327
328 our (%stallmap, @stallmap);
329
330 sub bs_gen_md ($$) {
331     my ($bs,$sortmul) = @_;
332     my $count= 0;
333     my $o= '';
334     
335     foreach $commod (
336                      sort { $pctb_commodmap{$a} <=> $pctb_commodmap{$b} }
337                      grep { exists $pctb_commodmap{$_} }
338                      keys %commod
339                      ) {
340 #print STDERR "COMMOD $commod\n";
341         $current= $commod{$commod};
342         my $l= bs_p($commod,$bs,$sortmul);
343         next unless @$l;
344 #print STDERR "COMMOD $commod  has ".scalar(@$l)."\n";
345         $o .= writeint($pctb_commodmap{$commod});
346         $o .= writeint(scalar @$l);
347         foreach my $cs (@$l) {
348             $stall= $cs->{Stall};
349             my $stallix= $stallmap{$stall};
350             if (!defined $stallix) {
351                 push @stallmap, $stall;
352                 $stallmap{$stall}= $stallix= @stallmap;
353 #print STDERR "STALL DEF $stallix $stall\n";
354             }
355             my $qty= $cs->{Qty};
356             $qty =~ s/^\>\s*//;
357             $o .= writeint($stallix, $cs->{Price}, $qty+0);
358             $count++;
359         }
360     }
361 #print STDERR "COMMOD $commod COUNT WAS $count\n";
362     return
363         writeint($count).$o;
364 }
365
366 sub writeint { return pack 'v*', @_; }
367
368 our (%stalltypetoabbrevmap)= qw(
369                                 Apothecary    A
370                                 Distilling    D
371                                 Furnishing    F
372                                 Ironworking   I
373                                 Shipbuilding  S
374                                 Tailoring     T
375                                 Weaving       W
376                                 );
377
378 sub genmarketdata () {
379     our $version= '005b';
380
381     parse_pctb_commodmap();
382     my @missing= grep { !exists $pctb_commodmap{$_} } keys %commod;
383     if (@missing) {
384         refresh_commodmap();
385         refresh_newcommods();
386         my $missing=0;
387         foreach $commod (sort keys %commod) {
388             next if exists $pctb_commodmap{$commod};
389             if (exists $newcommods{$commod}) {
390                 printf STDERR "Ignoring new commodity \`%s'!\n", $commod;
391             } else {
392                 printf STDERR "Unknown commodity \`%s'!\n", $commod;
393                 $missing++;
394             }
395         }
396         die "$missing unknown commoditi(es).".
397             "  See README (search for \`newcommods').\n"
398             if $missing;
399     }    
400
401     my $ob='';
402     $ob .= bs_gen_md(Buy, -1);
403     $ob .= bs_gen_md(Sell,+1);
404
405     my $ot= sprintf("$version\n".
406                     "%d\n",
407                     scalar(@stallmap));
408     foreach $stall (@stallmap) {
409         my $st= $stall;
410         if ($st =~ m/^(\S+)\'s (\S+) Stall$/) {
411             my $stkind= $stalltypetoabbrevmap{$2};
412             if (defined $stkind) {
413                 $st= "$1^$stkind";
414             } else {
415                 warn "unknown stall type $2 in $st\n";
416             }
417         }
418         $ot .= "$st\n";
419     }
420     return $ot.$ob;
421 }
422
423 sub main__genmarketdata () {
424     my $o= genmarketdata();
425     print $o or die $!;
426 }
427
428 sub save_upload_html ($$) {
429     my ($which, $resptxt) = @_;
430     open R, ">./_upload-$which.html" or die $!;
431     print R $resptxt or die $!;
432     close R or die $!;
433 }
434
435 sub gzip ($) {
436     my ($raw) = @_;
437     my $tf= pipethrough_prep();
438     print $tf $raw or die $!;
439     return pipethrough_run($tf,undef,'gzip','gzip');
440 }
441
442 sub main__uploadyarrg () {
443     my %o;
444
445     parse_info_clientside();
446
447     $o{'ocean'}= $ENV{'YPPSC_OCEAN'} or die;
448     $o{'island'}= $ENV{'YPPSC_ISLAND'} or die;
449     $o{'timestamp'}= $ENV{'YPPSC_DATA_TIMESTAMP'} or die;
450
451     my $tf= pipethrough_prep();
452     write_tsv($tf);
453     my $oz= pipethrough_run_gzip($tf);
454     $o{'data'}=  [ undef, 'deduped.tsv.gz',
455                     Content_Type => 'application/octet-stream',
456                     Content => $oz ];
457
458     my $respcontent= yarrgpostform($ua, \%o);
459     $respcontent =~ m/^OK\b/ or die "$respcontent ?";
460     $respcontent =~ s/^/ /mg;
461     print $respcontent,"\n";
462 }
463
464 sub main__uploadpctb () {
465     my $ocean= $ENV{'YPPSC_OCEAN'};  die unless $ocean;
466     my $island= $ENV{'YPPSC_ISLAND'};  die unless $island;
467     die unless $pctb;
468     my $o= genmarketdata();
469     $pctb =~ s,/*$,,;
470     my $url= "$pctb/upload.php";
471     my $content= {
472         'marketdata' => [ undef, "marketdata.gz",
473                           Content_Type => 'application/gzip',
474                           Content => gzip($o),
475                           ]
476                       };
477
478     print STDERR "Uploading data to $pctb...\n";
479
480     my $resp= $ua->post("$url", Content => $content,
481                         Content_Type => 'form-data');
482     die $resp->status_line unless $resp->is_success;
483
484     my $resptxt= $resp->content();
485     save_upload_html('1', $resptxt);
486
487     open R, ">./_upload-1.html" or die $!;
488     print R $resptxt or die $!;
489     close R or die $!;
490
491     my @filenames= $resptxt =~
492  m/input\s+type="hidden"\s+name="filename"\s+value=\"([_.0-9a-z]+)\"/ig;
493     @filenames or die;
494
495     my @forcerls= $resptxt =~
496  m/input\s+type="hidden"\s+name="forcereload"\s+value=\"([1-9]\d+)\"/ig;
497     @forcerls or die;
498
499     my $filename= $filenames[0];
500     my $forcerl= $forcerls[0];
501
502     $ocean= ucfirst lc $ocean;
503     my @oceanids= $resptxt =~
504  m/\<option value\=\"(\d+)\"\>$ocean\<\/option\>/;
505     @oceanids==1 or die "@oceanids ?";
506
507     my $islandid;
508     while ($resptxt =~
509  m/^islands\[\d+\]\[\d+\]\=new\s+option\(\"(.*)\"\,(\d+)\)\s*$/mig
510            ) {
511         next unless $1 eq $island;
512         $islandid= $2;
513     }
514     defined $islandid or die;
515
516     die "@filenames ?" if grep { $_ ne $filename } @filenames;
517     die "@forcerls ?" if grep { $_ ne $forcerl } @forcerls;
518
519     my $setisland= {
520     };
521
522     print STDERR "Setting ocean and island...\n";
523
524     my $siurl= ($url . "?action=setisland".
525                 "&filename=$filename".
526                 "&forcereload=$forcerl".
527                 "&ocean=$oceanids[0]".
528                 "&island=$islandid");
529     $resp= $ua->get($siurl);
530
531     die $resp->status_line unless $resp->is_success;
532
533     $resptxt= $resp->content();
534     save_upload_html('2', $resptxt);
535
536     die unless $resptxt =~ m/your uploaded data has been processed/i;
537     die unless $resptxt =~ m/your data has been integrated into the database/i;
538
539     $resptxt =~ s/\<a href=\"about:\w+\"\>[^<>]+\<\/a\>//g;
540     save_upload_html('3', $resptxt);
541
542     print "\n" or die $!;
543     system('w3m -T text/html -dump < _upload-3.html');
544     
545     print "\n" or die $!;
546 }
547
548
549 $mode =~ s/\-//;
550 &{"main__$mode"};
551 close(STDOUT) or die $!;