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