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)                           max_qty,
 112                 min(sell.qty,buy.qty) * (buy.price-sell.price)  max_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, max_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 my @columns= qw(org_name dst_name commodname
 133                 org_price org_qty dst_price dst_qty
 134                 max_qty max_profit);
 135
 136 </%perl>
 137
 138 % if ($qa->{'debug'}) {
 139 <pre>
 140 <% $stmt |h %>
 141 <% join(' | ',@query_params) |h %>
 142 </pre>
 143 % }
 144
 145 % {
 146 <& dumptable:start, sth => $sth &>
 147 %   my $flow;
 148 %   while ($flow= $sth->fetchrow_hashref()) {
 149 %       $flow->{Ix}= @flows;
 150 %       $flow->{Var}= "f$flow->{Ix}";
 151 %       push @flows, $flow;
 152 <& dumptable:row, sth => $sth, row => $flow &>
 153 %   }
 154 <& dumptable:end &>
 155 % }
 156
 157 % if (!$specific || $confusing || @islandids<=1) {
 158
 159 <p>
 160 % if (@islandids<=1) {
 161 Route is trivial.
 162 % }
 163 % if (!$specific) {
 164 Route contains archipelago(es), not just specific islands.
 165 % }
 166 % if ($confusing) {
 167 Route is complex - it visits the same island several times
 168 and isn't a simple loop.
 169 % }
 170 Therefore, optimal trade pattern not calculated.
 171
 172 % } else { # ========== OPTMISATION ==========
 173 <%perl>
 174
 175 my $cplex= "
 176 Maximize
 177
 178   totalprofit:
 179                   ".(join " +
 180                   ", map { "$_->{unit_profit} $_->{Var}" } @flows)."
 181
 182 Subject To
 183 ";
 184
 185 my %avail_csts;
 186 foreach my $flow (@flows) {
 187         foreach my $od (qw(org dst)) {
 188                 my $cstname= join '_',
 189                         'avail',
 190                         $flow->{'commodid'},
 191                         $od,
 192                         $flow->{"${od}_id"},
 193                         $flow->{"${od}_price"};
 194                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
 195                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
 196         }
 197 }
 198 foreach my $cstname (sort keys %avail_csts) {
 199         my $c= $avail_csts{$cstname};
 200         $cplex .= "
 201    ".   sprintf("%-30s","$cstname:")." ".
 202         join("+", @{ $c->{Flows} }).
 203         " <= ".$c->{Qty}."\n";
 204 }
 205
 206 $cplex.= "
 207 Bounds
 208         ".(join "
 209         ", map { "$_->{Var} >= 0" } @flows)."
 210
 211 End
 212 ";
 213
 214 if ($qa->{'debug'}) {
 215 </%perl>
 216 <pre>
 217 <% $cplex |h %>
 218 </pre>
 219 <%perl>
 220 }
 221
 222 {
 223         my $input= pipethrough_prep();
 224         print $input $cplex or die $!;
 225         my $output= pipethrough_run_along($input, undef, 'glpsol',
 226                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
 227         print "<pre>\n" if $qa->{'debug'};
 228         my $found_section= 0;
 229         while (<$output>) {
 230                 print encode_entities($_) if $qa->{'debug'};
 231                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
 232                         die if $found_section>0;
 233                         $found_section= 1;
 234                         next;
 235                 }
 236                 next unless $found_section==1;
 237                 next if m/^[- ]+$/;
 238                 if (!/\S/) {
 239                         $found_section= 2;
 240                         next;
 241                 }
 242                 my ($ix, $qty) =
 243                         m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
 244                 my $flow= $flows[$ix] or die;
 245                 $flow->{Opt_qty}= $qty;
 246                 $flow->{Opt_profit}= $flow->{'unitprofit'} * $qty;
 247         }
 248         print "</pre>\n" if $qa->{'debug'};
 249         pipethrough_run_finish($output, 'glpsol');
 250         die unless $found_section;
 251 };
 252
 253 print join ' ', map { $_->{Optimal} } @flows;
 254
 255 push @columns, qw(Opt_qty Opt_profit);
 256
 257 </%perl>
 258 <% join ' ', @columns %>
 259
 260 % } # ========== OPTIMISATION ==========
 261
 262 <%init>
 263 use CommodsWeb;
 264 use Commods;
 265 </%init>