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