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:37 <ceb> if tehre are 2 rows which take the same object and sell it for the
  39             same profit at two other islands, choose the shortest route as the
  40             preferred one
  41 16:37 <ceb> coconut buy 10 sell 16, at luthien or jorvik, in that example
  42 16:38 <ceb> Do you see what I mean?
  43
  44 16:38 <ceb> I don't know how hard this is, but can you show only the suggested
  45             trades to start ith and have a button to show all?
  46 16:39 <ceb> Also, maybe colour to highlight the suggested trades?
  47
  48 16:40 <ceb> can it give a total investment/profit for the suggested trades?
  49 16:40 <ceb> columns should be sortable with the small arrows as before
  50
  51 16:46 <Diziet> Oh the unticking has become broken.
  52
  53 16:51 <ceb> YPP interfaces have price then qty. You have qty then price. This
  54             is confusing!
  55 16:51 <ceb> the max column ordering is OK
  56 16:51 <ceb> (alo profit and suggested are OK)
  57 16:52 <Diziet> Err, you want qty on the left in those two but on the right in
  58                collect and deliver ?
  59 16:53 <ceb> Yes (price and capital are not the same thing)
  60 16:53 <Diziet> OK
  61 16:53 <ceb> for max the order in which you want to think about it is 'I need to
  62             buy ten of them and that will cost me $total price)
  63 16:54 <ceb> s/)/'/
  64
  65 16:46 <ceb> Also trading plan not functional but I guess you know that :-)
  66
  67 Also:
  68 - potential cost of losses
  69 - max volume/mass
  70 - use POST for update.  Hrrm.
  71
  72 ========== TODO ==========
  73
  74 </%doc>
  75 <%args>
  76 $dbh
  77 @islandids
  78 @archipelagoes
  79 $qa
  80 </%args>
  81 <%perl>
  82
  83 my @flow_conds;
  84 my @query_params;
  85
  86 my $sd_condition= sub {
  87         my ($bs, $ix) = @_;
  88         my $islandid= $islandids[$ix];
  89         if (defined $islandid) {
  90                 return "${bs}.islandid = $islandid";
  91         } else {
  92                 push @query_params, $archipelagoes[$ix];
  93                 return "${bs}_islands.archipelago = ?";
  94         }
  95 };
  96
  97 my %islandpair;
  98 # $islandpair{$a,$b}= [ $start_island_ix, $end_island_ix ]
  99
 100 my $specific= !grep { !defined $_ } @islandids;
 101 my $confusing= 0;
 102
 103 foreach my $src_i (0..$#islandids) {
 104         my $src_isle= $islandids[$src_i];
 105         my $src_cond= $sd_condition->('sell',$src_i);
 106         my @dst_conds;
 107         foreach my $dst_i ($src_i..$#islandids) {
 108                 my $dst_isle= $islandids[$dst_i];
 109                 my $dst_cond= $sd_condition->('buy',$dst_i);
 110                 if ($dst_i==$src_i and !defined $src_isle) {
 111                         # we always want arbitrage, but mentioning an arch
 112                         # once shouldn't produce intra-arch trades
 113                         $dst_cond=
 114                                 "($dst_cond AND sell.islandid = buy.islandid)";
 115                 }
 116                 push @dst_conds, $dst_cond;
 117
 118                 if ($specific && !$confusing &&
 119                     # With a circular route, do not carry goods round the loop
 120                     !($src_i==0 && $dst_i==$#islandids &&
 121                       $src_isle == $islandids[$dst_i])) {
 122                         if ($islandpair{$src_isle,$dst_isle}) {
 123                                 $confusing= 1;
 124                         } else {
 125                                 $islandpair{$src_isle,$dst_isle}=
 126                                         [ $src_i, $dst_i ];
 127                         }
 128                 }
 129         }
 130         push @flow_conds, "$src_cond AND (
 131                         ".join("
 132                      OR ",@dst_conds)."
 133                 )";
 134 }
 135
 136 my $stmt= "
 137         SELECT  sell_islands.islandname                         org_name,
 138                 sell_islands.islandid                           org_id,
 139                 sell.price                                      org_price,
 140                 buy_islands.islandname                          dst_name,
 141                 buy_islands.islandid                            dst_id,
 142                 buy.price                                       dst_price,
 143 ".($qa->{ShowStalls} ? "
 144                 sell.stallid                                    org_stallid,
 145                 sell_stalls.stallname                           org_stallname,
 146                 sell.qty                                        org_qty,
 147                 buy.stallid                                     dst_stallid,
 148                 buy_stalls.stallname                            dst_stallname,
 149                 buy.qty                                         dst_qty,
 150 " : "
 151                 sum(sell.qty)                                   org_qty,
 152                 sum(buy.qty)                                    dst_qty,
 153 ")."
 154                 commods.commodname                              commodname,
 155                 commods.commodid                                commodid,
 156                 commods.unitmass                                unitmass,
 157                 commods.unitvolume                              unitvolume,
 158                 buy.price - sell.price                          unitprofit
 159         FROM commods
 160         JOIN buy  on commods.commodid = buy.commodid
 161         JOIN sell on commods.commodid = sell.commodid
 162         JOIN islands as sell_islands on sell.islandid = sell_islands.islandid
 163         JOIN islands as buy_islands  on buy.islandid  = buy_islands.islandid
 164 ".($qa->{ShowStalls} ? "
 165         JOIN stalls  as sell_stalls  on sell.stallid  = sell_stalls.stallid
 166         JOIN stalls  as buy_stalls   on buy.stallid   = buy_stalls.stallid
 167 " : "")."
 168         WHERE   (
 169                 ".join("
 170            OR   ", @flow_conds)."
 171         )
 172           AND   buy.price > sell.price
 173 ".($qa->{ShowStalls} ? "" : "
 174         GROUP BY commods.commodid, org_id, org_price, dst_id, dst_price
 175 ")."
 176         ORDER BY org_name, dst_name, commodname, unitprofit DESC,
 177                  org_price, dst_price DESC
 178      ";
 179
 180 my $sth= $dbh->prepare($stmt);
 181 $sth->execute(@query_params);
 182 my @flows;
 183
 184 my @cols;
 185
 186 my $addcols= sub {
 187         my $base= shift @_;
 188         foreach my $name (@_) {
 189                 push @cols, { Name => $name, %$base };
 190         }
 191 };
 192
 193 if ($qa->{ShowStalls}) {
 194         $addcols->({ Text => 1 }, qw(
 195                 org_name org_stallname
 196                 dst_name dst_stallname
 197         ));
 198 } else {
 199         $addcols->({Text => 1 }, qw(
 200                 org_name dst_name
 201         ));
 202 }
 203 $addcols->({ Text => 1 }, qw(commodname));
 204 $addcols->({},
 205         qw(     org_qty org_price dst_qty dst_price
 206                 Margin unitprofit MaxQty
 207                 MaxCapital MaxProfit
 208         ));
 209
 210 </%perl>
 211
 212 % if ($qa->{'debug'}) {
 213 <pre>
 214 <% $stmt |h %>
 215 <% join(' | ',@query_params) |h %>
 216 </pre>
 217 % }
 218
 219 <& dumptable:start, qa => $qa, sth => $sth &>
 220 % {
 221 %   my $f;
 222 %   while ($f= $sth->fetchrow_hashref()) {
 223 <%perl>
 224
 225         $f->{Ix}= @flows;
 226         $f->{Var}= "f$f->{Ix}";
 227
 228         $f->{MaxQty}= $f->{'org_qty'} < $f->{'dst_qty'}
 229                 ? $f->{'org_qty'} : $f->{'dst_qty'};
 230         $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
 231         $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
 232
 233         $f->{Margin}= sprintf "%3.1f%%",
 234                 $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
 235
 236         $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
 237                 if !$qa->{ShowStalls};
 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 ($qa->{"R$f->{UidShort}"} && !$qa->{"T$f->{UidShort}"}) {
 303                 $f->{Suppress}= 1;
 304         }
 305
 306         push @flows, $f;
 307
 308 </%perl>
 309 <& dumptable:row, qa => $qa, sth => $sth, row => $f &>
 310 %   }
 311 <& dumptable:end, qa => $qa &>
 312 % }
 313
 314 % my $optimise= $specific && !$confusing && @islandids>1;
 315 % if (!$optimise) {
 316
 317 <p>
 318 % if (@islandids<=1) {
 319 Route is trivial.
 320 % }
 321 % if (!$specific) {
 322 Route contains archipelago(es), not just specific islands.
 323 % }
 324 % if ($confusing) {
 325 Route is complex - it visits the same island several times
 326 and isn't a simple loop.
 327 % }
 328 Therefore, optimal trade pattern not calculated.
 329
 330 % } else { # ========== OPTMISATION ==========
 331 <%perl>
 332
 333 my $cplex= "
 334 Maximize
 335
 336   totalprofit:
 337                   ".(join " +
 338                   ", map { "$_->{unitprofit} $_->{Var}" } @flows)."
 339
 340 Subject To
 341 ";
 342
 343 my %avail_csts;
 344 foreach my $flow (@flows) {
 345         if ($flow->{Suppress}) {
 346                 $cplex .= "
 347    $flow->{Var} = 0
 348 ";
 349                 next;
 350         }
 351         foreach my $od (qw(org dst)) {
 352                 my $cstname= join '_', (
 353                         'avail',
 354                         $flow->{'commodid'},
 355                         $od,
 356                         $flow->{"${od}_id"},
 357                         $flow->{"${od}_price"},
 358                         $flow->{"${od}_stallid"},
 359                 );
 360
 361                 push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
 362                 $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
 363         }
 364 }
 365 foreach my $cstname (sort keys %avail_csts) {
 366         my $c= $avail_csts{$cstname};
 367         $cplex .= "
 368    ".   sprintf("%-30s","$cstname:")." ".
 369         join("+", @{ $c->{Flows} }).
 370         " <= ".$c->{Qty}."\n";
 371 }
 372
 373 $cplex.= "
 374 Bounds
 375         ".(join "
 376         ", map { "$_->{Var} >= 0" } @flows)."
 377
 378 End
 379 ";
 380
 381 if ($qa->{'debug'}) {
 382 </%perl>
 383 <pre>
 384 <% $cplex |h %>
 385 </pre>
 386 <%perl>
 387 }
 388
 389 {
 390         my $input= pipethrough_prep();
 391         print $input $cplex or die $!;
 392         my $output= pipethrough_run_along($input, undef, 'glpsol',
 393                 qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
 394         print "<pre>\n" if $qa->{'debug'};
 395         my $found_section= 0;
 396         while (<$output>) {
 397                 print encode_entities($_) if $qa->{'debug'};
 398                 if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
 399                         die if $found_section>0;
 400                         $found_section= 1;
 401                         next;
 402                 }
 403                 next unless $found_section==1;
 404                 next if m/^[- ]+$/;
 405                 if (!/\S/) {
 406                         $found_section= 2;
 407                         next;
 408                 }
 409                 my ($ix, $qty) =
 410                         m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
 411                 my $flow= $flows[$ix] or die;
 412                 $flow->{OptQty}= $qty;
 413                 $flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
 414                 $flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
 415         }
 416         print "</pre>\n" if $qa->{'debug'};
 417         pipethrough_run_finish($output, 'glpsol');
 418         die unless $found_section;
 419 };
 420
 421 $addcols->({}, qw(
 422                 OptQty
 423         ));
 424 $addcols->({ Total => 0 }, qw(
 425                 OptCapital OptProfit
 426         ));
 427
 428 </%perl>
 429
 430 % } # ========== OPTIMISATION ==========
 431
 432 % {
 433 %       my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
 434 %       my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
 435 <table rules=groups>
 436 <colgroup span=1>
 437 <colgroup span=2>
 438 <% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
 439 <colgroup span=1>
 440 <colgroup span=2>
 441 <colgroup span=2>
 442 <colgroup span=2>
 443 <colgroup span=3>
 444 %       if ($optimise) {
 445 <colgroup span=3>
 446 %       }
 447 <tr>
 448 <th>
 449 <th<% $cdspan %>>Collect
 450 <th<% $cdspan %>>Deliver
 451 <th>
 452 <th colspan=2>Collect
 453 <th colspan=2>Deliver
 454 <th colspan=2>Profit
 455 <th colspan=3>Max
 456 %       if ($optimise) {
 457 <th colspan=3>Suggested
 458 %       }
 459
 460 <tr>
 461 <th>
 462 <th>Island <% $cdstall %>
 463 <th>Island <% $cdstall %>
 464 <th>Commodity
 465 <th>Qty
 466 <th>Price
 467 <th>Qty
 468 <th>Price
 469 <th>Margin
 470 <th>Unit
 471 <th>Qty
 472 <th>Capital
 473 <th>Profit
 474 %       if ($optimise) {
 475 <th>Qty
 476 <th>Capital
 477 <th>Profit
 478 %       }
 479 % }
 480
 481 % foreach my $flow (@flows) {
 482 <tr>
 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 (0..$#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 <td <% $col->{Text} ? '' : 'align=right' %>><% $v |h %>
 492 %       }
 493 % }
 494 <tr>
 495 <th>
 496 <th colspan=2>Total
 497 % foreach my $ci (2..$#cols) {
 498 %       my $col= $cols[$ci];
 499 <td align=right>
 500 %       if (defined $col->{Total}) {
 501 <% $col->{Total} |h %>
 502 %       }
 503 % }
 504 </table>
 505
 506 <input type=submit name=update value="Update">
 507
 508 % if ($optimise) { # ========== TRADING PLAN ==========
 509 %
 510 % my $iquery= $dbh->prepare('SELECT islandname FROM islands
 511 %                               WHERE islandid = ?');
 512 %
 513 <h1>Voyage trading plan</h1>
 514 <table>
 515 % foreach my $i (0..$#islandids) {
 516 <tr><td colspan=4><strong>
 517 %       $iquery->execute($islandids[$i]);
 518 %       my ($islandname) = $iquery->fetchrow_array();
 519 %       if (!$i) {
 520 Start at <% $islandname |h %>
 521 %       } else {
 522 Sail to <% $islandname |h %>
 523 %       }
 524 </strong>
 525 %    foreach my $od (qw(dst org)) {
 526 %       my $sign= $od eq 'dst' ? -1 : +1;
 527 %       foreach my $f (sort {
 528 %                       $a->{'commodname'} cmp $b->{'commodname'}
 529 %               or $sign * ($a->{"${od}_price"} <=> $b->{"${od}_price"})
 530 %               or      $a->{"${od}_stallname"} cmp $b->{"${od}_stallname"}
 531 %               } @flows) {
 532 %               next if $f->{Suppress};
 533 %               next unless $f->{"${od}_id"} == $islandids[$i];
 534 %               next unless $f->{OptQty};
 535 <tr>Buy or sell flow
 536 %       }
 537 %    }
 538 % }
 539 </table>
 540 %
 541 % } # ========== TRADING PLAN ==========
 542
 543 <%init>
 544 use CommodsWeb;
 545 use Commods;
 546 </%init>