chiark / gitweb /
Organise TODO list
[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 </%args>
42 <&| script &>
43   da_pageload= Date.now();
44 </&script>
45
46 <%perl>
47
48 my $now= time;
49 my $loss_per_league= 1e-7;
50
51 my @flow_conds;
52 my @query_params;
53
54 my $sd_condition= sub {
55         my ($bs, $ix) = @_;
56         my $islandid= $islandids[$ix];
57         if (defined $islandid) {
58                 return "${bs}.islandid = $islandid";
59         } else {
60                 push @query_params, $archipelagoes[$ix];
61                 return "${bs}_islands.archipelago = ?";
62         }
63 };
64
65 my %islandpair;
66 # $islandpair{$a,$b}= [ $start_island_ix, $end_island_ix ]
67
68 my $specific= !grep { !defined $_ } @islandids;
69 my $confusing= 0;
70
71 foreach my $src_i (0..$#islandids) {
72         my $src_isle= $islandids[$src_i];
73         my $src_cond= $sd_condition->('sell',$src_i);
74         my @dst_conds;
75         foreach my $dst_i ($src_i..$#islandids) {
76                 my $dst_isle= $islandids[$dst_i];
77                 my $dst_cond= $sd_condition->('buy',$dst_i);
78                 if ($dst_i==$src_i and !defined $src_isle) {
79                         # we always want arbitrage, but mentioning an arch
80                         # once shouldn't produce intra-arch trades
81                         $dst_cond=
82                                 "($dst_cond AND sell.islandid = buy.islandid)";
83                 }
84                 push @dst_conds, $dst_cond;
85
86                 if ($specific && !$confusing &&
87                     # With a circular route, do not carry goods round the loop
88                     !($src_i==0 && $dst_i==$#islandids &&
89                       $src_isle == $islandids[$dst_i])) {
90                         if ($islandpair{$src_isle,$dst_isle}) {
91                                 $confusing= 1;
92                         } else {
93                                 $islandpair{$src_isle,$dst_isle}=
94                                         [ $src_i, $dst_i ];
95                         }
96                 }
97         }
98         push @flow_conds, "$src_cond AND (
99                         ".join("
100                      OR ",@dst_conds)."
101                 )";
102 }
103
104 my $stmt= "             
105         SELECT  sell_islands.islandname                         org_name,
106                 sell_islands.islandid                           org_id,
107                 sell.price                                      org_price,
108                 sell.qty                                        org_qty_stall,
109                 sell_stalls.stallname                           org_stallname,
110                 sell.stallid                                    org_stallid,
111                 sell_uploads.timestamp                          org_timestamp,
112                 buy_islands.islandname                          dst_name,
113                 buy_islands.islandid                            dst_id,
114                 buy.price                                       dst_price,
115                 buy.qty                                         dst_qty_stall,
116                 buy_stalls.stallname                            dst_stallname,
117                 buy.stallid                                     dst_stallid,
118                 buy_uploads.timestamp                           dst_timestamp,
119 ".($qa->{ShowStalls} ? "
120                 sell.qty                                        org_qty_agg,
121                 buy.qty                                         dst_qty_agg,
122 " : "
123                 (SELECT sum(qty) FROM sell AS sell_agg
124                   WHERE sell_agg.commodid = commods.commodid
125                   AND   sell_agg.islandid = sell.islandid
126                   AND   sell_agg.price = sell.price)            org_qty_agg,
127                 (SELECT sum(qty) FROM buy AS buy_agg
128                   WHERE buy_agg.commodid = commods.commodid
129                   AND   buy_agg.islandid = buy.islandid
130                   AND   buy_agg.price = buy.price)              dst_qty_agg,
131 ")."
132                 commods.commodname                              commodname,
133                 commods.commodid                                commodid,
134                 commods.unitmass                                unitmass,
135                 commods.unitvolume                              unitvolume,
136                 dist                                            dist,
137                 buy.price - sell.price                          unitprofit
138         FROM commods
139         JOIN sell ON commods.commodid = sell.commodid
140         JOIN buy  ON commods.commodid = buy.commodid
141         JOIN islands AS sell_islands ON sell.islandid = sell_islands.islandid
142         JOIN islands AS buy_islands  ON buy.islandid  = buy_islands.islandid
143         JOIN uploads AS sell_uploads ON sell.islandid = sell_uploads.islandid
144         JOIN uploads AS buy_uploads  ON buy.islandid  = buy_uploads.islandid
145         JOIN stalls  AS sell_stalls  ON sell.stallid  = sell_stalls.stallid
146         JOIN stalls  AS buy_stalls   ON buy.stallid   = buy_stalls.stallid
147         JOIN dists ON aiid = sell.islandid AND biid = buy.islandid
148         WHERE   (
149                 ".join("
150            OR   ", @flow_conds)."
151         )
152           AND   buy.price > sell.price
153         ORDER BY org_name, dst_name, commodname, unitprofit DESC,
154                  org_price, dst_price DESC,
155                  org_stallname, dst_stallname
156      ";
157
158 my $sth= $dbh->prepare($stmt);
159 $sth->execute(@query_params);
160 my @flows;
161
162 my @cols= ({ NoSort => 1 });
163
164 my $addcols= sub {
165         my $base= shift @_;
166         foreach my $name (@_) {
167                 my $col= { Name => $name, %$base };
168                 $col->{Numeric}=1 if !$col->{Text};
169                 push @cols, $col;
170         }
171 };
172
173 if ($qa->{ShowStalls}) {
174         $addcols->({ Text => 1 }, qw(
175                 org_name org_stallname
176                 dst_name dst_stallname
177         ));
178 } else {
179         $addcols->({Text => 1 }, qw(
180                 org_name dst_name
181         ));
182 }
183 $addcols->({ Text => 1 }, qw(commodname));
184 $addcols->({ DoReverse => 1 },
185         qw(     org_price org_qty_agg dst_price dst_qty_agg
186         ));
187 $addcols->({ DoReverse => 1, SortColKey => 'MarginSortKey' },
188         qw(     Margin
189         ));
190 $addcols->({ DoReverse => 1 },
191         qw(     unitprofit MaxQty
192                 MaxCapital MaxProfit
193         ));
194
195 </%perl>
196
197 % if ($qa->{'debug'}) {
198 <pre>
199 <% $stmt |h %>
200 <% join(' | ',@query_params) |h %>
201 </pre>
202 % }
203
204 <& dumptable:start, qa => $qa, sth => $sth &>
205 % {
206 %   my $got;
207 %   while ($got= $sth->fetchrow_hashref()) {
208 <%perl>
209
210         my $f= $flows[$#flows];
211         if (    !$f ||
212                 $qa->{ShowStalls} ||
213                 grep { $f->{$_} ne $got->{$_} }
214                         qw(org_id org_price dst_id dst_price commodid)
215         ) {
216                 # Make a new flow rather than adding to the existing one
217
218                 $f= {
219                         Ix => scalar(@flows),
220                         Var => "f".@flows,
221                         %$got
222                 };
223                 $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
224                         if !$qa->{ShowStalls};
225                 push @flows, $f;
226         }
227         foreach my $od (qw(org dst)) {
228                 $f->{"${od}Stalls"}{
229                         $got->{"${od}_stallname"}
230                     } =
231                         $got->{"${od}_qty_stall"}
232                     ;
233         }
234
235 </%perl>
236 <& dumptable:row, qa => $qa, sth => $sth, row => $f &>
237 %    }
238 <& dumptable:end, qa => $qa &>
239 % }
240
241 <%perl>
242 foreach my $f (@flows) {
243
244         $f->{MaxQty}= $f->{'org_qty_agg'} < $f->{'dst_qty_agg'}
245                 ? $f->{'org_qty_agg'} : $f->{'dst_qty_agg'};
246         $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
247         $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
248
249         $f->{MarginSortKey}= sprintf "%d",
250                 $f->{'dst_price'} * 10000 / $f->{'org_price'};
251         $f->{Margin}= sprintf "%3.1f%%",
252                 $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
253
254         $f->{ExpectedUnitProfit}=
255                 $f->{'dst_price'} * (1.0 - $loss_per_league) ** $f->{'dist'}
256                 - $f->{'org_price'};
257
258         my @uid= $f->{commodid};
259         foreach my $od (qw(org dst)) {
260                 push @uid,
261                         $f->{"${od}_id"},
262                         $f->{"${od}_price"};
263                 push @uid,
264                         $f->{"${od}_stallid"}
265                                 if $qa->{ShowStalls};
266         }
267         $f->{UidLong}= join '_', @uid;
268
269         my $base= 31;
270         my $cmpu= '';
271         map {
272                 my $uue= $_;
273                 my $first= $base;
274                 do {
275                         my $this= $uue % $base;
276 print STDERR "uue=$uue this=$this ";
277                         $uue -= $this;
278                         $uue /= $base;
279                         $this += $first;
280                         $first= 0;
281                         $cmpu .= chr($this + ($this < 26 ? ord('a') :
282                                               $this < 52 ? ord('A')-26
283                                                          : ord('0')-52));
284 print STDERR " uue=$uue this=$this cmpu=$cmpu\n";
285 die "$cmpu $uue ?" if length $cmpu > 20;
286                 } while ($uue);
287                 $cmpu;
288         } @uid;
289         $f->{UidShort}= $cmpu;
290
291         if ($qa->{'debug'}) {
292                 my @outuid;
293                 $_= $f->{UidShort};
294                 my $mul;
295                 while (m/./) {
296                         my $v= m/^[a-z]/ ? ord($&)-ord('a') :
297                                m/^[A-Z]/ ? ord($&)-ord('A')+26 :
298                                m/^[0-9]/ ? ord($&)-ord('0')+52 :
299                                die "$_ ?";
300                         if ($v >= $base) {
301                                 push @outuid, 0;
302                                 $v -= $base;
303                                 $mul= 1;
304 #print STDERR "(next)\n";
305                         }
306                         die "$f->{UidShort} $_ ?" unless defined $mul;
307                         $outuid[$#outuid] += $v * $mul;
308
309 #print STDERR "$f->{UidShort}  $_  $&  v=$v  mul=$mul  ord()=".ord($&).
310 #                       "[vs.".ord('a').",".ord('A').",".ord('0')."]".
311 #                       "  outuid=@outuid\n";
312
313                         $mul *= $base;
314                         s/^.//;
315                 }
316                 my $recons_long= join '_', @outuid;
317                 $f->{UidLong} eq $recons_long or
318                         die "$f->{UidLong} = $f->{UidShort} = $recons_long ?";
319         }
320
321         if (defined $qa->{"R$f->{UidShort}"} &&
322             !defined $qa->{"T$f->{UidShort}"}) {
323                 $f->{Suppress}= 1;
324         }
325
326 }
327 </%perl>
328
329 % my $optimise= $specific && !$confusing && @islandids>1;
330 % if (!$optimise) {
331
332 <p>
333 % if (@islandids<=1) {
334 Route is trivial.
335 % }
336 % if (!$specific) {
337 Route contains archipelago(es), not just specific islands.
338 % }
339 % if ($confusing) {
340 Route is complex - it visits the same island several times
341 and isn't a simple loop.
342 % }
343 Therefore, optimal trade pattern not calculated.
344
345 % } else { # ========== OPTMISATION ==========
346 <%perl>
347
348 my $cplex= "
349 Maximize
350
351   totalprofit:
352                   ".(join " +
353                   ", map {
354                         sprintf "%.20f %s", $_->{ExpectedUnitProfit}, $_->{Var}
355                         } @flows)."
356
357 Subject To
358 ";
359
360 my %avail_csts;
361 foreach my $flow (@flows) {
362         if ($flow->{Suppress}) {
363                 $cplex .= "
364    $flow->{Var} = 0
365 ";
366                 next;
367         }
368         foreach my $od (qw(org dst)) {
369                 my $cstname= join '_', (
370                         'avail',
371                         $flow->{'commodid'},
372                         $od,
373                         $flow->{"${od}_id"},
374                         $flow->{"${od}_price"},
375                         $flow->{"${od}_stallid"},
376                 );
377                         
378                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
379                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty_agg"};
380         }
381 }
382 foreach my $cstname (sort keys %avail_csts) {
383         my $c= $avail_csts{$cstname};
384         $cplex .= "
385    ".   sprintf("%-30s","$cstname:")." ".
386         join("+", @{ $c->{Flows} }).
387         " <= ".$c->{Qty}."\n";
388 }
389
390 $cplex.= "
391 Bounds
392         ".(join "
393         ", map { "$_->{Var} >= 0" } @flows)."
394
395 End
396 ";
397
398 if ($qa->{'debug'}) {
399 </%perl>
400 <pre>
401 <% $cplex |h %>
402 </pre>
403 <%perl>
404 }
405
406 {
407         my $input= pipethrough_prep();
408         print $input $cplex or die $!;
409         my $output= pipethrough_run_along($input, undef, 'glpsol',
410                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
411         print "<pre>\n" if $qa->{'debug'};
412         my $found_section= 0;
413         while (<$output>) {
414                 print encode_entities($_) if $qa->{'debug'};
415                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
416                         die if $found_section>0;
417                         $found_section= 1;
418                         next;
419                 }
420                 next unless $found_section==1;
421                 next if m/^[- ]+$/;
422                 if (!/\S/) {
423                         $found_section= 2;
424                         next;
425                 }
426                 my ($ix, $qty) =
427                         m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
428                 my $flow= $flows[$ix] or die;
429                 $flow->{OptQty}= $qty;
430                 $flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
431                 $flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
432         }
433         print "</pre>\n" if $qa->{'debug'};
434         pipethrough_run_finish($output, 'glpsol');
435         die unless $found_section;
436 };
437
438 $addcols->({ DoReverse => 1 }, qw(
439                 OptQty
440         ));
441 $addcols->({ Total => 0, DoReverse => 1 }, qw(
442                 OptCapital OptProfit
443         ));
444
445 </%perl>
446
447 % } # ========== OPTIMISATION ==========
448
449 % my %ts_sortkeys;
450 % {
451 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
452 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
453 <table id="trades" rules=groups>
454 <colgroup span=1>
455 <colgroup span=2>
456 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
457 <colgroup span=1>
458 <colgroup span=2>
459 <colgroup span=2>
460 <colgroup span=2>
461 <colgroup span=3>
462 %       if ($optimise) {
463 <colgroup span=3>
464 %       }
465 <tr class="spong">
466 <th>
467 <th<% $cdspan %>>Collect
468 <th<% $cdspan %>>Deliver
469 <th>
470 <th colspan=2>Collect
471 <th colspan=2>Deliver
472 <th colspan=2>Profit
473 <th colspan=3>Max
474 %       if ($optimise) {
475 <th colspan=3>Planned
476 %       }
477
478 <tr>
479 <th>
480 <th>Island <% $cdstall %>
481 <th>Island <% $cdstall %>
482 <th>Commodity
483 <th>Price
484 <th>Qty
485 <th>Price
486 <th>Qty
487 <th>Margin
488 <th>Unit
489 <th>Qty
490 <th>Capital
491 <th>Profit
492 %       if ($optimise) {
493 <th>Qty
494 <th>Capital
495 <th>Profit
496 %       }
497 % }
498
499 <tr id="trades_sort">
500 % foreach my $col (@cols) {
501 <th>
502 % }
503
504 % foreach my $flowix (0..$#flows) {
505 %       my $flow= $flows[$flowix];
506 %       my $rowid= "id_row_$flow->{UidShort}";
507 <tr id="<% $rowid %>" class="datarow<% $flowix & 1 %>">
508 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
509     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
510        <% $flow->{Suppress} ? '' : 'checked' %> >
511 %       foreach my $ci (1..$#cols) {
512 %               my $col= $cols[$ci];
513 %               my $v= $flow->{$col->{Name}};
514 %               $col->{Total} += $v if defined $col->{Total};
515 %               $v='' if !$col->{Text} && !$v;
516 %               my $sortkey= $col->{SortColKey} ?
517 %                       $flow->{$col->{SortColKey}} : $v;
518 %               $ts_sortkeys{$ci}{$rowid}= $sortkey;
519 <td <% $col->{Text} ? '' : 'align=right' %>><% $v |h %>
520 %       }
521 % }
522 <tr id="trades_total">
523 <th>
524 <th colspan=2>Total
525 % foreach my $ci (3..$#cols) {
526 %       my $col= $cols[$ci];
527 <td align=right>
528 %       if (defined $col->{Total}) {
529 <% $col->{Total} |h %>
530 %       }
531 % }
532 </table>
533
534 <& tabsort, cols => \@cols, table => 'trades', rowclass => 'datarow',
535         throw => 'trades_sort', tbrow => 'trades_total' &>
536 <&| script &>
537   ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
538   function all_onload() {
539     ts_onload__trades();
540   }
541   window.onload= all_onload;
542 </&script>
543
544 <input type=submit name=update value="Update">
545
546 % if ($optimise) { # ========== TRADING PLAN ==========
547 %
548 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
549 %                               WHERE islandid = ?');
550 % my %da_ages;
551 %
552 <h1>Voyage trading plan</h1>
553 <table rules=groups>
554 % foreach my $i (0..$#islandids) {
555 <tbody>
556 <tr><td colspan=3><strong>
557 %       $iquery->execute($islandids[$i]);
558 %       my ($islandname) = $iquery->fetchrow_array();
559 %       if (!$i) {
560 Start at <% $islandname |h %>
561 %       } else {
562 Sail to <% $islandname |h %>
563 %       }
564 </strong>
565 <%perl>
566      my $age_reported= 0;
567      my %flowlists;
568      foreach my $od (qw(org dst)) {
569         foreach my $f (@flows) {
570                 next if $f->{Suppress};
571                 next unless $f->{"${od}_id"} == $islandids[$i];
572                 next unless $f->{OptQty};
573                 my $price= $f->{"${od}_price"};
574                 my $stallname= $f->{"${od}_stallname"};
575                 my $todo= \$flowlists{$od}{
576                                 $f->{'commodname'},
577                                 (sprintf "%07d", ($od eq 'dst' ?
578                                                 9999999-$price : $price)),
579                                 $stallname
580                         };
581                 $$todo= {
582                         Qty => 0,
583                         orgArbitrage => 0,
584                         dstArbitrage => 0,
585                 } unless $$todo;
586                 $$todo->{'commodname'}= $f->{'commodname'};
587                 $$todo->{'stallname'}= $stallname;
588                 $$todo->{Price}= $price;
589                 $$todo->{Timestamp}= $f->{"${od}_timestamp"};
590                 $$todo->{Qty} += $f->{OptQty};
591                 $$todo->{Total}= $$todo->{Price} * $$todo->{Qty};
592                 $$todo->{Stalls}= $f->{"${od}Stalls"};
593                 if ($f->{'org_id'} == $f->{'dst_id'}) {
594                         $$todo->{"${od}Arbitrage"}= 1;
595                 }
596         }
597      }
598
599      my $total;
600      my $dline= 0;
601      my $show_flows= sub {
602         my ($od,$arbitrage,$collectdeliver) = @_;
603 </%perl>
604 %
605 %       my $todo= $flowlists{$od};
606 %       return unless $todo;
607 %       foreach my $tkey (sort keys %$todo) {
608 %               my $t= $todo->{$tkey};
609 %               next if $t->{"${od}Arbitrage"} != $arbitrage;
610 %               if (!$age_reported++) {
611 %                       my $age= $now - $t->{Timestamp};
612 %                       my $cellid= "da_${i}";
613 %                       $da_ages{$cellid}= $age;
614 <td colspan=3>\
615 (Data age: <span id="<% $cellid %>"><% prettyprint_age($age) %></span>)
616 %               } elsif (!defined $total) {
617 %                       $total= 0;
618 <tbody>
619 %               }
620 %               $total += $t->{Total};
621 %               my $span= 0 + keys %{ $t->{Stalls} };
622 %               my $td= "td rowspan=$span";
623 <tr class="datarow<% $dline %>">
624 <<% $td %>><% $collectdeliver %>
625 <<% $td %>><% $t->{'commodname'} |h %>
626 %
627 %               my @stalls= sort keys %{ $t->{Stalls} };
628 %               my $pstall= sub {
629 %                       my $name= $stalls[$_[0]];
630 <td><% $name |h %>
631 %               };
632 %
633 %               $pstall->(0);
634 <<% $td %> align=right><% $t->{Price} |h %> poe ea.
635 <<% $td %> align=right><% $t->{Qty} |h %> unit(s)
636 <<% $td %> align=right><% $t->{Total} |h %> total
637 %
638 %               foreach my $stallix (1..$#stalls) {
639 <tr class="datarow<% $dline %>">
640 %                       $pstall->($stallix);
641 %               }
642 %
643 %               $dline ^= 1;
644 %       }
645 %    };
646 %    my $show_total= sub {
647 %       my ($totaldesc)= @_;
648 %       if (defined $total) {
649 <tr>
650 <td colspan=3>
651 <td colspan=2 align=right><% $totaldesc %>
652 <td align=right><% $total |h %> total
653 %       }
654 %       $total= undef;
655 %       $dline= 0;
656 <%perl>
657      };
658
659      $show_flows->('dst',0,'Deliver');  $show_total->('Proceeds');
660      $show_flows->('org',1,'Collect');  $show_total->('(Arbitrage) outlay');
661      $show_flows->('dst',1,'Deliver');  $show_total->('(Arbitrage) proceeds');
662      $show_flows->('org',0,'Collect');  $show_total->('Outlay');
663
664 }
665 </%perl>
666 </table>
667 <& query_age:dataages, id2age => \%da_ages &>
668 %
669 % } # ========== TRADING PLAN ==========
670
671 <%init>
672 use CommodsWeb;
673 use Commods;
674 </%init>