chiark / gitweb /
Leave PCTB server text in #upload-1#.html
[ypp-sc-tools.web-live.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     my $resp= $ua->get("$pctb/commodmap.php?version=2");
240     die $resp->status_line unless $resp->is_success;
241
242     my $cdata='';
243     my $incommodmap=0;
244     my $intag='';
245     my %got;
246     my $o= new IO::File "#commodmap#.tsv.new",'w' or die $!;
247     undef %commodmap;
248
249     my $xp= new XML::Parser
250         (Handlers =>
251          {
252              Start => sub {
253                  $_=$_[1];
254 #print STDERR "START [$_] intag=$intag icm=$incommodmap\n";
255                  if (m/^commodmap$/i) {
256                      $incommodmap++;
257                      undef %got;
258                  } elsif (m/^(?:name|index)$/i) {
259                      $cdata='';
260                      $intag=lc($_) if $incommodmap;
261 #print STDERR "START RECOGNISED $intag icm=$incommodmap\n";
262 #                } else {
263 #print STDERR "START UNRECOGNISED\n";
264                  }
265              },
266              End => sub {
267                  $_=$_[1];
268 #print STDERR "END [$_] intag=$intag icm=$incommodmap\n";
269                  if (m/^commodmap$/i) {
270                      $incommodmap--;
271                      die unless exists $got{'name'};
272                      die unless exists $got{'index'};
273                      die unless $got{'index'} =~ m/^\s*([1-9]\d{0,3})\s*$/;
274                      my $index= $1;
275                      $_= $got{'name'};
276                      s/^\s+//; s/\s+$//; s/\n/ /g; s/\s+/ /;
277                      die "$_ ?" if exists $commodmap{$_};
278                      $commodmap{$_}= $index;
279                      print $o "$_\t$index\n" or die $!;
280                  } elsif (lc $_ eq $intag) {
281                      $got{$intag}= $cdata;
282                  }
283              },
284              Char => sub {
285 #print STDERR "CHAR [$_[1]] intag=$intag icm=$incommodmap\n";
286                  $cdata .= $_[1];
287              }
288          }) or die;
289     my $content= $resp->content;
290
291 #    print STDERR "[[[$content]]]\n";
292     $xp->parse($content);
293     close $o or die $!;
294     rename "#commodmap#.tsv.new","#commodmap#.tsv" or die $!;
295 }
296
297 our (%stallmap, @stallmap);
298
299 sub bs_gen_md ($$) {
300     my ($bs,$sortmul) = @_;
301     my $count= 0;
302     my $o= '';
303     
304     foreach $commod (sort {
305         $commodmap{$a} <=> $commodmap{$b}
306     } keys %commod) {
307 #print STDERR "COMMOD $commod\n";
308         $current= $commod{$commod};
309         my $l= bs_p($commod,$bs,$sortmul);
310         next unless @$l;
311 #print STDERR "COMMOD $commod  has ".scalar(@$l)."\n";
312         $o .= writeint($commodmap{$commod});
313         $o .= writeint(scalar @$l);
314         foreach my $cs (@$l) {
315             $stall= $cs->{Stall};
316             my $stallix= $stallmap{$stall};
317             if (!defined $stallix) {
318                 push @stallmap, $stall;
319                 $stallmap{$stall}= $stallix= @stallmap;
320 #print STDERR "STALL DEF $stallix $stall\n";
321             }
322             my $qty= $cs->{Qty};
323             $qty =~ s/^\>\s*//;
324             $o .= writeint($stallix, $cs->{Price}, $qty+0);
325             $count++;
326         }
327     }
328 #print STDERR "COMMOD $commod COUNT WAS $count\n";
329     return
330         writeint($count).$o;
331 }
332
333 sub writeint { return pack 'v*', @_; }
334
335 our (%stalltypetoabbrevmap)= qw(
336                                 Apothecary    A
337                                 Distilling    D
338                                 Furnishing    F
339                                 Ironworking   I
340                                 Shipbuilding  S
341                                 Tailoring     T
342                                 Weaving       W
343                                 );
344
345 sub genmarketdata () {
346     our $version= '005b';
347
348     load_commodmap();
349     my @missing= grep { !exists $commodmap{$_} } keys %commod;
350     if (@missing) {
351         refresh_commodmap();
352         my $missing=0;
353         foreach $commod (sort keys %commod) {
354             next if exists $commodmap{$commod};
355             printf STDERR "Unknown commodity \`%s'!\n", $commod;
356             $missing++;
357         }
358         die "$missing unknown commoditi(es).  OCR failure?\n"
359             if $missing;
360     }    
361
362     my $ob='';
363     $ob .= bs_gen_md(Buy, -1);
364     $ob .= bs_gen_md(Sell,+1);
365
366     my $ot= sprintf("$version\n".
367                     "%d\n",
368                     scalar(@stallmap));
369     foreach $stall (@stallmap) {
370         my $st= $stall;
371         if ($st =~ m/^(\S+)\'s (\S+) Stall$/) {
372             my $stkind= $stalltypetoabbrevmap{$2};
373             if (defined $stkind) {
374                 $st= "$1^$stkind";
375             } else {
376                 warn "unknown stall type $2 in $st\n";
377             }
378         }
379         $ot .= "$st\n";
380     }
381     return $ot.$ob;
382 }
383
384 sub main__genmarketdata () {
385     my $o= genmarketdata();
386     print $o or die $!;
387 }
388
389 sub main__upload () {
390     my $ocean= $ENV{'YPPSC_OCEAN'};  die unless $ocean;
391     my $island= $ENV{'YPPSC_ISLAND'};  die unless $island;
392     die unless $pctb;
393     my $o= genmarketdata();
394     my $url= "$pctb/upload.php";
395     my $content= {
396         'marketdata' => [ undef, "marketdata.gz",
397                           Content_Type => 'application/gzip',
398                           Content => $o
399                           ]
400                       };
401     my $resp= $ua->post("$url", Content => $content,
402                         Content_Type => 'form-data');
403     die $resp->status_line unless $resp->is_success;
404
405     my $resptxt= $resp->content();
406
407     open R, ">./#upload-1#.html" or die $!;
408     print R $resptxt or die $!;
409     close R or die $!;
410
411     my @filenames= $resptxt =~
412  m/input\s+type="hidden"\s+name="filename"\s+value=\"([_.0-9a-z]+)\"/ig;
413     @filenames or die;
414
415     my @forcerls= $resptxt =~
416  m/input\s+type="hidden"\s+name="forcereload"\s+value=\"([1-9]\d+)\"/ig;
417     @forcerls or die;
418
419     my $filename= $filenames[0];
420     my $forcerl= $forcerls[0];
421
422 #print "[[[ $resptxt ]]]\n";
423
424 #    my $setsland= {
425 #       'action' => 'setisland'
426 #       'filename' => $filename,
427 #       'forcereload' => $forcerl,
428 #    my $url_setisland= "$url
429 #
430 #http://pctb.ilk.org/upload.php?&ocean=2&island=48&action=setisland&forcereload=1244748679&filename=PFayDW' >v.html 
431 #    
432     print ">$filename|$forcerl|@oceanids|$islandid<\n";
433
434     system 'printenv|grep YPP|sort';
435 }
436
437
438 $mode =~ s/\-//;
439 &{"main__$mode"};
440 close(STDOUT) or die $!;