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