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 ========== TODO ==========
  36 16:36 <ceb> alpha,byrne,papaya,turtle,jorvik,luthien is my example
  37
  38 16:46 <ceb> Also trading plan not functional but I guess you know that :-)
  39
  40 use POST for update.  Hrrm.
  41
  42 LATER OR NOT AT ALL
  43
  44 adjustable potential cost of losses (rather than fixed 1e-BIG per league)
  45
  46 max volume/mass
  47
  48 ========== TODO ==========
  49
  50 </%doc>
  51 <%args>
  52 $dbh
  53 @islandids
  54 @archipelagoes
  55 $qa
  56 </%args>
  57 <%perl>
  58
  59 my $loss_per_league= 1e-7;
  60
  61 my @flow_conds;
  62 my @query_params;
  63
  64 my $sd_condition= sub {
  65         my ($bs, $ix) = @_;
  66         my $islandid= $islandids[$ix];
  67         if (defined $islandid) {
  68                 return "${bs}.islandid = $islandid";
  69         } else {
  70                 push @query_params, $archipelagoes[$ix];
  71                 return "${bs}_islands.archipelago = ?";
  72         }
  73 };
  74
  75 my %islandpair;
  76 # $islandpair{$a,$b}= [ $start_island_ix, $end_island_ix ]
  77
  78 my $specific= !grep { !defined $_ } @islandids;
  79 my $confusing= 0;
  80
  81 foreach my $src_i (0..$#islandids) {
  82         my $src_isle= $islandids[$src_i];
  83         my $src_cond= $sd_condition->('sell',$src_i);
  84         my @dst_conds;
  85         foreach my $dst_i ($src_i..$#islandids) {
  86                 my $dst_isle= $islandids[$dst_i];
  87                 my $dst_cond= $sd_condition->('buy',$dst_i);
  88                 if ($dst_i==$src_i and !defined $src_isle) {
  89                         # we always want arbitrage, but mentioning an arch
  90                         # once shouldn't produce intra-arch trades
  91                         $dst_cond=
  92                                 "($dst_cond AND sell.islandid = buy.islandid)";
  93                 }
  94                 push @dst_conds, $dst_cond;
  95
  96                 if ($specific && !$confusing &&
  97                     # With a circular route, do not carry goods round the loop
  98                     !($src_i==0 && $dst_i==$#islandids &&
  99                       $src_isle == $islandids[$dst_i])) {
 100                         if ($islandpair{$src_isle,$dst_isle}) {
 101                                 $confusing= 1;
 102                         } else {
 103                                 $islandpair{$src_isle,$dst_isle}=
 104                                         [ $src_i, $dst_i ];
 105                         }
 106                 }
 107         }
 108         push @flow_conds, "$src_cond AND (
 109                         ".join("
 110                      OR ",@dst_conds)."
 111                 )";
 112 }
 113
 114 my $stmt= "
 115         SELECT  sell_islands.islandname                         org_name,
 116                 sell_islands.islandid                           org_id,
 117                 sell.price                                      org_price,
 118                 buy_islands.islandname                          dst_name,
 119                 buy_islands.islandid                            dst_id,
 120                 buy.price                                       dst_price,
 121 ".($qa->{ShowStalls} ? "
 122                 sell.stallid                                    org_stallid,
 123                 sell_stalls.stallname                           org_stallname,
 124                 sell.qty                                        org_qty,
 125                 buy.stallid                                     dst_stallid,
 126                 buy_stalls.stallname                            dst_stallname,
 127                 buy.qty                                         dst_qty,
 128 " : "
 129                 sum(sell.qty)                                   org_qty,
 130                 sum(buy.qty)                                    dst_qty,
 131 ")."
 132                 commods.commodname                              commodname,
 133                 commods.commodid                                commodid,
 134                 commods.unitmass                                unitmass,
 135                 commods.unitvolume                              unitvolume,
 136                 dist                                            dist,
 137                 buy.price - sell.price                          unitprofit
 138         FROM commods
 139         JOIN buy  ON commods.commodid = buy.commodid
 140         JOIN sell ON commods.commodid = sell.commodid
 141         JOIN islands AS sell_islands ON sell.islandid = sell_islands.islandid
 142         JOIN islands AS buy_islands  ON buy.islandid  = buy_islands.islandid
 143 ".($qa->{ShowStalls} ? "
 144         JOIN stalls  AS sell_stalls  ON sell.stallid  = sell_stalls.stallid
 145         JOIN stalls  AS buy_stalls   ON buy.stallid   = buy_stalls.stallid
 146 " : "")."
 147         JOIN dists ON aiid = sell.islandid AND biid = buy.islandid
 148         WHERE   (
 149                 ".join("
 150            OR   ", @flow_conds)."
 151         )
 152           AND   buy.price > sell.price
 153 ".($qa->{ShowStalls} ? "" : "
 154         GROUP BY commods.commodid, org_id, org_price, dst_id, dst_price
 155 ")."
 156         ORDER BY org_name, dst_name, commodname, unitprofit DESC,
 157                  org_price, dst_price DESC
 158      ";
 159
 160 my $sth= $dbh->prepare($stmt);
 161 $sth->execute(@query_params);
 162 my @flows;
 163
 164 my @cols= ({ NoSort => 1 });
 165
 166 my $addcols= sub {
 167         my $base= shift @_;
 168         foreach my $name (@_) {
 169                 my $col= { Name => $name, %$base };
 170                 $col->{Numeric}=1 if !$col->{Text};
 171                 push @cols, $col;
 172         }
 173 };
 174
 175 if ($qa->{ShowStalls}) {
 176         $addcols->({ Text => 1 }, qw(
 177                 org_name org_stallname
 178                 dst_name dst_stallname
 179         ));
 180 } else {
 181         $addcols->({Text => 1 }, qw(
 182                 org_name dst_name
 183         ));
 184 }
 185 $addcols->({ Text => 1 }, qw(commodname));
 186 $addcols->({ DoReverse => 1 },
 187         qw(     org_price org_qty dst_price dst_qty
 188                 Margin unitprofit MaxQty
 189                 MaxCapital MaxProfit
 190         ));
 191
 192 </%perl>
 193
 194 % if ($qa->{'debug'}) {
 195 <pre>
 196 <% $stmt |h %>
 197 <% join(' | ',@query_params) |h %>
 198 </pre>
 199 % }
 200
 201 <& dumptable:start, qa => $qa, sth => $sth &>
 202 % {
 203 %   my $f;
 204 %   while ($f= $sth->fetchrow_hashref()) {
 205 <%perl>
 206
 207         $f->{Ix}= @flows;
 208         $f->{Var}= "f$f->{Ix}";
 209
 210         $f->{MaxQty}= $f->{'org_qty'} < $f->{'dst_qty'}
 211                 ? $f->{'org_qty'} : $f->{'dst_qty'};
 212         $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
 213         $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
 214
 215         $f->{Margin}= sprintf "%3.1f%%",
 216                 $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
 217
 218         $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
 219                 if !$qa->{ShowStalls};
 220
 221         $f->{ExpectedUnitProfit}=
 222                 $f->{'dst_price'} * (1.0 - $loss_per_league) ** $f->{'dist'}
 223                 - $f->{'src_price'};
 224
 225         my @uid= $f->{commodid};
 226         foreach my $od (qw(org dst)) {
 227                 push @uid,
 228                         $f->{"${od}_id"},
 229                         $f->{"${od}_price"};
 230                 push @uid,
 231                         $f->{"${od}_stallid"}
 232                                 if $qa->{ShowStalls};
 233         }
 234         $f->{UidLong}= join '_', @uid;
 235
 236         my $base= 31;
 237         my $cmpu= '';
 238         map {
 239                 my $uue= $_;
 240                 my $first= $base;
 241                 do {
 242                         my $this= $uue % $base;
 243 print STDERR "uue=$uue this=$this ";
 244                         $uue -= $this;
 245                         $uue /= $base;
 246                         $this += $first;
 247                         $first= 0;
 248                         $cmpu .= chr($this + ($this < 26 ? ord('a') :
 249                                               $this < 52 ? ord('A')-26
 250                                                          : ord('0')-52));
 251 print STDERR " uue=$uue this=$this cmpu=$cmpu\n";
 252 die "$cmpu $uue ?" if length $cmpu > 20;
 253                 } while ($uue);
 254                 $cmpu;
 255         } @uid;
 256         $f->{UidShort}= $cmpu;
 257
 258         if ($qa->{'debug'}) {
 259                 my @outuid;
 260                 $_= $f->{UidShort};
 261                 my $mul;
 262                 while (m/./) {
 263                         my $v= m/^[a-z]/ ? ord($&)-ord('a') :
 264                                m/^[A-Z]/ ? ord($&)-ord('A')+26 :
 265                                m/^[0-9]/ ? ord($&)-ord('0')+52 :
 266                                die "$_ ?";
 267                         if ($v >= $base) {
 268                                 push @outuid, 0;
 269                                 $v -= $base;
 270                                 $mul= 1;
 271 #print STDERR "(next)\n";
 272                         }
 273                         die "$f->{UidShort} $_ ?" unless defined $mul;
 274                         $outuid[$#outuid] += $v * $mul;
 275
 276 #print STDERR "$f->{UidShort}  $_  $&  v=$v  mul=$mul  ord()=".ord($&).
 277 #                       "[vs.".ord('a').",".ord('A').",".ord('0')."]".
 278 #                       "  outuid=@outuid\n";
 279
 280                         $mul *= $base;
 281                         s/^.//;
 282                 }
 283                 my $recons_long= join '_', @outuid;
 284                 $f->{UidLong} eq $recons_long or
 285                         die "$f->{UidLong} = $f->{UidShort} = $recons_long ?";
 286         }
 287
 288         if (defined $qa->{"R$f->{UidShort}"} &&
 289             !defined $qa->{"T$f->{UidShort}"}) {
 290                 $f->{Suppress}= 1;
 291         }
 292
 293         push @flows, $f;
 294
 295 </%perl>
 296 <& dumptable:row, qa => $qa, sth => $sth, row => $f &>
 297 %   }
 298 <& dumptable:end, qa => $qa &>
 299 % }
 300
 301 % my $optimise= $specific && !$confusing && @islandids>1;
 302 % if (!$optimise) {
 303
 304 <p>
 305 % if (@islandids<=1) {
 306 Route is trivial.
 307 % }
 308 % if (!$specific) {
 309 Route contains archipelago(es), not just specific islands.
 310 % }
 311 % if ($confusing) {
 312 Route is complex - it visits the same island several times
 313 and isn't a simple loop.
 314 % }
 315 Therefore, optimal trade pattern not calculated.
 316
 317 % } else { # ========== OPTMISATION ==========
 318 <%perl>
 319
 320 my $cplex= "
 321 Maximize
 322
 323   totalprofit:
 324                   ".(join " +
 325                   ", map {
 326                         sprintf "%.20f %s", $_->{ExpectedUnitProfit}, $_->{Var}
 327                         } @flows)."
 328
 329 Subject To
 330 ";
 331
 332 my %avail_csts;
 333 foreach my $flow (@flows) {
 334         if ($flow->{Suppress}) {
 335                 $cplex .= "
 336    $flow->{Var} = 0
 337 ";
 338                 next;
 339         }
 340         foreach my $od (qw(org dst)) {
 341                 my $cstname= join '_', (
 342                         'avail',
 343                         $flow->{'commodid'},
 344                         $od,
 345                         $flow->{"${od}_id"},
 346                         $flow->{"${od}_price"},
 347                         $flow->{"${od}_stallid"},
 348                 );
 349
 350                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
 351                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
 352         }
 353 }
 354 foreach my $cstname (sort keys %avail_csts) {
 355         my $c= $avail_csts{$cstname};
 356         $cplex .= "
 357    ".   sprintf("%-30s","$cstname:")." ".
 358         join("+", @{ $c->{Flows} }).
 359         " <= ".$c->{Qty}."\n";
 360 }
 361
 362 $cplex.= "
 363 Bounds
 364         ".(join "
 365         ", map { "$_->{Var} >= 0" } @flows)."
 366
 367 End
 368 ";
 369
 370 if ($qa->{'debug'}) {
 371 </%perl>
 372 <pre>
 373 <% $cplex |h %>
 374 </pre>
 375 <%perl>
 376 }
 377
 378 {
 379         my $input= pipethrough_prep();
 380         print $input $cplex or die $!;
 381         my $output= pipethrough_run_along($input, undef, 'glpsol',
 382                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
 383         print "<pre>\n" if $qa->{'debug'};
 384         my $found_section= 0;
 385         while (<$output>) {
 386                 print encode_entities($_) if $qa->{'debug'};
 387                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
 388                         die if $found_section>0;
 389                         $found_section= 1;
 390                         next;
 391                 }
 392                 next unless $found_section==1;
 393                 next if m/^[- ]+$/;
 394                 if (!/\S/) {
 395                         $found_section= 2;
 396                         next;
 397                 }
 398                 my ($ix, $qty) =
 399                         m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
 400                 my $flow= $flows[$ix] or die;
 401                 $flow->{OptQty}= $qty;
 402                 $flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
 403                 $flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
 404         }
 405         print "</pre>\n" if $qa->{'debug'};
 406         pipethrough_run_finish($output, 'glpsol');
 407         die unless $found_section;
 408 };
 409
 410 $addcols->({ DoReverse => 1 }, qw(
 411                 OptQty
 412         ));
 413 $addcols->({ Total => 0, DoReverse => 1 }, qw(
 414                 OptCapital OptProfit
 415         ));
 416
 417 </%perl>
 418
 419 % } # ========== OPTIMISATION ==========
 420
 421 % my %ts_sortkeys;
 422 % {
 423 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
 424 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
 425 <table id="trades" rules=groups>
 426 <colgroup span=1>
 427 <colgroup span=2>
 428 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
 429 <colgroup span=1>
 430 <colgroup span=2>
 431 <colgroup span=2>
 432 <colgroup span=2>
 433 <colgroup span=3>
 434 %       if ($optimise) {
 435 <colgroup span=3>
 436 %       }
 437 <tr class="spong">
 438 <th>
 439 <th<% $cdspan %>>Collect
 440 <th<% $cdspan %>>Deliver
 441 <th>
 442 <th colspan=2>Collect
 443 <th colspan=2>Deliver
 444 <th colspan=2>Profit
 445 <th colspan=3>Max
 446 %       if ($optimise) {
 447 <th colspan=3>Planned
 448 %       }
 449
 450 <tr>
 451 <th>
 452 <th>Island <% $cdstall %>
 453 <th>Island <% $cdstall %>
 454 <th>Commodity
 455 <th>Price
 456 <th>Qty
 457 <th>Price
 458 <th>Qty
 459 <th>Margin
 460 <th>Unit
 461 <th>Qty
 462 <th>Capital
 463 <th>Profit
 464 %       if ($optimise) {
 465 <th>Qty
 466 <th>Capital
 467 <th>Profit
 468 %       }
 469 % }
 470
 471 <tr id="trades_sort">
 472 % foreach my $col (@cols) {
 473 <th>
 474 % }
 475
 476 % foreach my $flowix (0..$#flows) {
 477 %       my $flow= $flows[$flowix];
 478 %       my $rowid= "id_row_$flow->{UidShort}";
 479 <tr id="<% $rowid %>" class="datarow<% $flowix & 1 %>">
 480 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
 481     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
 482        <% $flow->{Suppress} ? '' : 'checked' %> >
 483 %       foreach my $ci (1..$#cols) {
 484 %               my $col= $cols[$ci];
 485 %               my $v= $flow->{$col->{Name}};
 486 %               $col->{Total} += $v if defined $col->{Total};
 487 %               $v='' if !$col->{Text} && !$v;
 488 %               $ts_sortkeys{$ci}{$rowid}= $v;
 489 <td <% $col->{Text} ? '' : 'align=right' %>><% $v |h %>
 490 %       }
 491 % }
 492 <tr id="trades_total">
 493 <th>
 494 <th colspan=2>Total
 495 % foreach my $ci (3..$#cols) {
 496 %       my $col= $cols[$ci];
 497 <td align=right>
 498 %       if (defined $col->{Total}) {
 499 <% $col->{Total} |h %>
 500 %       }
 501 % }
 502 </table>
 503
 504 <& tabsort, cols => \@cols, table => 'trades', rowclass => 'datarow',
 505         throw => 'trades_sort', tbrow => 'trades_total' &>
 506 <&| script &>
 507   ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
 508   function all_onload() {
 509     ts_onload__trades();
 510   }
 511   window.onload= all_onload;
 512 </&script>
 513
 514 <input type=submit name=update value="Update">
 515
 516 % if ($optimise) { # ========== TRADING PLAN ==========
 517 %
 518 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
 519 %                               WHERE islandid = ?');
 520 %
 521 <h1>Voyage trading plan</h1>
 522 <table>
 523 % foreach my $i (0..$#islandids) {
 524 <tr><td colspan=4><strong>
 525 %       $iquery->execute($islandids[$i]);
 526 %       my ($islandname) = $iquery->fetchrow_array();
 527 %       if (!$i) {
 528 Start at <% $islandname |h %>
 529 %       } else {
 530 Sail to <% $islandname |h %>
 531 %       }
 532 </strong>
 533 %    foreach my $od (qw(dst org)) {
 534 %       my $sign= $od eq 'dst' ? -1 : +1;
 535 %       foreach my $f (sort {
 536 %                       $a->{'commodname'} cmp $b->{'commodname'}
 537 %               or $sign * ($a->{"${od}_price"} <=> $b->{"${od}_price"})
 538 %               or      $a->{"${od}_stallname"} cmp $b->{"${od}_stallname"}
 539 %               } @flows) {
 540 %               next if $f->{Suppress};
 541 %               next unless $f->{"${od}_id"} == $islandids[$i];
 542 %               next unless $f->{OptQty};
 543 <tr><td>Buy or sell flow
 544 %       }
 545 %    }
 546 % }
 547 </table>
 548 %
 549 % } # ========== TRADING PLAN ==========
 550
 551 <%init>
 552 use CommodsWeb;
 553 use Commods;
 554 </%init>