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