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