chiark / gitweb /
Tickbox for each line
[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 @columns;
146 if ($qa->{ShowStalls}) {
147         push @columns,       qw(org_name org_stallname dst_name dst_stallname);
148 } else {
149         push @columns,       qw(org_name dst_name);
150 }
151 push @columns,               qw(commodname
152                                 org_price org_qty dst_price dst_qty
153                                 unitprofit PctProfit
154                                 MaxQty MaxCapital MaxProfit);
155
156 </%perl>
157
158 % if ($qa->{'debug'}) {
159 <pre>
160 <% $stmt |h %>
161 <% join(' | ',@query_params) |h %>
162 </pre>
163 % }
164
165 <& dumptable:start, qa => $qa, sth => $sth &>
166 % {
167 %   my $f;
168 %   while ($f= $sth->fetchrow_hashref()) {
169 <%perl>
170
171         $f->{Ix}= @flows;
172         $f->{Var}= "f$f->{Ix}";
173
174         $f->{MaxQty}= $f->{'org_qty'} < $f->{'dst_qty'}
175                 ? $f->{'org_qty'} : $f->{'dst_qty'};
176         $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
177         $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
178
179         $f->{PctProfit}= sprintf "%3.1f%%",
180                 $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
181
182         $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
183                 if !$qa->{ShowStalls};
184
185         my @uid= $f->{commodid};
186         foreach my $od (qw(org dst)) {
187                 push @uid,
188                         $f->{"${od}_id"},
189                         $f->{"${od}_price"},
190                         $f->{"${od}_stallid"};
191         }
192         $f->{Uid}= join '_', @uid;
193
194         if ($qa->{"rtsela_$f->{Uid}"} &&
195             !$qa->{"rtselg_$f->{Uid}"}) {
196                 $f->{Suppress}= 1;
197         }
198
199         push @flows, $f;
200
201 </%perl>
202 <& dumptable:row, qa => $qa, sth => $sth, row => $f &>
203 %   }
204 <& dumptable:end, qa => $qa &>
205 % }
206
207 % my $optimise= $specific && !$confusing && @islandids>1;
208 % if (!$optimise) {
209
210 <p>
211 % if (@islandids<=1) {
212 Route is trivial.
213 % }
214 % if (!$specific) {
215 Route contains archipelago(es), not just specific islands.
216 % }
217 % if ($confusing) {
218 Route is complex - it visits the same island several times
219 and isn't a simple loop.
220 % }
221 Therefore, optimal trade pattern not calculated.
222
223 % } else { # ========== OPTMISATION ==========
224 <%perl>
225
226 my $cplex= "
227 Maximize
228
229   totalprofit:
230                   ".(join " +
231                   ", map { "$_->{unit_profit} $_->{Var}" } @flows)."
232
233 Subject To
234 ";
235
236 my %avail_csts;
237 foreach my $flow (@flows) {
238         if ($flow->{Suppress}) {
239                 $cplex .= "
240    $flow->{Var} = 0
241 ";
242                 next;
243         }
244         foreach my $od (qw(org dst)) {
245                 my $cstname= join '_', (
246                         'avail',
247                         $flow->{'commodid'},
248                         $od,
249                         $flow->{"${od}_id"},
250                         $flow->{"${od}_price"},
251                         $flow->{"${od}_stallid"},
252                 );
253                         
254                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
255                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
256         }
257 }
258 foreach my $cstname (sort keys %avail_csts) {
259         my $c= $avail_csts{$cstname};
260         $cplex .= "
261    ".   sprintf("%-30s","$cstname:")." ".
262         join("+", @{ $c->{Flows} }).
263         " <= ".$c->{Qty}."\n";
264 }
265
266 $cplex.= "
267 Bounds
268         ".(join "
269         ", map { "$_->{Var} >= 0" } @flows)."
270
271 End
272 ";
273
274 if ($qa->{'debug'}) {
275 </%perl>
276 <pre>
277 <% $cplex |h %>
278 </pre>
279 <%perl>
280 }
281
282 {
283         my $input= pipethrough_prep();
284         print $input $cplex or die $!;
285         my $output= pipethrough_run_along($input, undef, 'glpsol',
286                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
287         print "<pre>\n" if $qa->{'debug'};
288         my $found_section= 0;
289         while (<$output>) {
290                 print encode_entities($_) if $qa->{'debug'};
291                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
292                         die if $found_section>0;
293                         $found_section= 1;
294                         next;
295                 }
296                 next unless $found_section==1;
297                 next if m/^[- ]+$/;
298                 if (!/\S/) {
299                         $found_section= 2;
300                         next;
301                 }
302                 my ($ix, $qty) =
303                         m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
304                 my $flow= $flows[$ix] or die;
305                 $flow->{OptQty}= $qty;
306                 $flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
307                 $flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
308         }
309         print "</pre>\n" if $qa->{'debug'};
310         pipethrough_run_finish($output, 'glpsol');
311         die unless $found_section;
312 };
313
314 print join ' ', map { $_->{Optimal} } @flows;
315
316 push @columns, qw(OptQty OptCapital OptProfit);
317
318 </%perl>
319
320 % } # ========== OPTIMISATION ==========
321
322 % {
323 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
324 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
325 <table>
326 <tr>
327 <th>
328 <th<% $cdspan %>>Collect
329 <th<% $cdspan %>>Deliver
330 <th>
331 <th colspan=2>Collect
332 <th colspan=2>Deliver
333 <th colspan=2>Profit
334 <th colspan=3>Max
335 %       if ($optimise) {
336 <th colspan=3>Suggested
337 %       }
338
339 <tr>
340 <th>
341 <th>Island <% $cdstall %>
342 <th>Island <% $cdstall %>
343 <th>Commodity
344 <th>Price
345 <th>Qty
346 <th>Price
347 <th>Qty
348 <th>Unit
349 <th>Margin
350 <th>Qty
351 <th>Capital
352 <th>Profit
353 %       if ($optimise) {
354 <th>Qty
355 <th>Capital
356 <th>Profit
357 %       }
358 % }
359
360 % foreach my $flow (@flows) {
361 <tr>
362 <td><input type=hidden   name=rtsela_<% $flow->{Uid} %> value=1>
363     <input type=checkbox name=rtselg_<% $flow->{Uid} %> value=1
364        <% $flow->{Suppress} ? '' : 'checked' %> >
365 %       foreach my $col (@columns) {
366 <td><% $flow->{$col} |h %>
367 %       }
368 % }
369 </table>
370
371 <input type=submit name=update value="Update">
372
373 <%init>
374 use CommodsWeb;
375 use Commods;
376 </%init>