chiark / gitweb /
cb0ef9379e1a451ebbe3b5c3aff332794ada7850
[ypp-sc-tools.web-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 <%perl>
43
44 my @flow_conds;
45 my @query_params;
46
47 my $sd_condition= sub {
48         my ($bs, $ix) = @_;
49         my $islandid= $islandids[$ix];
50         if (defined $islandid) {
51                 return "${bs}.islandid = $islandid";
52         } else {
53                 push @query_params, $archipelagoes[$ix];
54                 return "${bs}_islands.archipelago = ?";
55         }
56 };
57
58 my %islandpair;
59 # $islandpair{$a,$b}= [ $start_island_ix, $end_island_ix ]
60
61 my $specific= !grep { !defined $_ } @islandids;
62 my $confusing= 0;
63
64 foreach my $src_i (0..$#islandids) {
65         my $src_isle= $islandids[$src_i];
66         my $src_cond= $sd_condition->('sell',$src_i);
67         my @dst_conds;
68         foreach my $dst_i ($src_i..$#islandids) {
69                 my $dst_isle= $islandids[$dst_i];
70                 my $dst_cond= $sd_condition->('buy',$dst_i);
71                 if ($dst_i==$src_i and !defined $src_isle) {
72                         # we always want arbitrage, but mentioning an arch
73                         # once shouldn't produce intra-arch trades
74                         $dst_cond=
75                                 "($dst_cond AND sell.islandid = buy.islandid)";
76                 }
77                 push @dst_conds, $dst_cond;
78
79                 if ($specific && !$confusing &&
80                     # With a circular route, do not carry goods round the loop
81                     !($src_i==0 && $dst_i==$#islandids &&
82                       $src_isle == $islandids[$dst_i])) {
83                         if ($islandpair{$src_isle,$dst_isle}) {
84                                 $confusing= 1;
85                         } else {
86                                 $islandpair{$src_isle,$dst_isle}=
87                                         [ $src_i, $dst_i ];
88                         }
89                 }
90         }
91         push @flow_conds, "$src_cond AND (
92                         ".join("
93                      OR ",@dst_conds)."
94                 )";
95 }
96
97 my $stmt= "             
98         SELECT  sell_islands.islandname                         org_name,
99                 sell_islands.islandid                           org_id,
100                 sell.price                                      org_price,
101                 buy_islands.islandname                          dst_name,
102                 buy_islands.islandid                            dst_id,
103                 buy.price                                       dst_price,
104 ".($qa->{ShowStalls} ? "
105                 sell.stallid                                    org_stallid,
106                 sell_stalls.stallname                           org_stallname,
107                 sell.qty                                        org_qty,
108                 buy.stallid                                     dst_stallid,
109                 buy_stalls.stallname                            dst_stallname,
110                 buy.qty                                         dst_qty,
111 " : "
112                 sum(sell.qty)                                   org_qty,
113                 sum(buy.qty)                                    dst_qty,
114 ")."
115                 commods.commodname                              commodname,
116                 commods.commodid                                commodid,
117                 commods.unitmass                                unitmass,
118                 commods.unitvolume                              unitvolume,
119                 buy.price - sell.price                          unitprofit
120         FROM commods
121         JOIN buy  on commods.commodid = buy.commodid
122         JOIN sell on commods.commodid = sell.commodid
123         JOIN islands as sell_islands on sell.islandid = sell_islands.islandid
124         JOIN islands as buy_islands  on buy.islandid  = buy_islands.islandid
125 ".($qa->{ShowStalls} ? "
126         JOIN stalls  as sell_stalls  on sell.stallid  = sell_stalls.stallid
127         JOIN stalls  as buy_stalls   on buy.stallid   = buy_stalls.stallid
128 " : "")."
129         WHERE   (
130                 ".join("
131            OR   ", @flow_conds)."
132         )
133           AND   buy.price > sell.price
134 ".($qa->{ShowStalls} ? "" : "
135         GROUP BY commods.commodid, org_id, org_price, dst_id, dst_price
136 ")."
137         ORDER BY org_name, dst_name, commodname, unitprofit DESC,
138                  org_price, dst_price DESC
139      ";
140
141 my $sth= $dbh->prepare($stmt);
142 $sth->execute(@query_params);
143 my @flows;
144
145 my @cols;
146
147 my $addcols= sub {
148         my $base= shift @_;
149         foreach my $name (@_) {
150                 push @cols, { Name => $name, %$base };
151         }
152 };
153
154 if ($qa->{ShowStalls}) {
155         $addcols->({ Text => 1 }, qw(
156                 org_name org_stallname
157                 dst_name dst_stallname
158         ));
159 } else {
160         $addcols->({Text => 1 }, qw(
161                 org_name dst_name
162         ));
163 }
164 $addcols->({ Text => 1 }, qw(commodname));
165 $addcols->({},
166         qw(     org_qty org_price dst_qty dst_price
167                 Margin unitprofit MaxQty
168                 MaxCapital MaxProfit
169         ));
170
171 </%perl>
172
173 % if ($qa->{'debug'}) {
174 <pre>
175 <% $stmt |h %>
176 <% join(' | ',@query_params) |h %>
177 </pre>
178 % }
179
180 <& dumptable:start, qa => $qa, sth => $sth &>
181 % {
182 %   my $f;
183 %   while ($f= $sth->fetchrow_hashref()) {
184 <%perl>
185
186         $f->{Ix}= @flows;
187         $f->{Var}= "f$f->{Ix}";
188
189         $f->{MaxQty}= $f->{'org_qty'} < $f->{'dst_qty'}
190                 ? $f->{'org_qty'} : $f->{'dst_qty'};
191         $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
192         $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
193
194         $f->{Margin}= sprintf "%3.1f%%",
195                 $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
196
197         $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
198                 if !$qa->{ShowStalls};
199
200         my @uid= $f->{commodid};
201         foreach my $od (qw(org dst)) {
202                 push @uid,
203                         $f->{"${od}_id"},
204                         $f->{"${od}_price"};
205                 push @uid,
206                         $f->{"${od}_stallid"}
207                                 if $qa->{ShowStalls};
208         }
209         $f->{UidLong}= join '_', @uid;
210
211         my $base= 31;
212         my $cmpu= '';
213         map {
214                 my $uue= $_;
215                 my $first= $base;
216                 do {
217                         my $this= $uue % $base;
218 print STDERR "uue=$uue this=$this ";
219                         $uue -= $this;
220                         $uue /= $base;
221                         $this += $first;
222                         $first= 0;
223                         $cmpu .= chr($this + ($this < 26 ? ord('a') :
224                                               $this < 52 ? ord('A')-26
225                                                          : ord('0')-52));
226 print STDERR " uue=$uue this=$this cmpu=$cmpu\n";
227 die "$cmpu $uue ?" if length $cmpu > 20;
228                 } while ($uue);
229                 $cmpu;
230         } @uid;
231         $f->{UidShort}= $cmpu;
232
233         if ($qa->{'debug'}) {
234                 my @outuid;
235                 $_= $f->{UidShort};
236                 my $mul;
237                 while (m/./) {
238                         my $v= m/^[a-z]/ ? ord($&)-ord('a') :
239                                m/^[A-Z]/ ? ord($&)-ord('A')+26 :
240                                m/^[0-9]/ ? ord($&)-ord('0')+52 :
241                                die "$_ ?";
242                         if ($v >= $base) {
243                                 push @outuid, 0;
244                                 $v -= $base;
245                                 $mul= 1;
246 #print STDERR "(next)\n";
247                         }
248                         die "$f->{UidShort} $_ ?" unless defined $mul;
249                         $outuid[$#outuid] += $v * $mul;
250
251 #print STDERR "$f->{UidShort}  $_  $&  v=$v  mul=$mul  ord()=".ord($&).
252 #                       "[vs.".ord('a').",".ord('A').",".ord('0')."]".
253 #                       "  outuid=@outuid\n";
254
255                         $mul *= $base;
256                         s/^.//;
257                 }
258                 my $recons_long= join '_', @outuid;
259                 $f->{UidLong} eq $recons_long or
260                         die "$f->{UidLong} = $f->{UidShort} = $recons_long ?";
261         }
262
263         if ($qa->{"R$f->{UidShort}"} && !$qa->{"T$f->{UidShort}"}) {
264                 $f->{Suppress}= 1;
265         }
266
267         push @flows, $f;
268
269 </%perl>
270 <& dumptable:row, qa => $qa, sth => $sth, row => $f &>
271 %   }
272 <& dumptable:end, qa => $qa &>
273 % }
274
275 % my $optimise= $specific && !$confusing && @islandids>1;
276 % if (!$optimise) {
277
278 <p>
279 % if (@islandids<=1) {
280 Route is trivial.
281 % }
282 % if (!$specific) {
283 Route contains archipelago(es), not just specific islands.
284 % }
285 % if ($confusing) {
286 Route is complex - it visits the same island several times
287 and isn't a simple loop.
288 % }
289 Therefore, optimal trade pattern not calculated.
290
291 % } else { # ========== OPTMISATION ==========
292 <%perl>
293
294 my $cplex= "
295 Maximize
296
297   totalprofit:
298                   ".(join " +
299                   ", map { "$_->{unitprofit} $_->{Var}" } @flows)."
300
301 Subject To
302 ";
303
304 my %avail_csts;
305 foreach my $flow (@flows) {
306         if ($flow->{Suppress}) {
307                 $cplex .= "
308    $flow->{Var} = 0
309 ";
310                 next;
311         }
312         foreach my $od (qw(org dst)) {
313                 my $cstname= join '_', (
314                         'avail',
315                         $flow->{'commodid'},
316                         $od,
317                         $flow->{"${od}_id"},
318                         $flow->{"${od}_price"},
319                         $flow->{"${od}_stallid"},
320                 );
321                         
322                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
323                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
324         }
325 }
326 foreach my $cstname (sort keys %avail_csts) {
327         my $c= $avail_csts{$cstname};
328         $cplex .= "
329    ".   sprintf("%-30s","$cstname:")." ".
330         join("+", @{ $c->{Flows} }).
331         " <= ".$c->{Qty}."\n";
332 }
333
334 $cplex.= "
335 Bounds
336         ".(join "
337         ", map { "$_->{Var} >= 0" } @flows)."
338
339 End
340 ";
341
342 if ($qa->{'debug'}) {
343 </%perl>
344 <pre>
345 <% $cplex |h %>
346 </pre>
347 <%perl>
348 }
349
350 {
351         my $input= pipethrough_prep();
352         print $input $cplex or die $!;
353         my $output= pipethrough_run_along($input, undef, 'glpsol',
354                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
355         print "<pre>\n" if $qa->{'debug'};
356         my $found_section= 0;
357         while (<$output>) {
358                 print encode_entities($_) if $qa->{'debug'};
359                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
360                         die if $found_section>0;
361                         $found_section= 1;
362                         next;
363                 }
364                 next unless $found_section==1;
365                 next if m/^[- ]+$/;
366                 if (!/\S/) {
367                         $found_section= 2;
368                         next;
369                 }
370                 my ($ix, $qty) =
371                         m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
372                 my $flow= $flows[$ix] or die;
373                 $flow->{OptQty}= $qty;
374                 $flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
375                 $flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
376         }
377         print "</pre>\n" if $qa->{'debug'};
378         pipethrough_run_finish($output, 'glpsol');
379         die unless $found_section;
380 };
381
382 $addcols->({}, qw(
383                 OptQty
384         ));
385 $addcols->({ Total => 0 }, qw(
386                 OptCapital OptProfit
387         ));
388
389 </%perl>
390
391 % } # ========== OPTIMISATION ==========
392
393 % {
394 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
395 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
396 <table rules=groups>
397 <colgroup span=1>
398 <colgroup span=2>
399 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
400 <colgroup span=1>
401 <colgroup span=2>
402 <colgroup span=2>
403 <colgroup span=2>
404 <colgroup span=3>
405 %       if ($optimise) {
406 <colgroup span=3>
407 %       }
408 <tr>
409 <th>
410 <th<% $cdspan %>>Collect
411 <th<% $cdspan %>>Deliver
412 <th>
413 <th colspan=2>Collect
414 <th colspan=2>Deliver
415 <th colspan=2>Profit
416 <th colspan=3>Max
417 %       if ($optimise) {
418 <th colspan=3>Suggested
419 %       }
420
421 <tr>
422 <th>
423 <th>Island <% $cdstall %>
424 <th>Island <% $cdstall %>
425 <th>Commodity
426 <th>Qty
427 <th>Price
428 <th>Qty
429 <th>Price
430 <th>Margin
431 <th>Unit
432 <th>Qty
433 <th>Capital
434 <th>Profit
435 %       if ($optimise) {
436 <th>Qty
437 <th>Capital
438 <th>Profit
439 %       }
440 % }
441
442 % foreach my $flow (@flows) {
443 <tr>
444 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
445     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
446        <% $flow->{Suppress} ? '' : 'checked' %> >
447 %       foreach my $ci (0..$#cols) {
448 %               my $col= $cols[$ci];
449 %               my $v= $flow->{$col->{Name}};
450 %               $col->{Total} += $v if defined $col->{Total};
451 %               $v='' if !$col->{Text} && !$v;
452 <td <% $col->{Text} ? '' : 'align=right' %>><% $v |h %>
453 %       }
454 % }
455 <tr>
456 <th>
457 <th colspan=2>Total
458 % foreach my $ci (2..$#cols) {
459 %       my $col= $cols[$ci];
460 <td align=right>
461 %       if (defined $col->{Total}) {
462 <% $col->{Total} |h %>
463 %       }
464 % }
465 </table>
466
467 <input type=submit name=update value="Update">
468
469 <%init>
470 use CommodsWeb;
471 use Commods;
472 </%init>