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