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