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_c%d_p%d_%d_p%d_%d",
 296                                 $f->{Ix}, $sfi->[0],
 297                                 $f->{'commodid'},
 298                                 $sfi->[0], $f->{'org_price'},
 299                                 $sfi->[1], $f->{'dst_price'}
 300                 };
 301                 push @{ $f->{Subflows} }, $subflow;
 302                 push @subflows, $subflow;
 303         }
 304
 305         $f->{MarginSortKey}= sprintf "%d",
 306                 $f->{'dst_price'} * 10000 / $f->{'org_price'};
 307         $f->{Margin}= sprintf "%3.1f%%",
 308                 $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
 309
 310         $f->{ExpectedUnitProfit}=
 311                 $f->{'dst_price'} * (1.0 - $loss_per_league) ** $f->{'dist'}
 312                 - $f->{'org_price'};
 313
 314         $dists{'org_id'}{'dst_id'}= $f->{'dist'};
 315
 316         my @uid= $f->{commodid};
 317         foreach my $od (qw(org dst)) {
 318                 push @uid,
 319                         $f->{"${od}_id"},
 320                         $f->{"${od}_price"};
 321                 push @uid,
 322                         $f->{"${od}_stallid"}
 323                                 if $qa->{ShowStalls};
 324         }
 325         $f->{UidLong}= join '_', @uid;
 326
 327         my $base= 31;
 328         my $cmpu= '';
 329         map {
 330                 my $uue= $_;
 331                 my $first= $base;
 332                 do {
 333                         my $this= $uue % $base;
 334 #print STDERR "uue=$uue this=$this ";
 335                         $uue -= $this;
 336                         $uue /= $base;
 337                         $this += $first;
 338                         $first= 0;
 339                         $cmpu .= chr($this + ($this < 26 ? ord('a') :
 340                                               $this < 52 ? ord('A')-26
 341                                                          : ord('0')-52));
 342 #print STDERR " uue=$uue this=$this cmpu=$cmpu\n";
 343                         die "$cmpu $uue ?" if length $cmpu > 20;
 344                 } while ($uue);
 345                 $cmpu;
 346         } @uid;
 347         $f->{UidShort}= $cmpu;
 348
 349         if ($qa->{'debug'}) {
 350                 my @outuid;
 351                 $_= $f->{UidShort};
 352                 my $mul;
 353                 while (m/./) {
 354                         my $v= m/^[a-z]/ ? ord($&)-ord('a') :
 355                                m/^[A-Z]/ ? ord($&)-ord('A')+26 :
 356                                m/^[0-9]/ ? ord($&)-ord('0')+52 :
 357                                die "$_ ?";
 358                         if ($v >= $base) {
 359                                 push @outuid, 0;
 360                                 $v -= $base;
 361                                 $mul= 1;
 362 #print STDERR "(next)\n";
 363                         }
 364                         die "$f->{UidShort} $_ ?" unless defined $mul;
 365                         $outuid[$#outuid] += $v * $mul;
 366
 367 #print STDERR "$f->{UidShort}  $_  $&  v=$v  mul=$mul  ord()=".ord($&).
 368 #                       "[vs.".ord('a').",".ord('A').",".ord('0')."]".
 369 #                       "  outuid=@outuid\n";
 370
 371                         $mul *= $base;
 372                         s/^.//;
 373                 }
 374                 my $recons_long= join '_', @outuid;
 375                 $f->{UidLong} eq $recons_long or
 376                         die "$f->{UidLong} = $f->{UidShort} = $recons_long ?";
 377         }
 378
 379         if (defined $qa->{"R$f->{UidShort}"} &&
 380             !defined $qa->{"T$f->{UidShort}"}) {
 381                 $f->{Suppress}= 1;
 382         }
 383
 384 }
 385 </%perl>
 386
 387 % my $optimise= $specific;
 388 % if (!$optimise) {
 389
 390 <p>
 391 % if (!$specific) {
 392 Route contains archipelago(es), not just specific islands.
 393 % }
 394 Therefore, optimal voyage trade plan not calculated.
 395
 396 % } else { # ========== OPTMISATION ==========
 397 <%perl>
 398
 399 my $cplex= "
 400 Maximize
 401
 402   totalprofit:
 403 ";
 404
 405 foreach my $sf (@subflows) {
 406         my $eup= $sf->{Flow}{ExpectedUnitProfit};
 407         $eup *= (1.0-$loss_per_delay_slot) ** $sf->{Org};
 408         $cplex .= sprintf "
 409                 %+.20f %s", $eup, $sf->{Var};
 410 }
 411 $cplex .= "
 412
 413 Subject To
 414 ";
 415
 416 my %avail_lims;
 417 foreach my $flow (@flows) {
 418         if ($flow->{Suppress}) {
 419                 foreach my $sf (@{ $flow->{Subflows} }) {
 420                         $cplex .= "
 421    $sf->{Var} = 0";
 422                 }
 423                 next;
 424         }
 425         foreach my $od (qw(org dst)) {
 426                 my $limname= join '_', (
 427                         $od,
 428                         'i'.$flow->{"${od}_id"},
 429                         'c'.$flow->{'commodid'},
 430                         $flow->{"${od}_price"},
 431                         $flow->{"${od}_stallid"},
 432                 );
 433
 434                 push @{ $avail_lims{$limname}{SubflowVars} },
 435                         map { $_->{Var} } @{ $flow->{Subflows} };
 436                 $avail_lims{$limname}{Qty}= $flow->{"${od}_qty_agg"};
 437         }
 438 }
 439 foreach my $limname (sort keys %avail_lims) {
 440         my $c= $avail_lims{$limname};
 441         $cplex .=
 442                 sprintf("    %-30s","$limname:")." ".
 443                         join("+", @{ $c->{SubflowVars} }).
 444                         " <= ".$c->{Qty}."\n";
 445 }
 446
 447 foreach my $ci (0..($#islandids-1)) {
 448         my @rel_subflows;
 449
 450         foreach my $f (@flows) {
 451                 next if $f->{Suppress};
 452                 my @relsubflow= grep {
 453                         $_->{Org} <= $ci &&
 454                         $_->{Dst} > $ci;
 455                 } @{ $f->{Subflows} };
 456                 next unless @relsubflow;
 457                 die unless @relsubflow == 1;
 458                 push @rel_subflows, @relsubflow;
 459 #print " RELEVANT $ci $relsubflow[0]->{Var} ";
 460         }
 461 #print " RELEVANT $ci COUNT ".scalar(@rel_subflows)."  ";
 462         if (!@rel_subflows) {
 463                 foreach my $mv (qw(mass volume)) {
 464                         $sail_total[$ci]{$mv}= 0;
 465                 }
 466                 next;
 467         }
 468
 469         my $applylimit= sub {
 470                 my ($mv, $max, $f2val) = @_;
 471                 $max= 1e9 unless defined $max;
 472 #print " DEFINED MAX $mv $max ";
 473                 $cplex .= "
 474    ". sprintf("%-10s","${mv}_$ci:")." ".
 475                 join(" + ", map {
 476 #print " PART MAX $_->{Var} $_->{Flow}{Ix} ";
 477                         $f2val->($_->{Flow}) .' '. $_->{Var};
 478                 } @rel_subflows).
 479                 " <= $max";
 480         };
 481
 482         $applylimit->('mass',   $max_mass,   sub { $_[0]{'unitmass'}  *1e-3 });
 483         $applylimit->('volume', $max_volume, sub { $_[0]{'unitvolume'}*1e-3 });
 484         $applylimit->('capital',$max_capital,sub { $_[0]{'org_price'}       });
 485         $cplex.= "\n";
 486 }
 487
 488 $cplex.= "
 489 Bounds
 490         ".(join "
 491         ", map { "$_->{Var} >= 0" } @subflows)."
 492
 493 ";
 494
 495 $cplex.= "
 496 Integer
 497         ".(join "
 498         ", map { $_->{Var} } @subflows)."
 499
 500 End
 501 ";
 502
 503 if ($qa->{'debug'}) {
 504 </%perl>
 505 <pre>
 506 <% $cplex |h %>
 507 </pre>
 508 <%perl>
 509 }
 510
 511 {
 512         my $input= pipethrough_prep();
 513         print $input $cplex or die $!;
 514         my $output= pipethrough_run_along($input, undef, 'glpsol',
 515                 qw(glpsol --tmlim 2 --memlim 5 --intopt --cuts --bfs
 516                           --cpxlp /dev/stdin -o /dev/stdout));
 517         print "<pre>\n" if $qa->{'debug'};
 518         my $found_section= 0;
 519         my $glpsol_out= '';
 520         my $continuation='';
 521         while (<$output>) {
 522                 $glpsol_out.= $_;
 523                 print encode_entities($_) if $qa->{'debug'};
 524                 if (m/^\s*No\.\s+(Row|Column) name\s+(?:St\s+)?Activity\s/) {
 525                         die "$_ $found_section ?" if $found_section>0;
 526                         $found_section= 1;
 527                         next;
 528                 }
 529                 next unless $found_section==1;
 530                 if (!length $continuation) {
 531                         next if !$continuation &&  m/^[- ]+$/;
 532                         if (!/\S/) {
 533                                 $found_section= 0;
 534                                 next;
 535                         }
 536                         if (m/^ \s* \d+ \s+ \w+ $/x) {
 537                                 $continuation= $&;
 538                                 next;
 539                         }
 540                 }
 541                 $_= $continuation.$_;
 542                 $continuation= '';
 543                 my ($varname, $qty) = m/^
 544                         \s* \d+ \s+
 545                         (\w+) \s+ (?: [A-Z*]+ \s+ )?
 546                         ([0-9.]+) \s
 547                         /x or die "$_ ?";
 548                 if ($varname =~ m/^f(\d+)s(\d+)_/) {
 549                         my ($ix,$orgix) = ($1,$2);
 550                         my $flow= $flows[$ix] or die;
 551                         my @relsubflow= grep { $_->{Org} == $orgix }
 552                                 @{ $flow->{Subflows} };
 553                         die "$ix $orgix @relsubflow" unless @relsubflow == 1;
 554                         my $sf= $relsubflow[0];
 555                         $sf->{OptQty}= $qty;
 556                         $sf->{OptProfit}= $qty * $flow->{'unitprofit'};
 557                         $sf->{OptCapital}= $qty * $flow->{'org_price'};
 558                 } elsif ($varname =~ m/^(mass|volume)_(\d+)$/) {
 559                         my ($mv,$ix) = ($1,$2);
 560                         $sail_total[$ix]{$mv}= $qty;
 561                 }
 562         }
 563         print "</pre>\n" if $qa->{'debug'};
 564         my $prerr= "\n=====\n$cplex\n=====\n$glpsol_out\n=====\n ";
 565         pipethrough_run_finish($output,$prerr);
 566         map { defined $_->{OptQty} or die "$prerr $_->{Flow}{Ix}" } @subflows;
 567 };
 568
 569 $addcols->({ DoReverse => 1, TotalSubflows => 1, Special => sub {
 570         my ($flow,$col,$v,$spec) = @_;
 571         if ($flow->{ExpectedUnitProfit} < 0) {
 572                 $spec->{Span}= 3;
 573                 $spec->{String}= '(Small margin)';
 574                 $spec->{Align}= 'align=center';
 575         }
 576 } }, qw(
 577                 OptQty
 578         ));
 579 $addcols->({ Total => 0, DoReverse => 1, TotalSubflows => 1 }, qw(
 580                 OptCapital OptProfit
 581         ));
 582
 583 </%perl>
 584
 585 % } # ========== OPTIMISATION ==========
 586
 587 % my %ts_sortkeys;
 588 % {
 589 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
 590 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
 591 <table id="trades" rules=groups>
 592 <colgroup span=1>
 593 <colgroup span=2>
 594 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
 595 <colgroup span=1>
 596 <colgroup span=2>
 597 <colgroup span=2>
 598 <colgroup span=2>
 599 <colgroup span=3>
 600 <colgroup span=3>
 601 %       if ($optimise) {
 602 <colgroup span=3>
 603 %       }
 604 <tr class="spong">
 605 <th>
 606 <th<% $cdspan %>>Collect
 607 <th<% $cdspan %>>Deliver
 608 <th>
 609 <th colspan=2>Collect
 610 <th colspan=2>Deliver
 611 <th colspan=2>Profit
 612 <th colspan=3>Max
 613 <th colspan=1>
 614 <th colspan=2>Max
 615 %       if ($optimise) {
 616 <th colspan=3>Planned
 617 %       }
 618
 619 <tr>
 620 <th>
 621 <th>Island <% $cdstall %>
 622 <th>Island <% $cdstall %>
 623 <th>Commodity
 624 <th>Price
 625 <th>Qty
 626 <th>Price
 627 <th>Qty
 628 <th>Margin
 629 <th>Unit
 630 <th>Qty
 631 <th>Capital
 632 <th>Profit
 633 <th>Dist
 634 <th>Mass
 635 <th>Vol
 636 %       if ($optimise) {
 637 <th>Qty
 638 <th>Capital
 639 <th>Profit
 640 %       }
 641 % }
 642
 643 <tr id="trades_sort">
 644 % foreach my $col (@cols) {
 645 <th>
 646 % }
 647
 648 % foreach my $flowix (0..$#flows) {
 649 %       my $flow= $flows[$flowix];
 650 %       my $rowid= "id_row_$flow->{UidShort}";
 651 <tr id="<% $rowid %>" class="datarow<% $flowix & 1 %>">
 652 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
 653     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
 654        <% $flow->{Suppress} ? '' : 'checked' %> >
 655 %       my $ci= 1;
 656 %       while ($ci < @cols) {
 657 %               my $col= $cols[$ci];
 658 %               my $spec= {
 659 %                       Span => 1,
 660 %                       Align => ($col->{Text} ? '' : 'align=right')
 661 %               };
 662 %               my $cn= $col->{Name};
 663 %               my $v;
 664 %               if (!$col->{TotalSubflows}) {
 665 %                       $v= $flow->{$cn};
 666 %               } else {
 667 %                       $v= 0;
 668 %                       $v += $_->{$cn} foreach @{ $flow->{Subflows} };
 669 %               }
 670 %               if ($col->{Special}) { $col->{Special}($flow,$col,$v,$spec); }
 671 %               $col->{Total} += $v
 672 %                       if defined $col->{Total} and not $flow->{Suppress};
 673 %               $v='' if !$col->{Text} && !$v;
 674 %               my $sortkey= $col->{SortColKey} ?
 675 %                       $flow->{$col->{SortColKey}} : $v;
 676 %               $ts_sortkeys{$ci}{$rowid}= $sortkey;
 677 <td <% $spec->{Span} ? "colspan=$spec->{Span}" : ''
 678  %> <% $spec->{Align}
 679  %>><% exists $spec->{String} ? $spec->{String} : $v |h %>
 680 %               $ci += $spec->{Span};
 681 %       }
 682 % }
 683 <tr id="trades_total">
 684 <th>
 685 <th colspan=2>Total
 686 % foreach my $ci (3..$#cols) {
 687 %       my $col= $cols[$ci];
 688 <td align=right>
 689 %       if (defined $col->{Total}) {
 690 <% $col->{Total} |h %>
 691 %       }
 692 % }
 693 </table>
 694
 695 <&| tabsort, cols => \@cols, table => 'trades', rowclass => 'datarow',
 696         throw => 'trades_sort', tbrow => 'trades_total' &>
 697   ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
 698 </&tabsort>
 699
 700 <input type=submit name=update value="Update">
 701
 702 % if ($optimise) { # ========== TRADING PLAN ==========
 703 %
 704 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
 705 %                               WHERE islandid = ?');
 706 % my %da_ages;
 707 % my $total_total= 0;
 708 % my $total_dist= 0;
 709 %
 710 <h1>Voyage trading plan</h1>
 711 <table rules=groups>
 712 % foreach my $i (0..$#islandids) {
 713 <tbody>
 714 <tr><td colspan=4>
 715 %       $iquery->execute($islandids[$i]);
 716 %       my ($islandname) = $iquery->fetchrow_array();
 717 %       if (!$i) {
 718 <strong>Start at <% $islandname |h %></strong>
 719 %       } else {
 720 %               my $this_dist= $distance->($islandids[$i-1],$islandids[$i]);
 721 %               $total_dist += $this_dist;
 722 <%perl>
 723                 my $total_value= 0;
 724                 foreach my $sf (@subflows) {
 725                         next unless $sf->{Org} < $i && $sf->{Dst} >= $i;
 726                         $total_value +=
 727                                 $sf->{OptQty} * $sf->{Flow}{'dst_price'};
 728                 }
 729 </%perl>
 730 <strong>Sail to <% $islandname |h %></strong>
 731 - <% $this_dist |h %> leagues,
 732  <% $total_value %>poe at risk
 733  </td>
 734 %       }
 735 <%perl>
 736      my $age_reported= 0;
 737      my %flowlists;
 738      #print "<tr><td colspan=6>" if $qa->{'debug'};
 739      foreach my $od (qw(org dst)) {
 740         #print " [[ i $i od $od " if $qa->{'debug'};
 741         foreach my $sf (@subflows) {
 742                 my $f= $sf->{Flow};
 743                 next if $f->{Suppress};
 744                 next unless $sf->{ucfirst $od} == $i;
 745                 #print " FLOW $f->{Ix} SUB #$sf->{Org}..$sf->{Dst} "
 746                 #       if $qa->{'debug'};
 747                 next unless $sf->{OptQty};
 748                 my $arbitrage= $f->{'org_id'} == $f->{'dst_id'};
 749                 die if $arbitrage and $sf->{Org} != $sf->{Dst};
 750                 my $price= $f->{"${od}_price"};
 751                 my $stallname= $f->{"${od}_stallname"};
 752                 my $todo= \$flowlists{$od}{
 753                                 $f->{'commodname'},
 754                                 (sprintf "%07d", ($od eq 'dst' ?
 755                                                 9999999-$price : $price)),
 756                                 $stallname
 757                         };
 758                 $$todo= {
 759                         Qty => 0,
 760                         orgArbitrage => 0,
 761                         dstArbitrage => 0,
 762                 } unless $$todo;
 763                 $$todo->{'commodname'}= $f->{'commodname'};
 764                 $$todo->{'stallname'}= $stallname;
 765                 $$todo->{Price}= $price;
 766                 $$todo->{Timestamp}= $f->{"${od}_timestamp"};
 767                 $$todo->{Qty} += $sf->{OptQty};
 768                 $$todo->{Total}= $$todo->{Price} * $$todo->{Qty};
 769                 $$todo->{Stalls}= $f->{"${od}Stalls"};
 770                 $$todo->{"${od}Arbitrage"}= 1 if $arbitrage;
 771         }
 772         #print "]] " if $qa->{'debug'};
 773      }
 774      #print "</tr>" if $qa->{'debug'};
 775
 776      my ($total, $total_to_show);
 777      my $dline= 0;
 778      my $show_total= sub {
 779         my ($totaldesc, $sign) = @_;
 780         if (defined $total) {
 781                 die if defined $total_to_show;
 782                 $total_total += $sign * $total;
 783                 $total_to_show= [ $totaldesc, $total ];
 784                 $total= undef;
 785         }
 786         $dline= 0;
 787      };
 788      my $show_total_now= sub {
 789         my ($xinfo) = @_;
 790         return unless defined $total_to_show;
 791         my ($totaldesc,$totalwas) = @$total_to_show;
 792 </%perl>
 793 <tr>
 794 <td colspan=1>
 795 <td colspan=2><% $xinfo %>
 796 <td colspan=2 align=right><% $totaldesc %>
 797 <td align=right><% $totalwas |h %> total
 798 <%perl>
 799         $total_to_show= undef;
 800      };
 801 </%perl>
 802 %    my $show_flows= sub {
 803 %       my ($od,$arbitrage,$collectdeliver) = @_;
 804 %       my $todo= $flowlists{$od};
 805 %       return unless $todo;
 806 %       foreach my $tkey (sort keys %$todo) {
 807 %               my $t= $todo->{$tkey};
 808 %               next if $t->{"${od}Arbitrage"} != $arbitrage;
 809 %               $show_total_now->('');
 810 %               if (!$age_reported++) {
 811 %                       my $age= $now - $t->{Timestamp};
 812 %                       my $cellid= "da_${i}";
 813 %                       $da_ages{$cellid}= $age;
 814 <td colspan=2>\
 815 (Data age: <span id="<% $cellid %>"><% prettyprint_age($age) %></span>)
 816 %               } elsif (!defined $total) {
 817 %                       $total= 0;
 818 <tbody>
 819 %               }
 820 %               $total += $t->{Total};
 821 %               my $span= 0 + keys %{ $t->{Stalls} };
 822 %               my $td= "td rowspan=$span";
 823 <tr class="datarow<% $dline %>">
 824 <<% $td %>><% $collectdeliver %>
 825 <<% $td %>><% $t->{'commodname'} |h %>
 826 %
 827 %               my @stalls= sort keys %{ $t->{Stalls} };
 828 %               my $pstall= sub {
 829 %                       my $name= $stalls[$_[0]];
 830 <td><% $name |h %>
 831 %               };
 832 %
 833 %               $pstall->(0);
 834 <<% $td %> align=right><% $t->{Price} |h %> poe ea.
 835 <<% $td %> align=right><% $t->{Qty} |h %> unit(s)
 836 <<% $td %> align=right><% $t->{Total} |h %> total
 837 %
 838 %               foreach my $stallix (1..$#stalls) {
 839 <tr class="datarow<% $dline %>">
 840 %                       $pstall->($stallix);
 841 %               }
 842 %
 843 %               $dline ^= 1;
 844 %       }
 845 %    };
 846 <%perl>
 847
 848      $show_flows->('dst',0,'Deliver'); $show_total->('Proceeds',1);
 849      $show_flows->('org',1,'Collect'); $show_total->('(Arbitrage) outlay',-1);
 850      $show_flows->('dst',1,'Deliver'); $show_total->('(Arbitrage) proceeds',1);
 851      $show_flows->('org',0,'Collect'); $show_total->('Outlay',-1);
 852      my $totals= '';
 853      if ($i < $#islandids) {
 854         $totals .=      "In hold $sail_total[$i]{mass}kg,".
 855                         " $sail_total[$i]{volume} l";
 856         my $delim= '; spare ';
 857         my $domv= sub {
 858                 my ($max, $got, $units) = @_;
 859                 return unless defined $max;
 860                 $totals .= $delim;
 861                 $totals .= sprintf "%g %s", ($max-$got), $units;
 862                 $delim= ', ';
 863         };
 864         $domv->($max_mass,   $sail_total[$i]{mass},   'kg');
 865         $domv->($max_volume, $sail_total[$i]{volume}, 'l');
 866         $totals .= ".\n";
 867      }
 868      $show_total_now->($totals);
 869 }
 870 </%perl>
 871 <tbody><tr>
 872 <td colspan=2>Total distance: <% $total_dist %> leagues.
 873 <td colspan=3 align=right>Overall net cash flow
 874 <td align=right><strong><%
 875   $total_total < 0 ? -$total_total." loss" : $total_total." gain"
 876  %></strong>
 877 </table>
 878 <& query_age:dataages, id2age => \%da_ages &>
 879 %
 880 % } # ========== TRADING PLAN ==========
 881
 882 <%init>
 883 use CommodsWeb;
 884 use Commods;
 885 </%init>