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