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