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