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