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