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>