yarrg/web/routetrade

   1 <%doc>
   2
   3  This is part of the YARRG website.  YARRG is a tool and website
   4  for assisting players of Yohoho Puzzle Pirates.
   5
   6  Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
   7  Copyright (C) 2009 Clare Boothby
   8
   9   YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later).
  10   The YARRG website is covered by the GNU Affero GPL v3 or later, which
  11    basically means that every installation of the website will let you
  12    download the source.
  13
  14  This program is free software: you can redistribute it and/or modify
  15  it under the terms of the GNU Affero General Public License as
  16  published by the Free Software Foundation, either version 3 of the
  17  License, or (at your option) any later version.
  18
  19  This program is distributed in the hope that it will be useful,
  20  but WITHOUT ANY WARRANTY; without even the implied warranty of
  21  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22  GNU Affero General Public License for more details.
  23
  24  You should have received a copy of the GNU Affero General Public License
  25  along with this program.  If not, see <http://www.gnu.org/licenses/>.
  26
  27  Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
  28  are used without permission.  This program is not endorsed or
  29  sponsored by Three Rings.
  30
  31
  32  This Mason component is the core trade planner for a specific route.
  33
  34
  35 </%doc>
  36 <%args>
  37 $dbh
  38 @islandids
  39 @archipelagoes
  40 $qa
  41 $routeparams
  42 </%args>
  43 <& query_age:pageload &>
  44
  45 <%perl>
  46
  47 my $loss_per_league= defined $routeparams->{LossPerLeaguePct}
  48         ? $routeparams->{LossPerLeaguePct}*0.01 : 1e-7;
  49 my $loss_per_delay_slot= 1e-8;
  50
  51 my $now= time;
  52
  53 my @flow_conds;
  54 my @query_params;
  55 my %dists;
  56 my $expected_total_profit;
  57
  58 my $sd_condition= sub {
  59         my ($bs, $ix) = @_;
  60         my $islandid= $islandids[$ix];
  61         if (defined $islandid) {
  62                 return "${bs}.islandid = $islandid";
  63         } else {
  64                 push @query_params, $archipelagoes[$ix];
  65                 return "${bs}_islands.archipelago = ?";
  66         }
  67 };
  68
  69 my $specific= !grep { !defined $_ } @islandids;
  70
  71 my %ipair2subflowinfs;
  72 # $ipair2subflowinfs{$orgi,$dsti}= [ [$orgix,$distix], ... ]
  73
  74 my @subflows;
  75 # $subflows[0]{Flow} = { ... }
  76 # $subflows[0]{Org} = $orgix
  77 # $subflows[0]{Dst} = $dstix
  78
  79 foreach my $org_i (0..$#islandids) {
  80         my $org_isle= $islandids[$org_i];
  81         my $org_cond= $sd_condition->('sell',$org_i);
  82         my @dst_conds;
  83         foreach my $dst_i ($org_i..$#islandids) {
  84                 my $dst_isle= $islandids[$dst_i];
  85                 # Don't ever consider sailing things round the houses:
  86                 next if defined $dst_isle and
  87                         grep { $dst_isle == $_ } @islandids[$org_i..$dst_i-1];
  88                 next if defined $org_isle and
  89                         grep { $org_isle == $_ } @islandids[$org_i+1..$dst_i];
  90                 my $dst_cond;
  91                 if ($dst_i==$org_i and !defined $org_isle) {
  92                         # we always want arbitrage, but mentioning an arch
  93                         # once shouldn't produce intra-arch trades
  94                         $dst_cond= "sell.islandid = buy.islandid";
  95                 } else {
  96                         $dst_cond= $sd_condition->('buy',$dst_i);
  97                 }
  98                 push @dst_conds, $dst_cond;
  99
 100                 if ($specific) {
 101                         push @{ $ipair2subflowinfs{$org_isle,$dst_isle} },
 102                                 [ $org_i, $dst_i ];
 103                 }
 104         }
 105         push @flow_conds, "$org_cond AND (
 106                         ".join("
 107                      OR ",@dst_conds)."
 108                 )";
 109 }
 110
 111 my $stmt= "
 112         SELECT  sell_islands.islandname                         org_name,
 113                 sell_islands.islandid                           org_id,
 114                 sell.price                                      org_price,
 115                 sell.qty                                        org_qty_stall,
 116                 sell_stalls.stallname                           org_stallname,
 117                 sell.stallid                                    org_stallid,
 118                 sell_uploads.timestamp                          org_timestamp,
 119                 buy_islands.islandname                          dst_name,
 120                 buy_islands.islandid                            dst_id,
 121                 buy.price                                       dst_price,
 122                 buy.qty                                         dst_qty_stall,
 123                 buy_stalls.stallname                            dst_stallname,
 124                 buy.stallid                                     dst_stallid,
 125                 buy_uploads.timestamp                           dst_timestamp,
 126 ".($qa->{ShowStalls} ? "
 127                 sell.qty                                        org_qty_agg,
 128                 buy.qty                                         dst_qty_agg,
 129 " : "
 130                 (SELECT sum(qty) FROM sell AS sell_agg
 131                   WHERE sell_agg.commodid = commods.commodid
 132                   AND   sell_agg.islandid = sell.islandid
 133                   AND   sell_agg.price = sell.price)            org_qty_agg,
 134                 (SELECT sum(qty) FROM buy AS buy_agg
 135                   WHERE buy_agg.commodid = commods.commodid
 136                   AND   buy_agg.islandid = buy.islandid
 137                   AND   buy_agg.price = buy.price)              dst_qty_agg,
 138 ")."
 139                 commods.commodname                              commodname,
 140                 commods.commodid                                commodid,
 141                 commods.unitmass                                unitmass,
 142                 commods.unitvolume                              unitvolume,
 143                 commods.ordval                                  ordval,
 144                 commods.posinclass                              posinclass,
 145                 commods.commodclassid                           commodclassid,
 146                 dist                                            dist,
 147                 buy.price - sell.price                          unitprofit
 148         FROM commods
 149         JOIN sell ON commods.commodid = sell.commodid
 150         JOIN buy  ON commods.commodid = buy.commodid
 151         JOIN islands AS sell_islands ON sell.islandid = sell_islands.islandid
 152         JOIN islands AS buy_islands  ON buy.islandid  = buy_islands.islandid
 153         JOIN uploads AS sell_uploads ON sell.islandid = sell_uploads.islandid
 154         JOIN uploads AS buy_uploads  ON buy.islandid  = buy_uploads.islandid
 155         JOIN stalls  AS sell_stalls  ON sell.stallid  = sell_stalls.stallid
 156         JOIN stalls  AS buy_stalls   ON buy.stallid   = buy_stalls.stallid
 157         JOIN dists ON aiid = sell.islandid AND biid = buy.islandid
 158         WHERE   (
 159                 ".join("
 160            OR   ", @flow_conds)."
 161         )
 162           AND   buy.price > sell.price
 163         ORDER BY org_name, dst_name, commodname, unitprofit DESC,
 164                  org_price, dst_price DESC,
 165                  org_stallname, dst_stallname
 166      ";
 167
 168 my $sth= $dbh->prepare($stmt);
 169 $sth->execute(@query_params);
 170 my @flows;
 171
 172 my $distquery= $dbh->prepare("
 173                 SELECT dist FROM dists WHERE aiid = ? AND biid = ?
 174                 ");
 175 my $distance= sub {
 176         my ($from,$to)= @_;
 177         my $d= $dists{$from}{$to};
 178         return $d if defined $d;
 179         $distquery->execute($from,$to);
 180         $d = $distquery->fetchrow_array();
 181         defined $d or die "$from $to ?";
 182         $dists{$from}{$to}= $d;
 183         return $d;
 184 };
 185
 186 my @cols= ({ NoSort => 1 });
 187
 188 my $addcols= sub {
 189         my $base= shift @_;
 190         foreach my $name (@_) {
 191                 my $col= { Name => $name, %$base };
 192                 $col->{Numeric}=1 if !$col->{Text};
 193                 push @cols, $col;
 194         }
 195 };
 196
 197 if ($qa->{ShowStalls}) {
 198         $addcols->({ Text => 1 }, qw(
 199                 org_name org_stallname
 200                 dst_name dst_stallname
 201         ));
 202 } else {
 203         $addcols->({Text => 1 }, qw(
 204                 org_name dst_name
 205         ));
 206 }
 207 $addcols->({ Text => 1 }, qw(commodname));
 208 $addcols->({ DoReverse => 1 },
 209         qw(     org_price org_qty_agg dst_price dst_qty_agg
 210         ));
 211 $addcols->({ DoReverse => 1, SortColKey => 'MarginSortKey' },
 212         qw(     Margin
 213         ));
 214 $addcols->({ DoReverse => 1 },
 215         qw(     unitprofit MaxQty MaxCapital MaxProfit dist
 216         ));
 217 foreach my $v (qw(MaxMass MaxVolume)) {
 218    $addcols->({
 219         DoReverse => 1, Total => 0, SortColKey => "${v}SortKey" }, $v);
 220 }
 221
 222 </%perl>
 223
 224 % if ($qa->{'debug'}) {
 225 <pre>
 226 <% $stmt |h %>
 227 <% join(' | ',@query_params) |h %>
 228 </pre>
 229 % }
 230
 231 <& dumptable:start, qa => $qa, sth => $sth &>
 232 % {
 233 %   my $got;
 234 %   while ($got= $sth->fetchrow_hashref()) {
 235 <%perl>
 236
 237         my $f= $flows[$#flows];
 238         if (    !$f ||
 239                 $qa->{ShowStalls} ||
 240                 grep { $f->{$_} ne $got->{$_} }
 241                         qw(org_id org_price dst_id dst_price commodid)
 242         ) {
 243                 # Make a new flow rather than adding to the existing one
 244
 245                 $f= {
 246                         Ix => scalar(@flows),
 247                         %$got
 248                 };
 249                 $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
 250                         if !$qa->{ShowStalls};
 251                 push @flows, $f;
 252         }
 253         foreach my $od (qw(org dst)) {
 254                 $f->{"${od}Stalls"}{
 255                         $got->{"${od}_stallname"}
 256                     } =
 257                         $got->{"${od}_qty_stall"}
 258                     ;
 259         }
 260
 261 </%perl>
 262 <& dumptable:row, qa => $qa, sth => $sth, row => $f &>
 263 %    }
 264 <& dumptable:end, qa => $qa &>
 265 % }
 266
 267 % if (@islandids==1) {
 268 %       if (defined $islandids[0]) {
 269 Searched for arbitrage trades only.
 270 %       } else {
 271 Searched for arbitrage trades only, in <% $archipelagoes[0] |h %>
 272 <a href="docs#arbitrage">[?]</a>.
 273 %       }
 274 % }
 275
 276 <%perl>
 277
 278 my @sail_total;
 279
 280 if (!@flows) {
 281         print 'No profitable trading opportunities were found.';
 282         return;
 283 }
 284
 285 foreach my $f (@flows) {
 286
 287         $f->{MaxQty}= $f->{'org_qty_agg'} < $f->{'dst_qty_agg'}
 288                 ? $f->{'org_qty_agg'} : $f->{'dst_qty_agg'};
 289         $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
 290         $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
 291
 292         $f->{MaxMassSortKey}= $f->{MaxQty} * $f->{'unitmass'};
 293         $f->{MaxVolumeSortKey}= $f->{MaxQty} * $f->{'unitvolume'};
 294         foreach my $v (qw(Mass Volume)) {
 295                 $f->{"Max$v"}= sprintf "%.1f", $f->{"Max${v}SortKey"} * 1e-6;
 296         }
 297
 298         $f->{MarginSortKey}= sprintf "%d",
 299                 $f->{'dst_price'} * 10000 / $f->{'org_price'};
 300         $f->{Margin}= sprintf "%3.1f%%",
 301                 $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
 302
 303         $f->{ExpectedUnitProfit}=
 304                 $f->{'dst_price'} * (1.0 - $loss_per_league) ** $f->{'dist'}
 305                 - $f->{'org_price'};
 306
 307         $dists{'org_id'}{'dst_id'}= $f->{'dist'};
 308
 309         my @uid= $f->{commodid};
 310         foreach my $od (qw(org dst)) {
 311                 push @uid,
 312                         $f->{"${od}_id"},
 313                         $f->{"${od}_price"};
 314                 push @uid,
 315                         $f->{"${od}_stallid"}
 316                                 if $qa->{ShowStalls};
 317         }
 318         $f->{UidLong}= join '_', @uid;
 319
 320         my $base= 31;
 321         my $cmpu= '';
 322         map {
 323                 my $uue= $_;
 324                 my $first= $base;
 325                 do {
 326                         my $this= $uue % $base;
 327 #print STDERR "uue=$uue this=$this ";
 328                         $uue -= $this;
 329                         $uue /= $base;
 330                         $this += $first;
 331                         $first= 0;
 332                         $cmpu .= chr($this + ($this < 26 ? ord('a') :
 333                                               $this < 52 ? ord('A')-26
 334                                                          : ord('0')-52));
 335 #print STDERR " uue=$uue this=$this cmpu=$cmpu\n";
 336                         die "$cmpu $uue ?" if length $cmpu > 20;
 337                 } while ($uue);
 338                 $cmpu;
 339         } @uid;
 340         $f->{UidShort}= $cmpu;
 341
 342         if ($qa->{'debug'}) {
 343                 my @outuid;
 344                 $_= $f->{UidShort};
 345                 my $mul;
 346                 while (m/./) {
 347                         my $v= m/^[a-z]/ ? ord($&)-ord('a') :
 348                                m/^[A-Z]/ ? ord($&)-ord('A')+26 :
 349                                m/^[0-9]/ ? ord($&)-ord('0')+52 :
 350                                die "$_ ?";
 351                         if ($v >= $base) {
 352                                 push @outuid, 0;
 353                                 $v -= $base;
 354                                 $mul= 1;
 355 #print STDERR "(next)\n";
 356                         }
 357                         die "$f->{UidShort} $_ ?" unless defined $mul;
 358                         $outuid[$#outuid] += $v * $mul;
 359
 360 #print STDERR "$f->{UidShort}  $_  $&  v=$v  mul=$mul  ord()=".ord($&).
 361 #                       "[vs.".ord('a').",".ord('A').",".ord('0')."]".
 362 #                       "  outuid=@outuid\n";
 363
 364                         $mul *= $base;
 365                         s/^.//;
 366                 }
 367                 my $recons_long= join '_', @outuid;
 368                 $f->{UidLong} eq $recons_long or
 369                         die "$f->{UidLong} = $f->{UidShort} = $recons_long ?";
 370         }
 371
 372         if (defined $qa->{"R$f->{UidShort}"} &&
 373             !defined $qa->{"T$f->{UidShort}"}) {
 374                 $f->{Suppress}= 1;
 375         } else {
 376                 my $sfis= $ipair2subflowinfs{$f->{'org_id'},$f->{'dst_id'}};
 377                 foreach my $sfi (@$sfis) {
 378                         my $subflow= {
 379                                 Flow => $f,
 380                                 Org => $sfi->[0],
 381                                 Dst => $sfi->[1],
 382                                 Var => sprintf "f%ss%s_c%d_p%d_%d_p%d_%d",
 383                                         $f->{Ix}, $sfi->[0],
 384                                         $f->{'commodid'},
 385                                         $sfi->[0], $f->{'org_price'},
 386                                         $sfi->[1], $f->{'dst_price'}
 387                         };
 388                         push @{ $f->{Subflows} }, $subflow;
 389                         push @subflows, $subflow;
 390                 }
 391         }
 392 }
 393 </%perl>
 394
 395 % my $optimise= $specific;
 396 % if (!$optimise) {
 397
 398 <p>
 399 % if (!$specific) {
 400 Route contains archipelago(es), not just specific islands.
 401 % }
 402 Therefore, optimal voyage trade plan not calculated.
 403
 404 % } else { # ========== OPTMISATION ==========
 405 <%perl>
 406
 407 my $cplex= "
 408 Maximize
 409
 410   totalprofit:
 411 ";
 412
 413 my %stall_poe_limits;
 414
 415 foreach my $sf (@subflows) {
 416         my $eup= $sf->{Flow}{ExpectedUnitProfit};
 417         $eup *= (1.0-$loss_per_delay_slot) ** $sf->{Org};
 418         $cplex .= sprintf "
 419                 %+.20f %s", $eup, $sf->{Var};
 420         if ($qa->{ShowStalls}>=2) {
 421                 my $stall= $sf->{Flow}{'dst_stallid'};
 422                 push @{ $stall_poe_limits{$stall} }, $sf;
 423         }
 424 }
 425 $cplex .= "
 426
 427 Subject To
 428 ";
 429
 430 my %avail_lims;
 431 foreach my $flow (@flows) {
 432         next if $flow->{Suppress};
 433         foreach my $od (qw(org dst)) {
 434                 my $limname= join '_', (
 435                         $od,
 436                         'i'.$flow->{"${od}_id"},
 437                         'c'.$flow->{'commodid'},
 438                         $flow->{"${od}_price"},
 439                         $flow->{"${od}_stallid"},
 440                 );
 441
 442                 push @{ $avail_lims{$limname}{SubflowVars} },
 443                         map { $_->{Var} } @{ $flow->{Subflows} };
 444                 $avail_lims{$limname}{Qty}= $flow->{"${od}_qty_agg"};
 445         }
 446 }
 447 foreach my $limname (sort keys %avail_lims) {
 448         my $c= $avail_lims{$limname};
 449         $cplex .=
 450                 sprintf("    %-30s","$limname:")." ".
 451                         join("+", @{ $c->{SubflowVars} }).
 452                         " <= ".$c->{Qty}."\n";
 453 }
 454
 455 foreach my $ci (0..($#islandids-1)) {
 456         my @rel_subflows;
 457
 458         foreach my $f (@flows) {
 459                 next if $f->{Suppress};
 460                 my @relsubflow= grep {
 461                         $_->{Org} <= $ci &&
 462                         $_->{Dst} > $ci;
 463                 } @{ $f->{Subflows} };
 464                 next unless @relsubflow;
 465                 die unless @relsubflow == 1;
 466                 push @rel_subflows, @relsubflow;
 467 #print " RELEVANT $ci $relsubflow[0]->{Var} ";
 468         }
 469 #print " RELEVANT $ci COUNT ".scalar(@rel_subflows)."  ";
 470         if (!@rel_subflows) {
 471                 foreach my $mv (qw(mass volume)) {
 472                         $sail_total[$ci]{$mv}= 0;
 473                 }
 474                 next;
 475         }
 476
 477         my $applylimit= sub {
 478                 my ($mv, $f2val) = @_;
 479                 my $max= $routeparams->{"Max".ucfirst $mv};
 480                 $max= 1e9 unless defined $max;
 481 #print " DEFINED MAX $mv $max ";
 482                 $cplex .= "
 483    ". sprintf("%-10s","${mv}_$ci:")." ".
 484                 join(" + ", map {
 485 #print " PART MAX $_->{Var} $_->{Flow}{Ix} ";
 486                         $f2val->($_->{Flow}) .' '. $_->{Var};
 487                 } @rel_subflows).
 488                 " <= $max";
 489         };
 490
 491         $applylimit->('mass',    sub { $_[0]{'unitmass'}  *1e-3 });
 492         $applylimit->('volume',  sub { $_[0]{'unitvolume'}*1e-3 });
 493         $applylimit->('capital', sub { $_[0]{'org_price'}       });
 494         $cplex.= "\n";
 495 }
 496
 497 if ($qa->{ShowStalls}>=2) {
 498         my $stallpoe= $dbh->prepare(<<END);
 499 SELECT max(qty*price) FROM buy WHERE stallid=?
 500 END
 501         foreach my $stallid (sort { $a <=> $b } keys %stall_poe_limits) {
 502                 $stallpoe->execute($stallid);
 503                 my ($lim)= $stallpoe->fetchrow_array();
 504                 $stallpoe->finish();
 505                 $cplex.= "
 506     ". sprintf("%-15s","poe_$stallid:")." ".
 507                 join(" + ", map {
 508                         sprintf "%d %s", $_->{Flow}{'dst_price'}, $_->{Var};
 509                 } @{ $stall_poe_limits{$stallid} }).
 510                 " <= $lim";
 511         }
 512         $cplex.= "\n";
 513 }
 514
 515 $cplex.= "
 516 Bounds
 517         ".(join "
 518         ", map { "$_->{Var} >= 0" } @subflows)."
 519
 520 ";
 521
 522 $cplex.= "
 523 Integer
 524         ".(join "
 525         ", map { $_->{Var} } @subflows)."
 526
 527 End
 528 ";
 529
 530 if ($qa->{'debug'}) {
 531 </%perl>
 532 <pre>
 533 <% $cplex |h %>
 534 </pre>
 535 <%perl>
 536 }
 537
 538 {
 539         my $input= pipethrough_prep();
 540         print $input $cplex or die $!;
 541         my $output= pipethrough_run_along($input, undef, 'glpsol',
 542                 qw(glpsol --tmlim 5 --memlim 5 --intopt --cuts --bfs
 543                           --cpxlp /dev/stdin -o /dev/stdout));
 544         print "<pre>\n" if $qa->{'debug'};
 545         my $found_section= 0;
 546         my $glpsol_out= '';
 547         my $continuation='';
 548         while (<$output>) {
 549                 $glpsol_out.= $_;
 550                 print encode_entities($_) if $qa->{'debug'};
 551                 if (m/^\s*No\.\s+(Row|Column) name\s+(?:St\s+)?Activity\s/) {
 552                         die "$_ $found_section ?" if $found_section>0;
 553                         $found_section= 1;
 554                         next;
 555                 }
 556                 if (m/^Objective:\s+totalprofit = (\d+(?:\.\d*)?) /) {
 557                         $expected_total_profit= $1;
 558                 }
 559                 next unless $found_section==1;
 560                 if (!length $continuation) {
 561                         next if !$continuation &&  m/^[- ]+$/;
 562                         if (!/\S/) {
 563                                 $found_section= 0;
 564                                 next;
 565                         }
 566                         if (m/^ \s* \d+ \s+ \w+ $/x) {
 567                                 $continuation= $&;
 568                                 next;
 569                         }
 570                 }
 571                 $_= $continuation.$_;
 572                 $continuation= '';
 573                 my ($varname, $qty) = m/^
 574                         \s* \d+ \s+
 575                         (\w+) \s+ (?: [A-Z*]+ \s+ )?
 576                         ([+-e0-9.]+) \s
 577                         /x or die "$cplex \n==\n $glpsol_out $_ ?";
 578                 if ($varname =~ m/^f(\d+)s(\d+)_/) {
 579                         my ($ix,$orgix) = ($1,$2);
 580                         my $flow= $flows[$ix] or die;
 581                         my @relsubflow= grep { $_->{Org} == $orgix }
 582                                 @{ $flow->{Subflows} };
 583                         die "$ix $orgix @relsubflow" unless @relsubflow == 1;
 584                         my $sf= $relsubflow[0];
 585                         $sf->{OptQty}= $qty;
 586                         $sf->{OptProfit}= $qty * $flow->{'unitprofit'};
 587                         $sf->{OptCapital}= $qty * $flow->{'org_price'};
 588                 } elsif ($varname =~ m/^(mass|volume)_(\d+)$/) {
 589                         my ($mv,$ix) = ($1,$2);
 590                         $sail_total[$ix]{$mv}= $qty;
 591                 }
 592         }
 593         print "</pre>\n" if $qa->{'debug'};
 594         my $prerr= "\n=====\n$cplex\n=====\n$glpsol_out\n=====\n ";
 595         pipethrough_run_finish($output,$prerr);
 596         map { defined $_->{OptQty} or die "$prerr $_->{Flow}{Ix}" } @subflows;
 597         defined $expected_total_profit or die "$prerr ?";
 598 };
 599
 600 $addcols->({ DoReverse => 1, TotalSubflows => 1, Special => sub {
 601         my ($flow,$col,$v,$spec) = @_;
 602         if ($flow->{ExpectedUnitProfit} < 0) {
 603                 $spec->{Span}= 3;
 604                 $spec->{String}= '(Small margin)';
 605                 $spec->{Align}= 'align=center';
 606         }
 607 } }, qw(
 608                 OptQty
 609         ));
 610 $addcols->({ Total => 0, DoReverse => 1, TotalSubflows => 1 }, qw(
 611                 OptCapital OptProfit
 612         ));
 613
 614 </%perl>
 615
 616 % } # ========== OPTIMISATION ==========
 617
 618 % if (!printable($m)) {
 619 <h2>Contents</h2>
 620 <ul>
 621 % if ($optimise) {
 622  <li><a href="#plan">Voyage trading plan</a>
 623   <ul>
 624    <li><a href="#summary">Summary statistics</a>
 625    <li>Printable:
 626          <input type=submit name=printable_pdf value="PDF">
 627          <input type=submit name=printable_html value="HTML">
 628          <input type=submit name=printable_ps value="PostScript">
 629          <input type=submit name=printable_pdf2 value="PDF 2-up">
 630          <input type=submit name=printable_ps2 value="PostScript 2-up">
 631   </ul>
 632 % }
 633  <li><a href="#dataage">Data age summary</a>
 634  <li><a href="#trades">Relevant trades</a>
 635 </ul>
 636 % } else {
 637 %       my @tl= gmtime $now or die $!;
 638 <p>
 639 Generated by YARRG at <strong><%
 640         sprintf "%04d-%02d-%02d %02d:%02d:%02d UTC",
 641                 $tl[5]+1900, @tl[4,3,2,1,0]
 642                         |h %></strong>.
 643 % }
 644
 645 % if ($optimise) { # ========== TRADING PLAN ==========
 646 %
 647 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
 648 %                               WHERE islandid = ?');
 649 % my %da_ages;
 650 % my $total_total= 0;
 651 % my $total_dist= 0;
 652 %
 653 <h2><a name="plan">Voyage trading plan</a></h2>
 654
 655 <table class="data" rules=groups <% printable($m) ? 'width=100%' : '' %> >
 656 % my $tbody= sub {
 657 %       if (!printable($m)) { return '<tbody>'; }
 658 %#  return "<tr><td colspan=7><hr>";
 659 %       my ($c)= qw(40 00)[$_[0]];
 660 %       return "<tr><td bgcolor=\"#${c}${c}${c}\" height=1 colspan=7>";
 661 % };
 662 %
 663 % foreach my $i (0..$#islandids) {
 664 <% $tbody->(1) %>
 665 <tr>
 666 %       $iquery->execute($islandids[$i]);
 667 %       my ($islandname) = $iquery->fetchrow_array();
 668 %       if (!$i) {
 669 <td colspan=2>
 670 <strong>Start at <% $islandname |h %></strong>
 671 <td colspan=2><a href="docs#posinclass">[what are these codes?]</a>
 672 <td>
 673 %       } else {
 674 %               my $this_dist= $distance->($islandids[$i-1],$islandids[$i]);
 675 %               $total_dist += $this_dist;
 676 <td colspan=5>
 677 <%perl>
 678                 my $total_value= 0;
 679                 foreach my $sf (@subflows) {
 680                         next unless $sf->{Org} < $i && $sf->{Dst} >= $i;
 681                         $total_value +=
 682                                 $sf->{OptQty} * $sf->{Flow}{'dst_price'};
 683                 }
 684 </%perl>
 685 <strong>Sail to <% $islandname |h %></strong>
 686 - <% $this_dist |h %> leagues,
 687  <% $total_value %>poe at risk
 688  </td>
 689 %       }
 690 <%perl>
 691      my $age_reported= 0;
 692      my %flowlists;
 693      #print "<tr><td colspan=7>" if $qa->{'debug'};
 694      foreach my $od (qw(org dst)) {
 695         #print " [[ i $i od $od " if $qa->{'debug'};
 696         foreach my $sf (@subflows) {
 697                 my $f= $sf->{Flow};
 698                 next unless $sf->{ucfirst $od} == $i;
 699                 #print " FLOW $f->{Ix} SUB #$sf->{Org}..$sf->{Dst} "
 700                 #       if $qa->{'debug'};
 701                 next unless $sf->{OptQty};
 702                 my $arbitrage= $f->{'org_id'} == $f->{'dst_id'};
 703                 die if $arbitrage and $sf->{Org} != $sf->{Dst};
 704                 my $price= $f->{"${od}_price"};
 705                 my $stallname= $f->{"${od}_stallname"};
 706                 my $todo= \$flowlists{$od}{
 707                                 (sprintf "%010d", $f->{'ordval'}),
 708                                 $f->{'commodname'},
 709                                 (sprintf "%07d", ($od eq 'dst' ?
 710                                                 9999999-$price : $price)),
 711                                 $stallname
 712                         };
 713                 $$todo= {
 714                         Qty => 0,
 715                         orgArbitrage => 0,
 716                         dstArbitrage => 0,
 717                 } unless $$todo;
 718                 $$todo->{'commodname'}= $f->{'commodname'};
 719                 $$todo->{'posinclass'}= '';
 720                 my $incl= $f->{'posinclass'};
 721
 722                 my $findclass= $dbh->prepare(<<END);
 723 SELECT commodclass, maxposinclass FROM commodclasses WHERE commodclassid = ?
 724 END
 725                 $findclass->execute($f->{'commodclassid'});
 726                 my $classinfo= $findclass->fetchrow_hashref();
 727                 if ($classinfo) {
 728                         my $clname= $classinfo->{'commodclass'};
 729                         my $desc= encode_entities(sprintf "%s is under %s",
 730                                         $f->{'commodname'}, $clname);
 731                         my $abbrev= substr($clname,0,1);
 732                         if ($incl) {
 733                                 my $maxpic= $classinfo->{'maxposinclass'};
 734                                 $desc.= (sprintf ", commodity %d of %d",
 735                                         $incl, $maxpic);
 736                                 if ($classinfo->{'maxposinclass'} >= 8) {
 737                                         my @tmbs= qw(0 1 2 3 4 5 6 7 8 9);
 738                                         my $tmbi= ($incl+0.5)*$#tmbs/$maxpic;
 739                                         $abbrev.= " ".$tmbs[$tmbi]."&nbsp;";
 740                                 }
 741                         }
 742                         $$todo->{'posinclass'}=
 743                                 "<div class=mouseover title=\"$desc\">"
 744                                 .$abbrev."</div>";
 745                 }
 746                 $$todo->{'stallname'}= $stallname;
 747                 $$todo->{Price}= $price;
 748                 $$todo->{Timestamp}= $f->{"${od}_timestamp"};
 749                 $$todo->{Qty} += $sf->{OptQty};
 750                 $$todo->{Total}= $$todo->{Price} * $$todo->{Qty};
 751                 $$todo->{Stalls}= $f->{"${od}Stalls"};
 752                 $$todo->{"${od}Arbitrage"}= 1 if $arbitrage;
 753         }
 754         #print "]] " if $qa->{'debug'};
 755      }
 756      #print "</tr>" if $qa->{'debug'};
 757
 758      my ($total, $total_to_show);
 759      my $dline= 0;
 760      my $show_total= sub {
 761         my ($totaldesc, $sign) = @_;
 762         if (defined $total) {
 763                 die if defined $total_to_show;
 764                 $total_total += $sign * $total;
 765                 $total_to_show= [ $totaldesc, $total ];
 766                 $total= undef;
 767         }
 768         $dline= 0;
 769      };
 770      my $show_total_now= sub {
 771         my ($xinfo) = @_;
 772         return unless defined $total_to_show;
 773         my ($totaldesc,$totalwas) = @$total_to_show;
 774 </%perl>
 775 <tr>
 776 <td colspan=1>
 777 <td colspan=3><% $xinfo %>
 778 <td colspan=2 align=right><% $totaldesc %>
 779 <td align=right><% $totalwas |h %> total
 780 <%perl>
 781         $total_to_show= undef;
 782      };
 783 </%perl>
 784 %    my $show_flows= sub {
 785 %       my ($od,$arbitrage,$collectdeliver) = @_;
 786 %       my $todo= $flowlists{$od};
 787 %       return unless $todo;
 788 %       foreach my $tkey (sort keys %$todo) {
 789 %               my $t= $todo->{$tkey};
 790 %               next if $t->{"${od}Arbitrage"} != $arbitrage;
 791 %               $show_total_now->('');
 792 %               if (!$age_reported++) {
 793 %                       my $age= $now - $t->{Timestamp};
 794 %                       my $cellid= "da_${i}";
 795 %                       $da_ages{$cellid}= $age;
 796 <td colspan=2>\
 797 (Data age: <span id="<% $cellid %>"><% prettyprint_age($age) %></span>)
 798 %               } elsif (!defined $total) {
 799 %                       $total= 0;
 800 <% $tbody->(0) %>
 801 %               }
 802 %               $total += $t->{Total};
 803 %               my $span= 0 + keys %{ $t->{Stalls} };
 804 %               my $td= "td rowspan=$span";
 805 % tr_datarow($m,$dline);
 806 <<% $td %>><% $collectdeliver %>
 807 <<% $td %>><% $t->{'commodname'} |h %>
 808 <<% $td %>><% $t->{'posinclass'} %>
 809 %
 810 %               my @stalls= sort keys %{ $t->{Stalls} };
 811 %               my $pstall= sub {
 812 %                       my $name= $stalls[$_[0]];
 813 <td><% $name |h %>
 814 %               };
 815 %
 816 %               $pstall->(0);
 817 <<% $td %> align=right><% $t->{Price} |h %> poe ea.
 818 <<% $td %> align=right><% $t->{Qty} |h %> unit(s)
 819 <<% $td %> align=right><% $t->{Total} |h %> total
 820 %
 821 %               foreach my $stallix (1..$#stalls) {
 822 % tr_datarow($m,$dline);
 823 %                       $pstall->($stallix);
 824 %               }
 825 %
 826 %               $dline ^= 1;
 827 %       }
 828 %    };
 829 <%perl>
 830
 831      $show_flows->('dst',0,'Deliver'); $show_total->('Proceeds',1);
 832      $show_flows->('org',1,'Collect'); $show_total->('(Arbitrage) outlay',-1);
 833      $show_flows->('dst',1,'Deliver'); $show_total->('(Arbitrage) proceeds',1);
 834      $show_flows->('org',0,'Collect'); $show_total->('Outlay',-1);
 835      my $totals= '';
 836      if ($i < $#islandids) {
 837         $totals .=      "In hold $sail_total[$i]{mass}kg,".
 838                         " $sail_total[$i]{volume} l";
 839         my $delim= '; spare ';
 840         my $domv= sub {
 841                 my ($max, $got, $units) = @_;
 842                 return unless defined $max;
 843                 $totals .= $delim;
 844                 $totals .= sprintf "%g %s", ($max-$got), $units;
 845                 $delim= ', ';
 846         };
 847         $domv->($routeparams->{MaxMass},   $sail_total[$i]{mass},   'kg');
 848         $domv->($routeparams->{MaxVolume}, $sail_total[$i]{volume}, 'l');
 849         $totals .= ".\n";
 850      }
 851      $show_total_now->($totals);
 852 }
 853 </%perl><a name="summary"></a>
 854 <% $tbody->(1) %><tr>
 855 <td colspan=3>Total distance: <% $total_dist %> leagues.
 856 <td colspan=3 align=right>Overall net cash flow
 857 <td align=right><strong><%
 858   $total_total < 0 ? -$total_total." loss" : $total_total." gain"
 859  %></strong>
 860 </table>
 861 <& query_age:dataages, id2age => \%da_ages &>
 862 Expected average profit:
 863  approx. <strong><% sprintf "%d", $expected_total_profit %></strong> poe
 864  (considering expected losses, but ignoring rum consumed)
 865 %
 866 % } # ========== TRADING PLAN ==========
 867
 868 % if (!printable($m)) {
 869 <h2><a name="dataage">Data age summary</a></h2>
 870 <%perl>
 871         my $sth_i= $dbh->prepare(<<END);
 872                 SELECT archipelago, islandid, islandname, timestamp
 873                         FROM uploads NATURAL JOIN islands
 874                         WHERE islandid = ?
 875 END
 876         my $sth_a= $dbh->prepare(<<END);
 877                 SELECT archipelago, islandid, islandname, timestamp
 878                         FROM uploads NATURAL JOIN islands
 879                         WHERE archipelago = ?
 880                         ORDER BY islandname
 881 END
 882         my $ix=$#islandids;
 883         my $sth_current;
 884         my %idone;
 885         my $fetchrow= sub {
 886                 for (;;) {
 887                         if ($sth_current) {
 888                                 my $row= $sth_current->fetchrow_hashref();
 889                                 if ($row) {
 890                                         next if $idone{$row->{'islandid'}}++;
 891                                         return $row;
 892                                 }
 893                         }
 894                         return undef if $ix < 0;
 895                         my $iid= $islandids[$ix];
 896                         if (defined $iid) {
 897                                 $sth_i->execute($iid);
 898                                 $sth_current= $sth_i;
 899                         } else {
 900                                 my $arch= $archipelagoes[$ix];
 901                                 die unless defined $arch && length $arch;
 902                                 $sth_a->execute($arch);
 903                                 $sth_current= $sth_a;
 904                         }
 905                         $ix--;
 906                 }
 907         };
 908 </%perl>
 909 <&| query_age:agestable, now => $now, fetchrow => $fetchrow &>
 910 Islands shown in reverse order of visits.<br>
 911 </&>
 912 % }
 913
 914 % if (!printable($m)) {
 915 %   my %ts_sortkeys;
 916 %   {
 917 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
 918 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
 919 <h2><a name="trades">Relevant trades</a></h2>
 920 <table class="data" id="trades" rules=groups>
 921 <colgroup span=1>
 922 <colgroup span=2>
 923 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
 924 <colgroup span=1>
 925 <colgroup span=2>
 926 <colgroup span=2>
 927 <colgroup span=2>
 928 <colgroup span=3>
 929 <colgroup span=3>
 930 %       if ($optimise) {
 931 <colgroup span=3>
 932 %       }
 933 <tr>
 934 <th>
 935 <th<% $cdspan %>>Collect
 936 <th<% $cdspan %>>Deliver
 937 <th>
 938 <th colspan=2>Collect
 939 <th colspan=2>Deliver
 940 <th colspan=2>Profit
 941 <th colspan=3>Max
 942 <th colspan=1>
 943 <th colspan=2>Max
 944 %       if ($optimise) {
 945 <th colspan=3>Planned
 946 %       }
 947
 948 <tr>
 949 <th>
 950 <th>Island <% $cdstall %>
 951 <th>Island <% $cdstall %>
 952 <th>Commodity
 953 <th>Price
 954 <th>Qty
 955 <th>Price
 956 <th>Qty
 957 <th>Margin
 958 <th>Unit
 959 <th>Qty
 960 <th>Capital
 961 <th>Profit
 962 <th>Dist
 963 <th>Mass
 964 <th>Vol
 965 %       if ($optimise) {
 966 <th>Qty
 967 <th>Capital
 968 <th>Profit
 969 %       }
 970 %   }
 971
 972 <tr id="trades_sort">
 973 %   foreach my $col (@cols) {
 974 <th>
 975 %   }
 976
 977 %   foreach my $flowix (0..$#flows) {
 978 %       my $flow= $flows[$flowix];
 979 %       my $rowid= "id_row_$flow->{UidShort}";
 980 <tr id="<% $rowid %>" class="datarow<% $flowix & 1 %>">
 981 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
 982     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
 983        <% $flow->{Suppress} ? '' : 'checked' %> >
 984 %       my $ci= 1;
 985 %       while ($ci < @cols) {
 986 %               my $col= $cols[$ci];
 987 %               my $spec= {
 988 %                       Span => 1,
 989 %                       Align => ($col->{Text} ? '' : 'align=right')
 990 %               };
 991 %               my $cn= $col->{Name};
 992 %               my $v;
 993 %               if (!$col->{TotalSubflows}) {
 994 %                       $v= $flow->{$cn};
 995 %               } else {
 996 %                       $v= 0;
 997 %                       $v += $_->{$cn} foreach @{ $flow->{Subflows} };
 998 %               }
 999 %               if ($col->{Special}) { $col->{Special}($flow,$col,$v,$spec); }
1000 %               $col->{Total} += $v
1001 %                       if defined $col->{Total} and not $flow->{Suppress};
1002 %               $v='' if !$col->{Text} && !$v;
1003 %               my $sortkey= $col->{SortColKey} ?
1004 %                       $flow->{$col->{SortColKey}} : $v;
1005 %               $ts_sortkeys{$ci}{$rowid}= $sortkey;
1006 <td <% $spec->{Span} ? "colspan=$spec->{Span}" : ''
1007  %> <% $spec->{Align}
1008  %>><% exists $spec->{String} ? $spec->{String} : $v |h %>
1009 %               $ci += $spec->{Span};
1010 %       }
1011 %   }
1012 <tr id="trades_total">
1013 <th>
1014 <th colspan=2>Total
1015 %   foreach my $ci (3..$#cols) {
1016 %       my $col= $cols[$ci];
1017 <td align=right>
1018 %       if (defined $col->{Total}) {
1019 <% $col->{Total} |h %>
1020 %       }
1021 %   }
1022 </table>
1023
1024 <&| tabsort, cols => \@cols, table => 'trades', rowclass => 'datarow',
1025         throw => 'trades_sort', tbrow => 'trades_total' &>
1026   ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
1027 </&tabsort>
1028 <p>
1029 <input type=submit name=update value="Update">
1030
1031 % } # !printable
1032
1033 <%init>
1034 use CommodsWeb;
1035 use Commods;
1036 </%init>