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:40 <ceb> columns should be sortable with the small arrows as before
  41
  42 16:46 <ceb> Also trading plan not functional but I guess you know that :-)
  43
  44 use POST for update.  Hrrm.
  45
  46 LATER OR NOT AT ALL
  47
  48 adjustable potential cost of losses (rather than fixed 1e-BIG per league)
  49
  50 max volume/mass
  51
  52 16:38 <ceb> I don't know how hard this is, but can you show only the suggested
  53             trades to start ith and have a button to show all?
  54 ========== TODO ==========
  55
  56 </%doc>
  57 <%args>
  58 $dbh
  59 @islandids
  60 @archipelagoes
  61 $qa
  62 </%args>
  63 <%perl>
  64
  65 my $loss_per_league= 1e-7;
  66
  67 my @flow_conds;
  68 my @query_params;
  69
  70 my $sd_condition= sub {
  71         my ($bs, $ix) = @_;
  72         my $islandid= $islandids[$ix];
  73         if (defined $islandid) {
  74                 return "${bs}.islandid = $islandid";
  75         } else {
  76                 push @query_params, $archipelagoes[$ix];
  77                 return "${bs}_islands.archipelago = ?";
  78         }
  79 };
  80
  81 my %islandpair;
  82 # $islandpair{$a,$b}= [ $start_island_ix, $end_island_ix ]
  83
  84 my $specific= !grep { !defined $_ } @islandids;
  85 my $confusing= 0;
  86
  87 foreach my $src_i (0..$#islandids) {
  88         my $src_isle= $islandids[$src_i];
  89         my $src_cond= $sd_condition->('sell',$src_i);
  90         my @dst_conds;
  91         foreach my $dst_i ($src_i..$#islandids) {
  92                 my $dst_isle= $islandids[$dst_i];
  93                 my $dst_cond= $sd_condition->('buy',$dst_i);
  94                 if ($dst_i==$src_i and !defined $src_isle) {
  95                         # we always want arbitrage, but mentioning an arch
  96                         # once shouldn't produce intra-arch trades
  97                         $dst_cond=
  98                                 "($dst_cond AND sell.islandid = buy.islandid)";
  99                 }
 100                 push @dst_conds, $dst_cond;
 101
 102                 if ($specific && !$confusing &&
 103                     # With a circular route, do not carry goods round the loop
 104                     !($src_i==0 && $dst_i==$#islandids &&
 105                       $src_isle == $islandids[$dst_i])) {
 106                         if ($islandpair{$src_isle,$dst_isle}) {
 107                                 $confusing= 1;
 108                         } else {
 109                                 $islandpair{$src_isle,$dst_isle}=
 110                                         [ $src_i, $dst_i ];
 111                         }
 112                 }
 113         }
 114         push @flow_conds, "$src_cond AND (
 115                         ".join("
 116                      OR ",@dst_conds)."
 117                 )";
 118 }
 119
 120 my $stmt= "
 121         SELECT  sell_islands.islandname                         org_name,
 122                 sell_islands.islandid                           org_id,
 123                 sell.price                                      org_price,
 124                 buy_islands.islandname                          dst_name,
 125                 buy_islands.islandid                            dst_id,
 126                 buy.price                                       dst_price,
 127 ".($qa->{ShowStalls} ? "
 128                 sell.stallid                                    org_stallid,
 129                 sell_stalls.stallname                           org_stallname,
 130                 sell.qty                                        org_qty,
 131                 buy.stallid                                     dst_stallid,
 132                 buy_stalls.stallname                            dst_stallname,
 133                 buy.qty                                         dst_qty,
 134 " : "
 135                 sum(sell.qty)                                   org_qty,
 136                 sum(buy.qty)                                    dst_qty,
 137 ")."
 138                 commods.commodname                              commodname,
 139                 commods.commodid                                commodid,
 140                 commods.unitmass                                unitmass,
 141                 commods.unitvolume                              unitvolume,
 142                 dist                                            dist,
 143                 buy.price - sell.price                          unitprofit
 144         FROM commods
 145         JOIN buy  on commods.commodid = buy.commodid
 146         JOIN sell on commods.commodid = sell.commodid
 147         JOIN islands as sell_islands on sell.islandid = sell_islands.islandid
 148         JOIN islands as buy_islands  on buy.islandid  = buy_islands.islandid
 149 ".($qa->{ShowStalls} ? "
 150         JOIN stalls  as sell_stalls  on sell.stallid  = sell_stalls.stallid
 151         JOIN stalls  as buy_stalls   on buy.stallid   = buy_stalls.stallid
 152 " : "")."
 153         JOIN dists on aiid = sell.islandid AND biid = buy.islandid
 154         WHERE   (
 155                 ".join("
 156            OR   ", @flow_conds)."
 157         )
 158           AND   buy.price > sell.price
 159 ".($qa->{ShowStalls} ? "" : "
 160         GROUP BY commods.commodid, org_id, org_price, dst_id, dst_price
 161 ")."
 162         ORDER BY org_name, dst_name, commodname, unitprofit DESC,
 163                  org_price, dst_price DESC
 164      ";
 165
 166 my $sth= $dbh->prepare($stmt);
 167 $sth->execute(@query_params);
 168 my @flows;
 169
 170 my @cols;
 171
 172 my $addcols= sub {
 173         my $base= shift @_;
 174         foreach my $name (@_) {
 175                 push @cols, { Name => $name, %$base };
 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->({},
 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->({}, qw(
 415                 OptQty
 416         ));
 417 $addcols->({ Total => 0 }, qw(
 418                 OptCapital OptProfit
 419         ));
 420
 421 </%perl>
 422
 423 % } # ========== OPTIMISATION ==========
 424
 425 % {
 426 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
 427 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
 428 <table rules=groups>
 429 <colgroup span=1>
 430 <colgroup span=2>
 431 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
 432 <colgroup span=1>
 433 <colgroup span=2>
 434 <colgroup span=2>
 435 <colgroup span=2>
 436 <colgroup span=3>
 437 %       if ($optimise) {
 438 <colgroup span=3>
 439 %       }
 440 <tr>
 441 <th>
 442 <th<% $cdspan %>>Collect
 443 <th<% $cdspan %>>Deliver
 444 <th>
 445 <th colspan=2>Collect
 446 <th colspan=2>Deliver
 447 <th colspan=2>Profit
 448 <th colspan=3>Max
 449 %       if ($optimise) {
 450 <th colspan=3>Planned
 451 %       }
 452
 453 <tr>
 454 <th>
 455 <th>Island <% $cdstall %>
 456 <th>Island <% $cdstall %>
 457 <th>Commodity
 458 <th>Price
 459 <th>Qty
 460 <th>Price
 461 <th>Qty
 462 <th>Margin
 463 <th>Unit
 464 <th>Qty
 465 <th>Capital
 466 <th>Profit
 467 %       if ($optimise) {
 468 <th>Qty
 469 <th>Capital
 470 <th>Profit
 471 %       }
 472 % }
 473
 474 % foreach my $flow (@flows) {
 475 <tr>
 476 <td><input type=hidden   name=R<% $flow->{UidShort} %> value="">
 477     <input type=checkbox name=T<% $flow->{UidShort} %> value=""
 478        <% $flow->{Suppress} ? '' : 'checked' %> >
 479 %       foreach my $ci (0..$#cols) {
 480 %               my $col= $cols[$ci];
 481 %               my $v= $flow->{$col->{Name}};
 482 %               $col->{Total} += $v if defined $col->{Total};
 483 %               $v='' if !$col->{Text} && !$v;
 484 <td <% $col->{Text} ? '' : 'align=right' %>><% $v |h %>
 485 %       }
 486 % }
 487 <tr>
 488 <th>
 489 <th colspan=2>Total
 490 % foreach my $ci (2..$#cols) {
 491 %       my $col= $cols[$ci];
 492 <td align=right>
 493 %       if (defined $col->{Total}) {
 494 <% $col->{Total} |h %>
 495 %       }
 496 % }
 497 </table>
 498
 499 <input type=submit name=update value="Update">
 500
 501 % if ($optimise) { # ========== TRADING PLAN ==========
 502 %
 503 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
 504 %                               WHERE islandid = ?');
 505 %
 506 <h1>Voyage trading plan</h1>
 507 <table>
 508 % foreach my $i (0..$#islandids) {
 509 <tr><td colspan=4><strong>
 510 %       $iquery->execute($islandids[$i]);
 511 %       my ($islandname) = $iquery->fetchrow_array();
 512 %       if (!$i) {
 513 Start at <% $islandname |h %>
 514 %       } else {
 515 Sail to <% $islandname |h %>
 516 %       }
 517 </strong>
 518 %    foreach my $od (qw(dst org)) {
 519 %       my $sign= $od eq 'dst' ? -1 : +1;
 520 %       foreach my $f (sort {
 521 %                       $a->{'commodname'} cmp $b->{'commodname'}
 522 %               or $sign * ($a->{"${od}_price"} <=> $b->{"${od}_price"})
 523 %               or      $a->{"${od}_stallname"} cmp $b->{"${od}_stallname"}
 524 %               } @flows) {
 525 %               next if $f->{Suppress};
 526 %               next unless $f->{"${od}_id"} == $islandids[$i];
 527 %               next unless $f->{OptQty};
 528 <tr>Buy or sell flow
 529 %       }
 530 %    }
 531 % }
 532 </table>
 533 %
 534 % } # ========== TRADING PLAN ==========
 535
 536 <%init>
 537 use CommodsWeb;
 538 use Commods;
 539 </%init>