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
 423 % if (!$specific) {
 424 %       $optimise= 0;
 425 Route contains archipelago(es), not just specific islands.
 426 % } elsif (!@subflows) {
 427 %       $optimise= 0;
 428 %       if ($any_previous_suppression) {
 429 All available trades deselected.
 430 %       } else {
 431 No available trades meet the specified minimum trade value, so
 432 all available trades deselected.
 433 %       }
 434 % }
 435
 436 % if (!$optimise) {
 437
 438 <p>
 439 Therefore, optimal voyage trade plan not calculated.
 440
 441 % } else { # ========== OPTMISATION ==========
 442 <%perl>
 443
 444 my $cplex= "
 445 Maximize
 446
 447   totalprofit:
 448 ";
 449
 450 my %stall_poe_limits;
 451
 452 foreach my $sf (@subflows) {
 453         my $eup= $sf->{Flow}{ExpectedUnitProfit};
 454         $eup *= (1.0-$loss_per_delay_slot) ** $sf->{Org};
 455         $cplex .= sprintf "
 456                 %+.20f %s", $eup, $sf->{Var};
 457         if ($qa->{ShowStalls}>=2) {
 458                 my $stall= $sf->{Flow}{'dst_stallid'};
 459                 push @{ $stall_poe_limits{$stall} }, $sf;
 460         }
 461 }
 462 $cplex .= "
 463
 464 Subject To
 465 ";
 466
 467 my %avail_lims;
 468 foreach my $flow (@flows) {
 469         next if $flow->{Suppress};
 470         foreach my $od (qw(org dst)) {
 471                 my $limname= join '_', (
 472                         $od,
 473                         'i'.$flow->{"${od}_id"},
 474                         'c'.$flow->{'commodid'},
 475                         $flow->{"${od}_price"},
 476                         $flow->{"${od}_stallid"},
 477                 );
 478
 479                 push @{ $avail_lims{$limname}{SubflowVars} },
 480                         map { $_->{Var} } @{ $flow->{Subflows} };
 481                 $avail_lims{$limname}{Qty}= $flow->{"${od}_qty_agg"};
 482         }
 483 }
 484 foreach my $limname (sort keys %avail_lims) {
 485         my $c= $avail_lims{$limname};
 486         $cplex .=
 487                 sprintf("    %-30s","$limname:")." ".
 488                         join("+", @{ $c->{SubflowVars} }).
 489                         " <= ".$c->{Qty}."\n";
 490 }
 491
 492 foreach my $ci (0..($#islandids-1)) {
 493         my @rel_subflows;
 494
 495         foreach my $f (@flows) {
 496                 next if $f->{Suppress};
 497                 my @relsubflow= grep {
 498                         $_->{Org} <= $ci &&
 499                         $_->{Dst} > $ci;
 500                 } @{ $f->{Subflows} };
 501                 next unless @relsubflow;
 502                 die unless @relsubflow == 1;
 503                 push @rel_subflows, @relsubflow;
 504 #print " RELEVANT $ci $relsubflow[0]->{Var} ";
 505         }
 506 #print " RELEVANT $ci COUNT ".scalar(@rel_subflows)."  ";
 507         if (!@rel_subflows) {
 508                 foreach my $mv (qw(mass volume)) {
 509                         $sail_total[$ci]{$mv}= 0;
 510                 }
 511                 next;
 512         }
 513
 514         my $applylimit= sub {
 515                 my ($mv, $f2val) = @_;
 516                 my $max= $routeparams->{"Max".ucfirst $mv};
 517                 $max= 1e9 unless defined $max;
 518 #print " DEFINED MAX $mv $max ";
 519                 $cplex .= "
 520    ". sprintf("%-10s","${mv}_$ci:")." ".
 521                 join(" + ", map {
 522 #print " PART MAX $_->{Var} $_->{Flow}{Ix} ";
 523                         $f2val->($_->{Flow}) .' '. $_->{Var};
 524                 } @rel_subflows).
 525                 " <= $max";
 526         };
 527
 528         $applylimit->('mass',    sub { $_[0]{'unitmass'}  *1e-3 });
 529         $applylimit->('volume',  sub { $_[0]{'unitvolume'}*1e-3 });
 530         $applylimit->('capital', sub { $_[0]{'org_price'}       });
 531
 532         my @gem_subflows= grep { $_->{Flow}{flags} =~ m/g/ } @rel_subflows;
 533         if (@gem_subflows) {
 534                 $cplex .= "
 535    ". sprintf("%-10s","gems_$ci:")." ".
 536                 join(" + ", map { $_->{Var} } @gem_subflows). " <= $max_gems";
 537         }
 538
 539         $cplex.= "\n";
 540 }
 541
 542 if ($qa->{ShowStalls}>=2) {
 543         my $stallpoe= $dbh->prepare(<<END);
 544 SELECT max(qty*price) FROM buy WHERE stallid=?
 545 END
 546         foreach my $stallid (sort { $a <=> $b } keys %stall_poe_limits) {
 547                 $stallpoe->execute($stallid);
 548                 my ($lim)= $stallpoe->fetchrow_array();
 549                 $stallpoe->finish();
 550                 $cplex.= "
 551     ". sprintf("%-15s","poe_$stallid:")." ".
 552                 join(" + ", map {
 553                         sprintf "%d %s", $_->{Flow}{'dst_price'}, $_->{Var};
 554                 } @{ $stall_poe_limits{$stallid} }).
 555                 " <= $lim";
 556         }
 557         $cplex.= "\n";
 558 }
 559
 560 $cplex.= "
 561 Bounds
 562         ".(join "
 563         ", map { "$_->{Var} >= 0" } @subflows)."
 564
 565 ";
 566
 567 $cplex.= "
 568 Integer
 569         ".(join "
 570         ", map { $_->{Var} } @subflows)."
 571
 572 End
 573 ";
 574
 575 if ($qa->{'debug'}) {
 576 </%perl>
 577 <pre>
 578 <% $cplex |h %>
 579 </pre>
 580 <%perl>
 581 }
 582
 583 my $try_solve= sub {
 584         my (@opts) = @_;
 585         my $input= pipethrough_prep();
 586         print $input $cplex or die $!;
 587         my $output= pipethrough_run_along($input, undef, 'glpsol',
 588                 qw(glpsol --tmlim 1 --memlim 5), @opts,
 589                 qw( --cpxlp /dev/stdin -o /dev/stdout));
 590         if ($qa->{'debug'}) {
 591                 print "<h3>@opts</h3>\n<pre>\n";
 592         }
 593         $expected_total_profit= undef;
 594         $_->{OptQty}= undef foreach @subflows;
 595         my $found_section= 0;
 596         my $glpsol_out= '';
 597         my $continuation='';
 598         my $timelimit= 0;
 599         my $somemip= 0;
 600         while (<$output>) {
 601                 $glpsol_out.= $_;
 602                 print encode_entities($_) if $qa->{'debug'};
 603                 if (m/^\s*No\.\s+(Row|Column) name\s+(?:St\s+)?Activity\s/) {
 604                         die "$_ $found_section ?" if $found_section>0;
 605                         $found_section= 1;
 606                         next;
 607                 }
 608                 if ((m/^Integer optimization begins/ .. 0) &&
 609                     m/^\+ \s* \d+\: \s* mip \s* = \s* \d/) {
 610                         $somemip= 1;
 611                         next;
 612                 }
 613                 if (m/^TIME LIMIT EXCEEDED/) {
 614                         $timelimit= 1;
 615                 }
 616                 if (m/^Objective:\s+totalprofit = (\d+(?:\.\d*)?) /) {
 617                         $expected_total_profit= $1;
 618                 }
 619                 next unless $found_section==1;
 620                 if (!length $continuation) {
 621                         next if !$continuation &&  m/^[- ]+$/;
 622                         if (!/\S/) {
 623                                 $found_section= 0;
 624                                 next;
 625                         }
 626                         if (m/^ \s* \d+ \s+ \w+ $/x) {
 627                                 $continuation= $&;
 628                                 next;
 629                         }
 630                 }
 631                 $_= $continuation.$_;
 632                 $continuation= '';
 633                 my ($varname, $qty) = m/^
 634                         \s* \d+ \s+
 635                         (\w+) \s+ (?: [A-Z*]+ \s+ )?
 636                         ([-+0-9]+)(?: [.e][-+e0-9.]* )? \s
 637                         /x or die "$cplex \n==\n $glpsol_out $_ ?";
 638                 if ($varname =~ m/^f(\d+)s(\d+)_/) {
 639                         my ($ix,$orgix) = ($1,$2);
 640                         my $flow= $flows[$ix] or die;
 641                         my @relsubflow= grep { $_->{Org} == $orgix }
 642                                 @{ $flow->{Subflows} };
 643                         die "$ix $orgix @relsubflow" unless @relsubflow == 1;
 644                         my $sf= $relsubflow[0];
 645                         $sf->{OptQty}= $qty;
 646                         $sf->{OptProfit}= $qty * $flow->{'unitprofit'};
 647                         $sf->{OptCapital}= $qty * $flow->{'org_price'};
 648                 } elsif ($varname =~ m/^(mass|volume)_(\d+)$/) {
 649                         my ($mv,$ix) = ($1,$2);
 650                         $sail_total[$ix]{$mv}= $qty;
 651                 }
 652         }
 653         print "</pre>\n" if $qa->{'debug'};
 654         my $prerr= "\n=====\n$cplex\n=====\n$glpsol_out\n=====\n ";
 655         pipethrough_run_finish($output,$prerr);
 656         map { defined $_->{OptQty} or die "$prerr $_->{Flow}{Ix}" } @subflows;
 657         defined $expected_total_profit or die "$prerr ?";
 658         return $somemip || !$timelimit;
 659 };
 660
 661 unless ($try_solve->(qw( --intopt --cuts --bfs )) or
 662         $try_solve->(qw( --nomip ))) {
 663 </%perl>
 664 <h2>Optimisation failed</h2>
 665 The linear/mixed-integer optimisation failed.
 666 Please report this problem.
 667
 668 <pre>
 669 <% $cplex |h %>
 670 </pre>
 671 <%perl>
 672         return;
 673 }
 674
 675 $addcols->({ DoReverse => 1, TotalSubflows => 1, Special => sub {
 676         my ($flow,$col,$v,$spec) = @_;
 677         if ($flow->{ExpectedUnitProfit} < 0) {
 678                 $spec->{Span}= 3;
 679                 $spec->{String}= '(Small margin)';
 680                 $spec->{Align}= 'align=center';
 681         }
 682 } }, qw(
 683                 OptQty
 684         ));
 685 $addcols->({ Total => 0, DoReverse => 1, TotalSubflows => 1 }, qw(
 686                 OptCapital OptProfit
 687         ));
 688
 689 </%perl>
 690
 691 % } # ========== OPTIMISATION ==========
 692
 693 % if (!printable($m)) {
 694 <h2>Contents</h2>
 695 <ul>
 696 % if ($optimise) {
 697  <li><a href="#plan">Voyage trading plan</a>
 698   <ul>
 699    <li><a href="#summary">Summary statistics</a>
 700    <li>Printable:
 701          <input type=submit name=printable_pdf value="PDF">
 702          <input type=submit name=printable_html value="HTML">
 703          <input type=submit name=printable_ps value="PostScript">
 704          <input type=submit name=printable_pdf2 value="PDF 2-up">
 705          <input type=submit name=printable_ps2 value="PostScript 2-up">
 706   </ul>
 707 % }
 708  <li><a href="#dataage">Data age summary</a>
 709  <li><a href="#trades">Relevant trades</a>
 710 </ul>
 711 % } else {
 712 %       my @tl= gmtime $now or die $!;
 713 <p>
 714 Generated by YARRG at <strong><%
 715         sprintf "%04d-%02d-%02d %02d:%02d:%02d UTC",
 716                 $tl[5]+1900, @tl[4,3,2,1,0]
 717                         |h %></strong>.
 718 % }
 719
 720 % if ($optimise) { # ========== TRADING PLAN ==========
 721 %
 722 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
 723 %                               WHERE islandid = ?');
 724 % my %da_ages;
 725 % my $total_total= 0;
 726 % my $total_dist= 0;
 727 %
 728 <h2><a name="plan">Voyage trading plan</a></h2>
 729
 730 <table class="data" rules=groups <% printable($m) ? 'width=100%' : '' %> >
 731 % my $tbody= sub {
 732 %       if (!printable($m)) { return '<tbody>'; }
 733 %#  return "<tr><td colspan=7><hr>";
 734 %       my ($c)= qw(40 00)[$_[0]];
 735 %       return "<tr><td bgcolor=\"#${c}${c}${c}\" height=1 colspan=7>";
 736 % };
 737 %
 738 % foreach my $i (0..$#islandids) {
 739 <% $tbody->(1) %>
 740 <tr>
 741 %       $iquery->execute($islandids[$i]);
 742 %       my ($islandname) = $iquery->fetchrow_array();
 743 %       if (!$i) {
 744 <td colspan=2>
 745 <strong>Start at <% $islandname |h %></strong>
 746 <td colspan=2><a href="docs#posinclass">[what are these codes?]</a>
 747 <td>
 748 %       } else {
 749 %               my $this_dist= $distance->($islandids[$i-1],$islandids[$i]);
 750 %               $total_dist += $this_dist;
 751 <td colspan=5>
 752 <%perl>
 753                 my $total_value= 0;
 754                 foreach my $sf (@subflows) {
 755                         next unless $sf->{Org} < $i && $sf->{Dst} >= $i;
 756                         $total_value +=
 757                                 $sf->{OptQty} * $sf->{Flow}{'dst_price'};
 758                 }
 759 </%perl>
 760 <strong>Sail to <% $islandname |h %></strong>
 761 - <% $this_dist |h %> leagues,
 762  <% $total_value %>poe at risk
 763  </td>
 764 %       }
 765 <%perl>
 766      my $age_reported= 0;
 767      my %flowlists;
 768      #print "<tr><td colspan=7>" if $qa->{'debug'};
 769      foreach my $od (qw(org dst)) {
 770         #print " [[ i $i od $od " if $qa->{'debug'};
 771         foreach my $sf (@subflows) {
 772                 my $f= $sf->{Flow};
 773                 next unless $sf->{ucfirst $od} == $i;
 774                 #print " FLOW $f->{Ix} SUB #$sf->{Org}..$sf->{Dst} "
 775                 #       if $qa->{'debug'};
 776                 next unless $sf->{OptQty};
 777                 my $arbitrage= $f->{'org_id'} == $f->{'dst_id'};
 778                 die if $arbitrage and $sf->{Org} != $sf->{Dst};
 779                 my $price= $f->{"${od}_price"};
 780                 my $stallname= $f->{"${od}_stallname"};
 781                 my $todo= \$flowlists{$od}{
 782                                 (sprintf "%010d", $f->{'ordval'}),
 783                                 $f->{'commodname'},
 784                                 (sprintf "%07d", ($od eq 'dst' ?
 785                                                 9999999-$price : $price)),
 786                                 $stallname
 787                         };
 788                 $$todo= {
 789                         Qty => 0,
 790                         orgArbitrage => 0,
 791                         dstArbitrage => 0,
 792                 } unless $$todo;
 793                 $$todo->{'commodid'}= $f->{'commodid'};
 794                 $$todo->{'commodname'}= $f->{'commodname'};
 795                 $$todo->{'posinclass'}= '';
 796                 my $incl= $f->{'posinclass'};
 797
 798                 my $findclass= $dbh->prepare(<<END);
 799 SELECT commodclass, maxposinclass FROM commodclasses WHERE commodclassid = ?
 800 END
 801                 $findclass->execute($f->{'commodclassid'});
 802                 my $classinfo= $findclass->fetchrow_hashref();
 803                 if ($classinfo) {
 804                         my $clname= $classinfo->{'commodclass'};
 805                         my $desc= encode_entities(sprintf "%s is under %s",
 806                                         $f->{'commodname'}, $clname);
 807                         my $abbrev= substr($clname,0,1);
 808                         if ($incl) {
 809                                 my $maxpic= $classinfo->{'maxposinclass'};
 810                                 $desc.= (sprintf ", commodity %d of %d",
 811                                         $incl, $maxpic);
 812                                 if ($classinfo->{'maxposinclass'} >= 8) {
 813                                         my @tmbs= qw(0 1 2 3 4 5 6 7 8 9);
 814                                         my $tmbi= ($incl+0.5)*$#tmbs/$maxpic;
 815                                         $abbrev.= " ".$tmbs[$tmbi]."&nbsp;";
 816                                 }
 817                         }
 818                         $$todo->{'posinclass'}=
 819                                 "<div class=mouseover title=\"$desc\">"
 820                                 .$abbrev."</div>";
 821                 }
 822                 $$todo->{'stallname'}= $stallname;
 823                 $$todo->{Price}= $price;
 824                 $$todo->{Timestamp}= $f->{"${od}_timestamp"};
 825                 $$todo->{Qty} += $sf->{OptQty};
 826                 $$todo->{Total}= $$todo->{Price} * $$todo->{Qty};
 827                 $$todo->{Stalls}= $f->{"${od}Stalls"};
 828                 $$todo->{"${od}Arbitrage"}= 1 if $arbitrage;
 829         }
 830         #print "]] " if $qa->{'debug'};
 831      }
 832      #print "</tr>" if $qa->{'debug'};
 833
 834      my ($total, $total_to_show);
 835      my $dline= 0;
 836      my $show_total= sub {
 837         my ($totaldesc, $sign) = @_;
 838         if (defined $total) {
 839                 die if defined $total_to_show;
 840                 $total_total += $sign * $total;
 841                 $total_to_show= [ $totaldesc, $total ];
 842                 $total= undef;
 843         }
 844         $dline= 0;
 845      };
 846      my $show_total_now= sub {
 847         my ($xinfo) = @_;
 848         return unless defined $total_to_show;
 849         my ($totaldesc,$totalwas) = @$total_to_show;
 850 </%perl>
 851 <tr>
 852 <td colspan=1>
 853 <td colspan=3><% $xinfo %>
 854 <td colspan=2 align=right><% $totaldesc %>
 855 <td align=right><% $totalwas |h %> total
 856 <%perl>
 857         $total_to_show= undef;
 858      };
 859 </%perl>
 860 %    my $show_flows= sub {
 861 %       my ($od,$arbitrage,$collectdeliver) = @_;
 862 %       my $todo= $flowlists{$od};
 863 %       return unless $todo;
 864 %       foreach my $tkey (sort keys %$todo) {
 865 %               my $t= $todo->{$tkey};
 866 %               next if $t->{"${od}Arbitrage"} != $arbitrage;
 867 %               $show_total_now->('');
 868 %               if (!$age_reported++) {
 869 %                       my $age= $now - $t->{Timestamp};
 870 %                       my $cellid= "da_${i}";
 871 %                       $da_ages{$cellid}= $age;
 872 <td colspan=2>\
 873 (Data age: <span id="<% $cellid %>"><% prettyprint_age($age) %></span>)
 874 %               } elsif (!defined $total) {
 875 %                       $total= 0;
 876 <% $tbody->(0) %>
 877 %               }
 878 %               $total += $t->{Total};
 879 %               my $span= 0 + keys %{ $t->{Stalls} };
 880 %               my $td= "td rowspan=$span";
 881 %               my %linkqf= (%{ $qa->{'baseqf'} }, %{ $qa->{'queryqf'} });
 882 %               $linkqf{'query'}= 'commod';
 883 %               $linkqf{'commodstring'}= $t->{'commodname'};
 884 %               $linkqf{'commodid'}= $t->{'commodid'};
 885 % tr_datarow($m,$dline);
 886 <<% $td %>><% $collectdeliver %>
 887 <<% $td %>><a href="<% $quri->(%linkqf) %>"><% $t->{'commodname'} |h %></a>
 888 <<% $td %>><% $t->{'posinclass'} %>
 889 %
 890 %               my @stalls= sort keys %{ $t->{Stalls} };
 891 %               my $pstall= sub {
 892 %                       my $name= $stalls[$_[0]];
 893 <td><% $name |h %>
 894 %               };
 895 %
 896 %               $pstall->(0);
 897 <<% $td %> align=right><% $t->{Price} |h %> poe ea.
 898 <<% $td %> align=right><% $t->{Qty} |h %> unit(s)
 899 <<% $td %> align=right><% $t->{Total} |h %> total
 900 %
 901 %               foreach my $stallix (1..$#stalls) {
 902 % tr_datarow($m,$dline);
 903 %                       $pstall->($stallix);
 904 %               }
 905 %
 906 %               $dline ^= 1;
 907 %       }
 908 %    };
 909 <%perl>
 910
 911      $show_flows->('dst',0,'Deliver'); $show_total->('Proceeds',1);
 912      $show_flows->('org',1,'Collect'); $show_total->('(Arbitrage) outlay',-1);
 913      $show_flows->('dst',1,'Deliver'); $show_total->('(Arbitrage) proceeds',1);
 914      $show_flows->('org',0,'Collect'); $show_total->('Outlay',-1);
 915      my $totals= '';
 916      if ($i < $#islandids) {
 917         $totals .=      "In hold $sail_total[$i]{mass}kg,".
 918                         " $sail_total[$i]{volume} l";
 919         my $delim= '; spare ';
 920         my $domv= sub {
 921                 my ($max, $got, $units) = @_;
 922                 return unless defined $max;
 923                 $totals .= $delim;
 924                 $totals .= sprintf "%g %s", ($max-$got), $units;
 925                 $delim= ', ';
 926         };
 927         $domv->($routeparams->{MaxMass},   $sail_total[$i]{mass},   'kg');
 928         $domv->($routeparams->{MaxVolume}, $sail_total[$i]{volume}, 'l');
 929         $totals .= ".\n";
 930      }
 931      $show_total_now->($totals);
 932 }
 933 </%perl><a name="summary"></a>
 934 <% $tbody->(1) %><tr>
 935 <td colspan=3>Total distance: <% $total_dist %> leagues.
 936 <td colspan=3 align=right>Overall net cash flow
 937 <td align=right><strong><%
 938   $total_total < 0 ? -$total_total." loss" : $total_total." gain"
 939  %></strong>
 940 </table>
 941 <& query_age:dataages, id2age => \%da_ages &>
 942 Expected average profit:
 943  approx. <strong><% sprintf "%d", $expected_total_profit %></strong> poe
 944  (considering expected losses, but ignoring rum consumed)
 945 %
 946 % } # ========== TRADING PLAN ==========
 947
 948 % if (!printable($m)) {
 949 <h2><a name="dataage">Data age summary</a></h2>
 950 <%perl>
 951         my $sth_i= $dbh->prepare(<<END);
 952                 SELECT archipelago, islandid, islandname, timestamp
 953                         FROM uploads NATURAL JOIN islands
 954                         WHERE islandid = ?
 955 END
 956         my $sth_a= $dbh->prepare(<<END);
 957                 SELECT archipelago, islandid, islandname, timestamp
 958                         FROM uploads NATURAL JOIN islands
 959                         WHERE archipelago = ?
 960                         ORDER BY islandname
 961 END
 962         my $ix=$#islandids;
 963         my $sth_current;
 964         my %idone;
 965         my $fetchrow= sub {
 966                 for (;;) {
 967                         if ($sth_current) {
 968                                 my $row= $sth_current->fetchrow_hashref();
 969                                 if ($row) {
 970                                         next if $idone{$row->{'islandid'}}++;
 971                                         return $row;
 972                                 }
 973                         }
 974                         return undef if $ix < 0;
 975                         my $iid= $islandids[$ix];
 976                         if (defined $iid) {
 977                                 $sth_i->execute($iid);
 978                                 $sth_current= $sth_i;
 979                         } else {
 980                                 my $arch= $archipelagoes[$ix];
 981                                 die unless defined $arch && length $arch;
 982                                 $sth_a->execute($arch);
 983                                 $sth_current= $sth_a;
 984                         }
 985                         $ix--;
 986                 }
 987         };
 988 </%perl>
 989 <&| query_age:agestable, now => $now, fetchrow => $fetchrow &>
 990 Islands shown in reverse order of visits.<br>
 991 </&>
 992 % }
 993
 994 % if (!printable($m)) {
 995 %   my %ts_sortkeys;
 996 %   {
 997 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
 998 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
 999 <h2><a name="trades">Relevant trades</a></h2>
1000 <table class="data" id="trades" rules=groups>
1001 <colgroup span=1>
1002 <colgroup span=2>
1003 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
1004 <colgroup span=1>
1005 <colgroup span=2>
1006 <colgroup span=2>
1007 <colgroup span=2>
1008 <colgroup span=3>
1009 <colgroup span=3>
1010 %       if ($optimise) {
1011 <colgroup span=3>
1012 %       }
1013 <tr>
1014 <th>
1015 <th<% $cdspan %>>Collect
1016 <th<% $cdspan %>>Deliver
1017 <th>
1018 <th colspan=2>Collect
1019 <th colspan=2>Deliver
1020 <th colspan=2>Profit
1021 <th colspan=3>Max
1022 <th colspan=1>
1023 <th colspan=2>Max
1024 %       if ($optimise) {
1025 <th colspan=3>Planned
1026 %       }
1027
1028 <tr>
1029 <th>
1030 <th>Island <% $cdstall %>
1031 <th>Island <% $cdstall %>
1032 <th>Commodity
1033 <th>Price
1034 <th>Qty
1035 <th>Price
1036 <th>Qty
1037 <th>Margin
1038 <th>Unit
1039 <th>Qty
1040 <th>Capital
1041 <th>Profit
1042 <th>Dist
1043 <th>Mass
1044 <th>Vol
1045 %       if ($optimise) {
1046 <th>Qty
1047 <th>Capital
1048 <th>Profit
1049 %       }
1050 %   }
1051
1052 <tr id="trades_sort">
1053 %   foreach my $col (@cols) {
1054 <th>
1055 %   }
1056
1057 %   foreach my $flowix (0..$#flows) {
1058 %       my $flow= $flows[$flowix];
1059 %       my $rowid= "id_row_$flow->{UidShort}";
1060 <tr id="<% $rowid %>" class="datarow<% $flowix & 1 %>">
1061 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
1062     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
1063        <% $flow->{Suppress} ? '' : 'checked' %> >
1064 %       my $ci= 1;
1065 %       while ($ci < @cols) {
1066 %               my $col= $cols[$ci];
1067 %               my $spec= {
1068 %                       Span => 1,
1069 %                       Align => ($col->{Text} ? '' : 'align=right')
1070 %               };
1071 %               my $cn= $col->{Name};
1072 %               my $v;
1073 %               if (!$col->{TotalSubflows}) {
1074 %                       $v= $flow->{$cn};
1075 %               } else {
1076 %                       $v= 0;
1077 %                       $v += $_->{$cn} foreach @{ $flow->{Subflows} };
1078 %               }
1079 %               if ($col->{Special}) { $col->{Special}($flow,$col,$v,$spec); }
1080 %               $col->{Total} += $v
1081 %                       if defined $col->{Total} and not $flow->{Suppress};
1082 %               $v='' if !$col->{Text} && !$v;
1083 %               my $sortkey= $col->{SortColKey} ?
1084 %                       $flow->{$col->{SortColKey}} : $v;
1085 %               $ts_sortkeys{$ci}{$rowid}= $sortkey;
1086 <td <% $spec->{Span} ? "colspan=$spec->{Span}" : ''
1087  %> <% $spec->{Align}
1088  %>><% exists $spec->{String} ? $spec->{String} : $v |h %>
1089 %               $ci += $spec->{Span};
1090 %       }
1091 %   }
1092 <tr id="trades_total">
1093 <th>
1094 <th colspan=2>Total
1095 %   foreach my $ci (3..$#cols) {
1096 %       my $col= $cols[$ci];
1097 <td align=right>
1098 %       if (defined $col->{Total}) {
1099 <% $col->{Total} |h %>
1100 %       }
1101 %   }
1102 </table>
1103
1104 <&| tabsort, cols => \@cols, table => 'trades', rowclass => 'datarow',
1105         throw => 'trades_sort', tbrow => 'trades_total' &>
1106   ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
1107 </&tabsort>
1108 <p>
1109 <input type=submit name=update value="Update">
1110
1111 % } # !printable
1112
1113 <%init>
1114 use CommodsWeb;
1115 use Commods;
1116 </%init>