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