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