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