chiark / gitweb /
a52531c57758a8e5fff6d1cbc66802b483d1cfba
[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                 sum(sell.qty)                                   org_qty,
102                 buy_islands.islandname                          dst_name,
103                 buy_islands.islandid                            dst_id,
104                 buy.price                                       dst_price,
105                 sum(buy.qty)                                    dst_qty,
106                 commods.commodname                              commodname,
107                 commods.commodid                                commodid,
108                 commods.unitmass                                unitmass,
109                 commods.unitvolume                              unitvolume,
110                 buy.price - sell.price                          unitprofit,
111                 min(sell.qty,buy.qty)                           tqty,
112                 min(sell.qty,buy.qty) * (buy.price-sell.price)  profit
113         FROM commods
114         JOIN buy  on commods.commodid = buy.commodid
115         JOIN sell on commods.commodid = sell.commodid
116         JOIN islands as sell_islands on sell.islandid = sell_islands.islandid
117         JOIN islands as buy_islands  on buy.islandid  = buy_islands.islandid
118         WHERE   (
119                 ".join("
120            OR   ", @flow_conds)."
121         )
122           AND   buy.price > sell.price
123         GROUP BY commods.commodid, org_id, org_price, dst_id, dst_price
124         ORDER BY org_name, dst_name, profit DESC, commodname,
125                  org_price, dst_price DESC
126      ";
127
128 my $sth= $dbh->prepare($stmt);
129 $sth->execute(@query_params);
130 my @flows;
131
132 </%perl>
133
134 % if ($qa->{'debug'}) {
135 <pre>
136 <% $stmt |h %>
137 <% join(' | ',@query_params) |h %>
138 </pre>
139 % }
140
141 % {
142 <& dumpqueryresults:start, sth => $sth &>
143 %   my $flow;
144 %   while ($flow= $sth->fetchrow_hashref()) {
145 %       $flow->{Ix}= @flows;
146 %       $flow->{Var}= "f$flow->{Ix}";
147 %       push @flows, $flow;
148 <& dumpqueryresults:row, sth => $sth, row => $flow &>
149 %   }
150 <& dumpqueryresults:end &>
151 % }
152
153 % if (!$specific || $confusing || @islandids<=1) {
154
155 <p>
156 % if (@islandids<=1) {
157 Route is trivial.
158 % }
159 % if (!$specific) {
160 Route contains archipelago(es), not just specific islands.
161 % }
162 % if ($confusing) {
163 Route is complex - it visits the same island several times
164 and isn't a simple loop.
165 % }
166 Therefore, optimal trade pattern not calculated.
167
168 % } else { # ========== OPTMISATION ==========
169 <%perl>
170
171 my $cplex= "
172 Maximize
173
174   totalprofit:
175                   ".(join " +
176                   ", map { "$_->{profit} $_->{Var}" } @flows)."
177
178 Subject To
179 ";
180
181 my %avail_csts;
182 foreach my $flow (@flows) {
183         foreach my $od (qw(org dst)) {
184                 my $cstname= join '_',
185                         'avail',
186                         $flow->{'commodid'},
187                         $od,
188                         $flow->{"${od}_id"},
189                         $flow->{"${od}_price"};
190                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
191                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
192         }
193 }
194 foreach my $cstname (sort keys %avail_csts) {
195         my $c= $avail_csts{$cstname};
196         $cplex .= "
197    ".   sprintf("%-30s","$cstname:")." ".
198         join("+", @{ $c->{Flows} }).
199         " <= ".$c->{Qty}."\n";
200 }
201
202 $cplex.= "
203 Bounds
204         ".(join "
205         ", map { "$_->{Var} >= 0" } @flows)."
206
207 End
208 ";
209
210 if ($qa->{'debug'}) {
211 </%perl>
212 <pre>
213 <% $cplex |h %>
214 </pre>
215 <%perl>
216 }
217
218 {
219         my $input= pipethrough_prep();
220         print $input $cplex or die $!;
221         my $output= pipethrough_run_along($input, undef, 'glpsol',
222                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
223         print "<pre>\n" if $qa->{'debug'};
224         my $found_section= 0;
225         while (<$output>) {
226                 print encode_entities($_) if $qa->{'debug'};
227                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
228                         die if $found_section>0;
229                         $found_section= 1;
230                         next;
231                 }
232                 next unless $found_section==1;
233                 next if m/^[- ]+$/;
234                 if (!/\S/) {
235                         $found_section= 2;
236                         next;
237                 }
238                 m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
239                 die if $1 >= @flows;
240                 $flows[$1]{Optimal}= $2;
241         }
242         print "</pre>\n" if $qa->{'debug'};
243         pipethrough_run_finish($output, 'glpsol');
244         die unless $found_section;
245 };
246
247 print join ' ', map { $_->{Optimal} } @flows;
248
249 </%perl>
250 % } # ========== OPTIMISATION ==========
251
252 <%init>
253 use CommodsWeb;
254 use Commods;
255 </%init>