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                 push @uid,
 191                         $f->{"${od}_stallid"}
 192                                 if $qa->{ShowStalls};
 193         }
 194         $f->{UidLong}= join '_', @uid;
 195
 196         my $base= 31;
 197         my $cmpu= '';
 198         map {
 199                 my $uue= $_;
 200                 my $first= $base;
 201                 do {
 202                         my $this= $uue % $base;
 203 print STDERR "uue=$uue this=$this ";
 204                         $uue -= $this;
 205                         $uue /= $base;
 206                         $this += $first;
 207                         $first= 0;
 208                         $cmpu .= chr($this + ($this < 26 ? ord('a') :
 209                                               $this < 52 ? ord('A')-26
 210                                                          : ord('0')-52));
 211 print STDERR " uue=$uue this=$this cmpu=$cmpu\n";
 212 die "$cmpu $uue ?" if length $cmpu > 20;
 213                 } while ($uue);
 214                 $cmpu;
 215         } @uid;
 216         $f->{UidShort}= $cmpu;
 217
 218         if ($qa->{'debug'}) {
 219                 my @outuid;
 220                 $_= $f->{UidShort};
 221                 my $mul;
 222                 while (m/./) {
 223                         my $v= m/^[a-z]/ ? ord($&)-ord('a') :
 224                                m/^[A-Z]/ ? ord($&)-ord('A')+26 :
 225                                m/^[0-9]/ ? ord($&)-ord('0')+52 :
 226                                die "$_ ?";
 227                         if ($v >= $base) {
 228                                 push @outuid, 0;
 229                                 $v -= $base;
 230                                 $mul= 1;
 231 #print STDERR "(next)\n";
 232                         }
 233                         die "$f->{UidShort} $_ ?" unless defined $mul;
 234                         $outuid[$#outuid] += $v * $mul;
 235
 236 #print STDERR "$f->{UidShort}  $_  $&  v=$v  mul=$mul  ord()=".ord($&).
 237 #                       "[vs.".ord('a').",".ord('A').",".ord('0')."]".
 238 #                       "  outuid=@outuid\n";
 239
 240                         $mul *= $base;
 241                         s/^.//;
 242                 }
 243                 my $recons_long= join '_', @outuid;
 244                 $f->{UidLong} eq $recons_long or
 245                         die "$f->{UidLong} = $f->{UidShort} = $recons_long ?";
 246         }
 247
 248         if ($qa->{"R$f->{UidShort}"} && !$qa->{"T$f->{UidShort}"}) {
 249                 $f->{Suppress}= 1;
 250         }
 251
 252         push @flows, $f;
 253
 254 </%perl>
 255 <& dumptable:row, qa => $qa, sth => $sth, row => $f &>
 256 %   }
 257 <& dumptable:end, qa => $qa &>
 258 % }
 259
 260 % my $optimise= $specific && !$confusing && @islandids>1;
 261 % if (!$optimise) {
 262
 263 <p>
 264 % if (@islandids<=1) {
 265 Route is trivial.
 266 % }
 267 % if (!$specific) {
 268 Route contains archipelago(es), not just specific islands.
 269 % }
 270 % if ($confusing) {
 271 Route is complex - it visits the same island several times
 272 and isn't a simple loop.
 273 % }
 274 Therefore, optimal trade pattern not calculated.
 275
 276 % } else { # ========== OPTMISATION ==========
 277 <%perl>
 278
 279 my $cplex= "
 280 Maximize
 281
 282   totalprofit:
 283                   ".(join " +
 284                   ", map { "$_->{unitprofit} $_->{Var}" } @flows)."
 285
 286 Subject To
 287 ";
 288
 289 my %avail_csts;
 290 foreach my $flow (@flows) {
 291         if ($flow->{Suppress}) {
 292                 $cplex .= "
 293    $flow->{Var} = 0
 294 ";
 295                 next;
 296         }
 297         foreach my $od (qw(org dst)) {
 298                 my $cstname= join '_', (
 299                         'avail',
 300                         $flow->{'commodid'},
 301                         $od,
 302                         $flow->{"${od}_id"},
 303                         $flow->{"${od}_price"},
 304                         $flow->{"${od}_stallid"},
 305                 );
 306
 307                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
 308                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
 309         }
 310 }
 311 foreach my $cstname (sort keys %avail_csts) {
 312         my $c= $avail_csts{$cstname};
 313         $cplex .= "
 314    ".   sprintf("%-30s","$cstname:")." ".
 315         join("+", @{ $c->{Flows} }).
 316         " <= ".$c->{Qty}."\n";
 317 }
 318
 319 $cplex.= "
 320 Bounds
 321         ".(join "
 322         ", map { "$_->{Var} >= 0" } @flows)."
 323
 324 End
 325 ";
 326
 327 if ($qa->{'debug'}) {
 328 </%perl>
 329 <pre>
 330 <% $cplex |h %>
 331 </pre>
 332 <%perl>
 333 }
 334
 335 {
 336         my $input= pipethrough_prep();
 337         print $input $cplex or die $!;
 338         my $output= pipethrough_run_along($input, undef, 'glpsol',
 339                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
 340         print "<pre>\n" if $qa->{'debug'};
 341         my $found_section= 0;
 342         while (<$output>) {
 343                 print encode_entities($_) if $qa->{'debug'};
 344                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
 345                         die if $found_section>0;
 346                         $found_section= 1;
 347                         next;
 348                 }
 349                 next unless $found_section==1;
 350                 next if m/^[- ]+$/;
 351                 if (!/\S/) {
 352                         $found_section= 2;
 353                         next;
 354                 }
 355                 my ($ix, $qty) =
 356                         m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
 357                 my $flow= $flows[$ix] or die;
 358                 $flow->{OptQty}= $qty;
 359                 $flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
 360                 $flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
 361         }
 362         print "</pre>\n" if $qa->{'debug'};
 363         pipethrough_run_finish($output, 'glpsol');
 364         die unless $found_section;
 365 };
 366
 367 push @columns, qw(OptQty OptCapital OptProfit);
 368
 369 </%perl>
 370
 371 % } # ========== OPTIMISATION ==========
 372
 373 % {
 374 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
 375 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
 376 <table>
 377 <tr>
 378 <th>
 379 <th<% $cdspan %>>Collect
 380 <th<% $cdspan %>>Deliver
 381 <th>
 382 <th colspan=2>Collect
 383 <th colspan=2>Deliver
 384 <th colspan=2>Profit
 385 <th colspan=3>Max
 386 %       if ($optimise) {
 387 <th colspan=3>Suggested
 388 %       }
 389
 390 <tr>
 391 <th>
 392 <th>Island <% $cdstall %>
 393 <th>Island <% $cdstall %>
 394 <th>Commodity
 395 <th>Price
 396 <th>Qty
 397 <th>Price
 398 <th>Qty
 399 <th>Unit
 400 <th>Margin
 401 <th>Qty
 402 <th>Capital
 403 <th>Profit
 404 %       if ($optimise) {
 405 <th>Qty
 406 <th>Capital
 407 <th>Profit
 408 %       }
 409 % }
 410
 411 % foreach my $flow (@flows) {
 412 <tr>
 413 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
 414     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
 415        <% $flow->{Suppress} ? '' : 'checked' %> >
 416 %       foreach my $col (@columns) {
 417 <td><% $flow->{$col} |h %>
 418 %       }
 419 % }
 420 </table>
 421
 422 <input type=submit name=update value="Update">
 423
 424 <%init>
 425 use CommodsWeb;
 426 use Commods;
 427 </%init>