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