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                 sell_uploads.timestamp                          org_timestamp,
 119                 buy_islands.islandname                          dst_name,
 120                 buy_islands.islandid                            dst_id,
 121                 buy.price                                       dst_price,
 122                 buy_uploads.timestamp                           dst_timestamp,
 123 ".($qa->{ShowStalls} ? "
 124                 sell.stallid                                    org_stallid,
 125                 sell_stalls.stallname                           org_stallname,
 126                 sell.qty                                        org_qty,
 127                 buy.stallid                                     dst_stallid,
 128                 buy_stalls.stallname                            dst_stallname,
 129                 buy.qty                                         dst_qty,
 130 " : "
 131                 sum(sell.qty)                                   org_qty,
 132                 sum(buy.qty)                                    dst_qty,
 133 ")."
 134                 commods.commodname                              commodname,
 135                 commods.commodid                                commodid,
 136                 commods.unitmass                                unitmass,
 137                 commods.unitvolume                              unitvolume,
 138                 dist                                            dist,
 139                 buy.price - sell.price                          unitprofit
 140         FROM commods
 141         JOIN buy  ON commods.commodid = buy.commodid
 142         JOIN sell ON commods.commodid = sell.commodid
 143         JOIN islands AS sell_islands ON sell.islandid = sell_islands.islandid
 144         JOIN islands AS buy_islands  ON buy.islandid  = buy_islands.islandid
 145         JOIN uploads AS sell_uploads ON sell.islandid = sell_uploads.islandid
 146         JOIN uploads AS buy_uploads  ON buy.islandid  = buy_uploads.islandid
 147 ".($qa->{ShowStalls} ? "
 148         JOIN stalls  AS sell_stalls  ON sell.stallid  = sell_stalls.stallid
 149         JOIN stalls  AS buy_stalls   ON buy.stallid   = buy_stalls.stallid
 150 " : "")."
 151         JOIN dists ON aiid = sell.islandid AND biid = buy.islandid
 152         WHERE   (
 153                 ".join("
 154            OR   ", @flow_conds)."
 155         )
 156           AND   buy.price > sell.price
 157 ".($qa->{ShowStalls} ? "" : "
 158         GROUP BY commods.commodid, org_id, org_price, dst_id, dst_price
 159 ")."
 160         ORDER BY org_name, dst_name, commodname, unitprofit DESC,
 161                  org_price, dst_price DESC
 162      ";
 163
 164 my $sth= $dbh->prepare($stmt);
 165 $sth->execute(@query_params);
 166 my @flows;
 167
 168 my @cols= ({ NoSort => 1 });
 169
 170 my $addcols= sub {
 171         my $base= shift @_;
 172         foreach my $name (@_) {
 173                 my $col= { Name => $name, %$base };
 174                 $col->{Numeric}=1 if !$col->{Text};
 175                 push @cols, $col;
 176         }
 177 };
 178
 179 if ($qa->{ShowStalls}) {
 180         $addcols->({ Text => 1 }, qw(
 181                 org_name org_stallname
 182                 dst_name dst_stallname
 183         ));
 184 } else {
 185         $addcols->({Text => 1 }, qw(
 186                 org_name dst_name
 187         ));
 188 }
 189 $addcols->({ Text => 1 }, qw(commodname));
 190 $addcols->({ DoReverse => 1 },
 191         qw(     org_price org_qty dst_price dst_qty
 192                 Margin unitprofit MaxQty
 193                 MaxCapital MaxProfit
 194         ));
 195
 196 </%perl>
 197
 198 % if ($qa->{'debug'}) {
 199 <pre>
 200 <% $stmt |h %>
 201 <% join(' | ',@query_params) |h %>
 202 </pre>
 203 % }
 204
 205 <& dumptable:start, qa => $qa, sth => $sth &>
 206 % {
 207 %   my $f;
 208 %   while ($f= $sth->fetchrow_hashref()) {
 209 <%perl>
 210
 211         $f->{Ix}= @flows;
 212         $f->{Var}= "f$f->{Ix}";
 213
 214         $f->{MaxQty}= $f->{'org_qty'} < $f->{'dst_qty'}
 215                 ? $f->{'org_qty'} : $f->{'dst_qty'};
 216         $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
 217         $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
 218
 219         $f->{Margin}= sprintf "%3.1f%%",
 220                 $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
 221
 222         $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
 223                 if !$qa->{ShowStalls};
 224
 225         $f->{ExpectedUnitProfit}=
 226                 $f->{'dst_price'} * (1.0 - $loss_per_league) ** $f->{'dist'}
 227                 - $f->{'src_price'};
 228
 229         my @uid= $f->{commodid};
 230         foreach my $od (qw(org dst)) {
 231                 push @uid,
 232                         $f->{"${od}_id"},
 233                         $f->{"${od}_price"};
 234                 push @uid,
 235                         $f->{"${od}_stallid"}
 236                                 if $qa->{ShowStalls};
 237         }
 238         $f->{UidLong}= join '_', @uid;
 239
 240         my $base= 31;
 241         my $cmpu= '';
 242         map {
 243                 my $uue= $_;
 244                 my $first= $base;
 245                 do {
 246                         my $this= $uue % $base;
 247 print STDERR "uue=$uue this=$this ";
 248                         $uue -= $this;
 249                         $uue /= $base;
 250                         $this += $first;
 251                         $first= 0;
 252                         $cmpu .= chr($this + ($this < 26 ? ord('a') :
 253                                               $this < 52 ? ord('A')-26
 254                                                          : ord('0')-52));
 255 print STDERR " uue=$uue this=$this cmpu=$cmpu\n";
 256 die "$cmpu $uue ?" if length $cmpu > 20;
 257                 } while ($uue);
 258                 $cmpu;
 259         } @uid;
 260         $f->{UidShort}= $cmpu;
 261
 262         if ($qa->{'debug'}) {
 263                 my @outuid;
 264                 $_= $f->{UidShort};
 265                 my $mul;
 266                 while (m/./) {
 267                         my $v= m/^[a-z]/ ? ord($&)-ord('a') :
 268                                m/^[A-Z]/ ? ord($&)-ord('A')+26 :
 269                                m/^[0-9]/ ? ord($&)-ord('0')+52 :
 270                                die "$_ ?";
 271                         if ($v >= $base) {
 272                                 push @outuid, 0;
 273                                 $v -= $base;
 274                                 $mul= 1;
 275 #print STDERR "(next)\n";
 276                         }
 277                         die "$f->{UidShort} $_ ?" unless defined $mul;
 278                         $outuid[$#outuid] += $v * $mul;
 279
 280 #print STDERR "$f->{UidShort}  $_  $&  v=$v  mul=$mul  ord()=".ord($&).
 281 #                       "[vs.".ord('a').",".ord('A').",".ord('0')."]".
 282 #                       "  outuid=@outuid\n";
 283
 284                         $mul *= $base;
 285                         s/^.//;
 286                 }
 287                 my $recons_long= join '_', @outuid;
 288                 $f->{UidLong} eq $recons_long or
 289                         die "$f->{UidLong} = $f->{UidShort} = $recons_long ?";
 290         }
 291
 292         if (defined $qa->{"R$f->{UidShort}"} &&
 293             !defined $qa->{"T$f->{UidShort}"}) {
 294                 $f->{Suppress}= 1;
 295         }
 296
 297         push @flows, $f;
 298
 299 </%perl>
 300 <& dumptable:row, qa => $qa, sth => $sth, row => $f &>
 301 %   }
 302 <& dumptable:end, qa => $qa &>
 303 % }
 304
 305 % my $optimise= $specific && !$confusing && @islandids>1;
 306 % if (!$optimise) {
 307
 308 <p>
 309 % if (@islandids<=1) {
 310 Route is trivial.
 311 % }
 312 % if (!$specific) {
 313 Route contains archipelago(es), not just specific islands.
 314 % }
 315 % if ($confusing) {
 316 Route is complex - it visits the same island several times
 317 and isn't a simple loop.
 318 % }
 319 Therefore, optimal trade pattern not calculated.
 320
 321 % } else { # ========== OPTMISATION ==========
 322 <%perl>
 323
 324 my $cplex= "
 325 Maximize
 326
 327   totalprofit:
 328                   ".(join " +
 329                   ", map {
 330                         sprintf "%.20f %s", $_->{ExpectedUnitProfit}, $_->{Var}
 331                         } @flows)."
 332
 333 Subject To
 334 ";
 335
 336 my %avail_csts;
 337 foreach my $flow (@flows) {
 338         if ($flow->{Suppress}) {
 339                 $cplex .= "
 340    $flow->{Var} = 0
 341 ";
 342                 next;
 343         }
 344         foreach my $od (qw(org dst)) {
 345                 my $cstname= join '_', (
 346                         'avail',
 347                         $flow->{'commodid'},
 348                         $od,
 349                         $flow->{"${od}_id"},
 350                         $flow->{"${od}_price"},
 351                         $flow->{"${od}_stallid"},
 352                 );
 353
 354                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
 355                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
 356         }
 357 }
 358 foreach my $cstname (sort keys %avail_csts) {
 359         my $c= $avail_csts{$cstname};
 360         $cplex .= "
 361    ".   sprintf("%-30s","$cstname:")." ".
 362         join("+", @{ $c->{Flows} }).
 363         " <= ".$c->{Qty}."\n";
 364 }
 365
 366 $cplex.= "
 367 Bounds
 368         ".(join "
 369         ", map { "$_->{Var} >= 0" } @flows)."
 370
 371 End
 372 ";
 373
 374 if ($qa->{'debug'}) {
 375 </%perl>
 376 <pre>
 377 <% $cplex |h %>
 378 </pre>
 379 <%perl>
 380 }
 381
 382 {
 383         my $input= pipethrough_prep();
 384         print $input $cplex or die $!;
 385         my $output= pipethrough_run_along($input, undef, 'glpsol',
 386                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
 387         print "<pre>\n" if $qa->{'debug'};
 388         my $found_section= 0;
 389         while (<$output>) {
 390                 print encode_entities($_) if $qa->{'debug'};
 391                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
 392                         die if $found_section>0;
 393                         $found_section= 1;
 394                         next;
 395                 }
 396                 next unless $found_section==1;
 397                 next if m/^[- ]+$/;
 398                 if (!/\S/) {
 399                         $found_section= 2;
 400                         next;
 401                 }
 402                 my ($ix, $qty) =
 403                         m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
 404                 my $flow= $flows[$ix] or die;
 405                 $flow->{OptQty}= $qty;
 406                 $flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
 407                 $flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
 408         }
 409         print "</pre>\n" if $qa->{'debug'};
 410         pipethrough_run_finish($output, 'glpsol');
 411         die unless $found_section;
 412 };
 413
 414 $addcols->({ DoReverse => 1 }, qw(
 415                 OptQty
 416         ));
 417 $addcols->({ Total => 0, DoReverse => 1 }, qw(
 418                 OptCapital OptProfit
 419         ));
 420
 421 </%perl>
 422
 423 % } # ========== OPTIMISATION ==========
 424
 425 % my %ts_sortkeys;
 426 % {
 427 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
 428 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
 429 <table id="trades" rules=groups>
 430 <colgroup span=1>
 431 <colgroup span=2>
 432 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
 433 <colgroup span=1>
 434 <colgroup span=2>
 435 <colgroup span=2>
 436 <colgroup span=2>
 437 <colgroup span=3>
 438 %       if ($optimise) {
 439 <colgroup span=3>
 440 %       }
 441 <tr class="spong">
 442 <th>
 443 <th<% $cdspan %>>Collect
 444 <th<% $cdspan %>>Deliver
 445 <th>
 446 <th colspan=2>Collect
 447 <th colspan=2>Deliver
 448 <th colspan=2>Profit
 449 <th colspan=3>Max
 450 %       if ($optimise) {
 451 <th colspan=3>Planned
 452 %       }
 453
 454 <tr>
 455 <th>
 456 <th>Island <% $cdstall %>
 457 <th>Island <% $cdstall %>
 458 <th>Commodity
 459 <th>Price
 460 <th>Qty
 461 <th>Price
 462 <th>Qty
 463 <th>Margin
 464 <th>Unit
 465 <th>Qty
 466 <th>Capital
 467 <th>Profit
 468 %       if ($optimise) {
 469 <th>Qty
 470 <th>Capital
 471 <th>Profit
 472 %       }
 473 % }
 474
 475 <tr id="trades_sort">
 476 % foreach my $col (@cols) {
 477 <th>
 478 % }
 479
 480 % foreach my $flowix (0..$#flows) {
 481 %       my $flow= $flows[$flowix];
 482 %       my $rowid= "id_row_$flow->{UidShort}";
 483 <tr id="<% $rowid %>" class="datarow<% $flowix & 1 %>">
 484 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
 485     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
 486        <% $flow->{Suppress} ? '' : 'checked' %> >
 487 %       foreach my $ci (1..$#cols) {
 488 %               my $col= $cols[$ci];
 489 %               my $v= $flow->{$col->{Name}};
 490 %               $col->{Total} += $v if defined $col->{Total};
 491 %               $v='' if !$col->{Text} && !$v;
 492 %               $ts_sortkeys{$ci}{$rowid}= $v;
 493 <td <% $col->{Text} ? '' : 'align=right' %>><% $v |h %>
 494 %       }
 495 % }
 496 <tr id="trades_total">
 497 <th>
 498 <th colspan=2>Total
 499 % foreach my $ci (3..$#cols) {
 500 %       my $col= $cols[$ci];
 501 <td align=right>
 502 %       if (defined $col->{Total}) {
 503 <% $col->{Total} |h %>
 504 %       }
 505 % }
 506 </table>
 507
 508 <& tabsort, cols => \@cols, table => 'trades', rowclass => 'datarow',
 509         throw => 'trades_sort', tbrow => 'trades_total' &>
 510 <&| script &>
 511   ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
 512   function all_onload() {
 513     ts_onload__trades();
 514   }
 515   window.onload= all_onload;
 516 </&script>
 517
 518 <input type=submit name=update value="Update">
 519
 520 % if ($optimise) { # ========== TRADING PLAN ==========
 521 %
 522 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
 523 %                               WHERE islandid = ?');
 524 %
 525 <h1>Voyage trading plan</h1>
 526 <table>
 527 % foreach my $i (0..$#islandids) {
 528 <tr><td colspan=4><strong>
 529 %       $iquery->execute($islandids[$i]);
 530 %       my ($islandname) = $iquery->fetchrow_array();
 531 %       if (!$i) {
 532 Start at <% $islandname |h %>
 533 %       } else {
 534 Sail to <% $islandname |h %>
 535 %       }
 536 </strong>
 537 %    foreach my $od (qw(dst org)) {
 538 %       my $sign= $od eq 'dst' ? -1 : +1;
 539 %       my %todo;
 540 %       foreach my $f (@flows) {
 541 %               next if $f->{Suppress};
 542 %               next unless $f->{"${od}_id"} == $islandids[$i];
 543 %               next unless $f->{OptQty};
 544 %               my $price= $f->{"${od}_price"};
 545 %               my $stallname= $f->{"${od}_stallname"};
 546 %               my $todo= \$todo{ $f->{'commodname'},
 547 %                                 (sprintf "%07d", $price),
 548 %                                 $stallname };
 549 %               $$todo= { } unless $$todo;
 550 %               $$todo->{'commodname'}= $f->{'commodname'};
 551 %               $$todo->{'stallname'}= $stallname;
 552 %               $$todo->{Price} += $price;
 553 %               $$todo->{Qty} += $f->{OptQty};
 554 %               $$todo->{Total} = $$todo->{Price} * $$todo->{Qty};
 555 %               $$todo->{Timestamp} = $f->{"${od}_timestamp"};
 556 %       }
 557 %       my $total= 0;
 558 %       my $dline= 0;
 559 %       foreach my $tkey (sort keys %todo) {
 560 %               my $t= $todo{$tkey};
 561 %               $total += $t->{Total};
 562 <tr class="datarow<% $dline %>"><td>
 563 %               if ($od eq 'org') {
 564 Collect
 565 %               } else {
 566 Deliver
 567 %               }
 568 <td><% $t->{'commodname'} |h %>
 569 <td align=right><% $t->{Price} |h %> each
 570 %               if ($qa->{ShowStalls}) {
 571 <td><% $t->{'stallname'} |h %>
 572 %               }
 573 <td align=right><% $t->{Qty} |h %> unit(s)
 574 <td align=right><% $t->{Total} |h %> total
 575 %               $dline ^= 1;
 576 %       }
 577 %       if (%todo) {
 578 <tr><td>
 579 <td colspan=<% 2+!!$qa->{ShowStalls} %>>
 580 <% (values %todo)[0]->{Timestamp} %>
 581 <td align=right>
 582 %               if ($od eq 'org') {
 583 Outlay
 584 %               } else {
 585 Proceeds
 586 %               }
 587 <td align=right><% $total |h %> total
 588 %       }
 589 %    }
 590 % }
 591 </table>
 592 %
 593 % } # ========== TRADING PLAN ==========
 594
 595 <%init>
 596 use CommodsWeb;
 597 use Commods;
 598 </%init>