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