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