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