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:39 <ceb> Also, maybe colour to highlight the suggested trades?
  39
  40 16:46 <ceb> Also trading plan not functional but I guess you know that :-)
  41
  42 use POST for update.  Hrrm.
  43
  44 LATER OR NOT AT ALL
  45
  46 adjustable potential cost of losses (rather than fixed 1e-BIG per league)
  47
  48 max volume/mass
  49
  50 16:38 <ceb> I don't know how hard this is, but can you show only the suggested
  51             trades to start ith and have a button to show all?
  52 ========== TODO ==========
  53
  54 </%doc>
  55 <%args>
  56 $dbh
  57 @islandids
  58 @archipelagoes
  59 $qa
  60 </%args>
  61 <%perl>
  62
  63 my $loss_per_league= 1e-7;
  64
  65 my @flow_conds;
  66 my @query_params;
  67
  68 my $sd_condition= sub {
  69         my ($bs, $ix) = @_;
  70         my $islandid= $islandids[$ix];
  71         if (defined $islandid) {
  72                 return "${bs}.islandid = $islandid";
  73         } else {
  74                 push @query_params, $archipelagoes[$ix];
  75                 return "${bs}_islands.archipelago = ?";
  76         }
  77 };
  78
  79 my %islandpair;
  80 # $islandpair{$a,$b}= [ $start_island_ix, $end_island_ix ]
  81
  82 my $specific= !grep { !defined $_ } @islandids;
  83 my $confusing= 0;
  84
  85 foreach my $src_i (0..$#islandids) {
  86         my $src_isle= $islandids[$src_i];
  87         my $src_cond= $sd_condition->('sell',$src_i);
  88         my @dst_conds;
  89         foreach my $dst_i ($src_i..$#islandids) {
  90                 my $dst_isle= $islandids[$dst_i];
  91                 my $dst_cond= $sd_condition->('buy',$dst_i);
  92                 if ($dst_i==$src_i and !defined $src_isle) {
  93                         # we always want arbitrage, but mentioning an arch
  94                         # once shouldn't produce intra-arch trades
  95                         $dst_cond=
  96                                 "($dst_cond AND sell.islandid = buy.islandid)";
  97                 }
  98                 push @dst_conds, $dst_cond;
  99
 100                 if ($specific && !$confusing &&
 101                     # With a circular route, do not carry goods round the loop
 102                     !($src_i==0 && $dst_i==$#islandids &&
 103                       $src_isle == $islandids[$dst_i])) {
 104                         if ($islandpair{$src_isle,$dst_isle}) {
 105                                 $confusing= 1;
 106                         } else {
 107                                 $islandpair{$src_isle,$dst_isle}=
 108                                         [ $src_i, $dst_i ];
 109                         }
 110                 }
 111         }
 112         push @flow_conds, "$src_cond AND (
 113                         ".join("
 114                      OR ",@dst_conds)."
 115                 )";
 116 }
 117
 118 my $stmt= "
 119         SELECT  sell_islands.islandname                         org_name,
 120                 sell_islands.islandid                           org_id,
 121                 sell.price                                      org_price,
 122                 buy_islands.islandname                          dst_name,
 123                 buy_islands.islandid                            dst_id,
 124                 buy.price                                       dst_price,
 125 ".($qa->{ShowStalls} ? "
 126                 sell.stallid                                    org_stallid,
 127                 sell_stalls.stallname                           org_stallname,
 128                 sell.qty                                        org_qty,
 129                 buy.stallid                                     dst_stallid,
 130                 buy_stalls.stallname                            dst_stallname,
 131                 buy.qty                                         dst_qty,
 132 " : "
 133                 sum(sell.qty)                                   org_qty,
 134                 sum(buy.qty)                                    dst_qty,
 135 ")."
 136                 commods.commodname                              commodname,
 137                 commods.commodid                                commodid,
 138                 commods.unitmass                                unitmass,
 139                 commods.unitvolume                              unitvolume,
 140                 dist                                            dist,
 141                 buy.price - sell.price                          unitprofit
 142         FROM commods
 143         JOIN buy  ON commods.commodid = buy.commodid
 144         JOIN sell ON commods.commodid = sell.commodid
 145         JOIN islands AS sell_islands ON sell.islandid = sell_islands.islandid
 146         JOIN islands AS buy_islands  ON buy.islandid  = buy_islands.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>
 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 $flow (@flows) {
 481 %       my $rowid= "id_row_$flow->{UidShort}";
 482 <tr id="<% $rowid %>">
 483 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
 484     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
 485        <% $flow->{Suppress} ? '' : 'checked' %> >
 486 %       foreach my $ci (1..$#cols) {
 487 %               my $col= $cols[$ci];
 488 %               my $v= $flow->{$col->{Name}};
 489 %               $col->{Total} += $v if defined $col->{Total};
 490 %               $v='' if !$col->{Text} && !$v;
 491 %               $ts_sortkeys{$ci}{$rowid}= $v;
 492 <td <% $col->{Text} ? '' : 'align=right' %>><% $v |h %>
 493 %       }
 494 % }
 495 <tr id="trades_total">
 496 <th>
 497 <th colspan=2>Total
 498 % foreach my $ci (3..$#cols) {
 499 %       my $col= $cols[$ci];
 500 <td align=right>
 501 %       if (defined $col->{Total}) {
 502 <% $col->{Total} |h %>
 503 %       }
 504 % }
 505 </table>
 506
 507 <& tabsort, cols => \@cols, table => 'trades',
 508         throw => 'trades_sort', tbrow => 'trades_total' &>
 509 <&| script &>
 510   ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
 511   function all_onload() {
 512     ts_onload__trades();
 513   }
 514   window.onload= all_onload;
 515 </&script>
 516
 517 <input type=submit name=update value="Update">
 518
 519 % if ($optimise) { # ========== TRADING PLAN ==========
 520 %
 521 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
 522 %                               WHERE islandid = ?');
 523 %
 524 <h1>Voyage trading plan</h1>
 525 <table>
 526 % foreach my $i (0..$#islandids) {
 527 <tr><td colspan=4><strong>
 528 %       $iquery->execute($islandids[$i]);
 529 %       my ($islandname) = $iquery->fetchrow_array();
 530 %       if (!$i) {
 531 Start at <% $islandname |h %>
 532 %       } else {
 533 Sail to <% $islandname |h %>
 534 %       }
 535 </strong>
 536 %    foreach my $od (qw(dst org)) {
 537 %       my $sign= $od eq 'dst' ? -1 : +1;
 538 %       foreach my $f (sort {
 539 %                       $a->{'commodname'} cmp $b->{'commodname'}
 540 %               or $sign * ($a->{"${od}_price"} <=> $b->{"${od}_price"})
 541 %               or      $a->{"${od}_stallname"} cmp $b->{"${od}_stallname"}
 542 %               } @flows) {
 543 %               next if $f->{Suppress};
 544 %               next unless $f->{"${od}_id"} == $islandids[$i];
 545 %               next unless $f->{OptQty};
 546 <tr><td>Buy or sell flow
 547 %       }
 548 %    }
 549 % }
 550 </table>
 551 %
 552 % } # ========== TRADING PLAN ==========
 553
 554 <%init>
 555 use CommodsWeb;
 556 use Commods;
 557 </%init>