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