yarrg/web/query_routesearch

   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 generates the core of the `routesearch' query.
  33
  34
  35 </%doc>
  36 <%args>
  37 $quri
  38 $dbh
  39 $baseqf
  40 $queryqf
  41 $islandstring => '';
  42 $capacitystring => '';
  43 $lossperleague => '';
  44 $capitalstring => '';
  45 $minprofitstring => '';
  46 $distance => '';
  47 $prselector
  48 $someresults
  49 $emsgokorprint
  50 $allargs
  51 </%args>
  52
  53 <%perl>
  54 use BSD::Resource;
  55
  56 my $emsg;
  57 my @warningfs;
  58 my @islandids;
  59
  60 my $destspec;
  61
  62 my @maxmaxdist= qw(35 35 60);
  63 my $maxcpu=90;
  64 my $concur_lim=5;
  65
  66 my $qa= \%ARGS;
  67 my $routeparams= { EmsgRef => \$emsg, SayRequiredCapacity => 1 };
  68 my $maxdist;
  69 my $maxcountea=15;
  70
  71 </%perl>
  72
  73 <div class="query">
  74 <h1>Find most profitable routes and trades</h1>
  75
  76 % my $searchtype= $ARGS{RouteSearchType};
  77 % my $searchtype_show;
  78 %
  79 % if ($qa->{Dropdowns}) {
  80 This feature is not available from the "drop down menus" interface.
  81 % } else {
  82
  83 % $prselector->('RouteSearchType');
  84
  85 <form action="<% $quri->() |h %>" method="get">
  86
  87 <& enter_route, qa=>$qa, dbh=>$dbh, emsg_r=>\$emsg, warningfs_r=>\@warningfs,
  88         enterwhat => 'Enter starting point(s)',
  89         islandids_r => \@islandids, archipelagoes_r => undef
  90  &>
  91
  92 % if ($searchtype == 0) {
  93 %       $destspec= 'any';
  94 %       $searchtype_show= 'open-ended';
  95 % } elsif ($searchtype == 1) {
  96 %       $destspec= 'circ';
  97 %       $searchtype_show= 'circular';
  98 % } elsif ($searchtype == 2) {
  99 %       $searchtype_show= 'specific-destination';
 100
 101 Destination (one island only):
 102 <& qtextstring, qa => $qa, dbh => $dbh, emsgstore => \$emsg,
 103     thingstring => 'deststring',
 104     prefix => 'ds', boxopts => 'size=40',
 105     onresults => sub {
 106 print STDERR "ONRESULTS @_\n";
 107         return unless @_;
 108         my ($canonname, $island, $arch) = @{ $_[0] };
 109         die unless defined $island;
 110         $destspec= $island;
 111     }
 112  &>
 113
 114 % } else {
 115 %       die "$destspec ?";
 116 % }
 117
 118 <&| enter_advrouteopts, qa=>$qa, dbh=>$dbh, routeparams=>$routeparams &>
 119 <td>
 120 &nbsp;
 121 &nbsp;
 122 <td>
 123  Maximum distance:
 124  <& qtextstring, qa => $qa, dbh => $dbh, prefix => 'ml',
 125     thingstring => 'distance', emsgstore => \$emsg, boxopts => 'size=10',
 126     onresults => sub { ($maxdist)= @_; }
 127    &>
 128 </&>
 129
 130 <input type=submit name=submit value="Search">
 131 % my $ours= sub { $_[0] =~ m/^lossperleague|^islandstring|^deststring|^capitalstring|^capacitystring|^minprofitstring|^distance/; };
 132 <& "lookup:formhidden", ours => $ours &>
 133
 134 % }
 135
 136 </form>
 137 </div>
 138 <div class="results">
 139 <%perl>
 140
 141 my $maxmaxdist= $maxmaxdist[$searchtype];
 142 if (!$emsg && $maxdist > $maxmaxdist) {
 143         $emsg= "Searching for $searchtype_show routes".
 144                " of more than $maxmaxdist leagues is not".
 145                " supported, sorry.";
 146 }
 147
 148 print("</div>"), return
 149      unless $emsgokorprint->($emsg)
 150         and @islandids
 151         and $allargs->{'submit'}
 152         and defined $destspec
 153         and (defined $routeparams->{MaxMass} or
 154              defined $routeparams->{MaxVolume});
 155
 156 #---------- prepare island names ----------
 157
 158 my $islandname_stmt= $dbh->prepare(<<END);
 159         SELECT islandname, archipelago
 160           FROM islands
 161          WHERE islandid = ?
 162 END
 163
 164 my $isleinfo = sub {
 165         my ($id) = @_;
 166         $islandname_stmt->execute($id);
 167         my $row= $islandname_stmt->fetchrow_hashref();
 168         local $_= $row->{'islandname'};
 169         s/ Island$//;
 170         return $_, $row->{'islandname'}, $row->{'archipelago'};
 171 };
 172
 173 #---------- compute the results ----------
 174
 175 my @rsargs= ($concur_lim, '-DN');
 176 my $concur_fail;
 177
 178 foreach my $k (qw(MaxMass MaxVolume MaxCapital)) {
 179         my $v= $routeparams->{$k};
 180         push @rsargs, (defined $v ? $v : -1);
 181 }
 182 push @rsargs, defined $routeparams->{LossPerLeaguePct}
 183         ? $routeparams->{LossPerLeaguePct}*0.01 : 1e-9;
 184 push @rsargs, $routeparams->{MinProfit};
 185 push @rsargs, 'search',$maxdist, $maxcountea,$maxcountea;
 186 push @rsargs, $destspec;
 187 push @rsargs, @islandids;
 188
 189 m/[^-.0-9a-zA-Z]/ and die "$_ $& ?" foreach @rsargs;
 190
 191 if ($qa->{'debug'}) {
 192 </%perl>
 193 [[ <% "@rsargs" |h %> ]]<br><pre>
 194 <%perl>
 195 }
 196
 197 unshift @rsargs,
 198         'nice', sourcebasedir().'/yarrg/routesearch',
 199         '-d', dbw_filename($qa->{'Ocean'}),
 200         '-C', webdatadir().'/_concur.', '.lock';
 201
 202 # touch _concur.0{0,1,2,3,4}.lock
 203 # really chgrp www-data _concur.0?.lock
 204
 205 my %results; # $results{$ap}{"5 6 9 10"} = { stuff }
 206
 207 my $fh= new IO::File;
 208 my $child= $fh->open("-|"); defined $child or die $!;
 209 if (!$child) {
 210         my $cpu= BSD::Resource::RLIMIT_CPU;
 211         my ($soft,$hard)= getrlimit($cpu);
 212         setrlimit($cpu,$maxcpu,$hard) or die $! if $hard<=$maxcpu;
 213         exec @rsargs;
 214         die $!;
 215 }
 216
 217 while (<$fh>) {
 218         chomp;
 219         if ($qa->{'debug'}) {
 220 </%perl>
 221 <% $_ |h %>
 222 <%perl>
 223         }
 224         next unless m/^\s*\@/;
 225         if (m/^\@\@\@ concurrency limit exceeded/) {
 226                 $concur_fail= 1;
 227                 last;
 228         }
 229         die unless m/^ \@ *\d+ ([ap])\# *\d+ \|.*\| *(\d+)lg *\| *\d+ +(\d+) +(\d+) *\| ([0-9 ]+)$/;
 230         my ($ap,$isles) = (uc $1,$5);
 231         next if $results{$ap} && %{$results{$ap}} >= $maxcountea;
 232         my $item= { A => $3, P => $4, Leagues => $2 };
 233         my (@i, @fi, @a);
 234         foreach (split / /, $isles) {
 235                 my ($name,$fullname,$arch)= $isleinfo->($_);
 236                 push @i, $name;
 237                 push @fi, $fullname;
 238                 push @a, $arch unless @a && $a[-1] eq $arch;
 239         }
 240         $item->{Isles}= [ @i ];
 241         $item->{Archs}= [ @a ];
 242         $item->{Start}= $i[0];
 243         $item->{Finish}= $i[-1];
 244         $item->{Vias}= [ ];
 245         my $i;
 246         for ($i=1; $i < @i-1; $i++) {
 247                 push @{ $item->{Vias} }, $i[$i];
 248         }
 249         my %linkqf= (%$baseqf, %$queryqf);
 250         delete $linkqf{'query'};
 251         $linkqf{'routestring'}= join ', ', @fi;
 252         $item->{Url}= $quri->(%linkqf);
 253         $item->{ArchesString}= join ', ', @a;
 254         $item->{ViasString}= join ' ', map { $_.',' } @{ $item->{Vias} };
 255         $item->{RouteSortString}= join ', ', @i;
 256         $results{$ap}{$isles}= $item;
 257 }
 258
 259 if ($qa->{'debug'}) {
 260         print "</pre>\n";
 261 }
 262
 263 $!=0;
 264 if (!close $fh) {
 265         die $! if $!;
 266         die $? if $? != 24; # SIGXCPU but not in POSIX.pm :-/
 267 </%perl>
 268 % $someresults->('Search took too long and was terminated');
 269
 270 Sorry, but your query resulted in a search that took too long.
 271 Searches are limited to <% $maxcpu |h %> seconds of CPU time to
 272 avoid them consuming excessive resources on the server system, and to
 273 make sure that shorter searches can still happen.
 274
 275 <p>
 276 Please try a search with a smaller maximum distance, or place more
 277 restrictions on the route.
 278
 279 </div>
 280 <%perl>
 281         return;
 282 }
 283
 284 if ($concur_fail) {
 285 </%perl>
 286 % $someresults->('Server too busy');
 287
 288 Sorry, but there are already <% $concur_lim |h %> route searches
 289 running.  We limit the number which can run at once to avoid
 290 overloading the server system and to make sure that the rest of the
 291 YARRG website still runs quickly.
 292 <p>
 293
 294 If you submitted several searches and gave up on them (eg by hitting
 295 "back" or "stop" in your browser), be aware that that doesn't
 296 generally stop the search process at the server end.  So it's best to
 297 avoid asking for large searches that you're not sure about.
 298
 299 <p>
 300 Otherwise, please try later.  Searches are limited to <% $maxcpu |h %>
 301 seconds of CPU time so more processing resources should be available soon.
 302
 303 </div>
 304 <%perl>
 305         return;
 306 }
 307
 308 $someresults->();
 309
 310 </%perl>
 311 % foreach my $ap (qw(A P)) {
 312 %       if ($ap eq 'A') {
 313 <h2>Best routes for total profit</h2>
 314 %       } else {
 315 <h2>Best routes for profit per league</h2>
 316 %       }
 317 <table class="data" rules=groups id="ap<% $ap %>_table">
 318 <colgroup span=2>
 319 <colgroup span=1>
 320 <colgroup span=1>
 321 <colgroup span=3>
 322 <tr>
 323 <th colspan=2>Profit
 324 <th>Dist.
 325 <th>Archipelagoes
 326 <th>
 327 <th>Route
 328 <th>
 329 <tr>
 330 <th>Abs.
 331 <th>Per.lg.
 332 <th>
 333 <th>(link to plan)
 334 <th>Start
 335 <th>Via
 336 <th>Finish
 337 <tr id="ap<% $ap %>_sortrow"><th><th><th><th><th><th><th>
 338 %       my $datarow=0;
 339 %       my %sortkeys;
 340 %       foreach my $isles (sort {
 341 %                       $results{$ap}{$b}{$ap} <=>
 342 %                       $results{$ap}{$a}{$ap}
 343 %               } keys %{$results{$ap}}) {
 344 %               my $item= $results{$ap}{$isles};
 345 %               my $ci=0;
 346 %               my $rowid= "r${ap}$isles"; $rowid =~ y/ /_/;
 347 %               foreach my $k (qw(A P Leagues ArchesString
 348 %                                 Start RouteSortString Finish)) {
 349 %                       $sortkeys{$ci}{$rowid}= $item->{$k};
 350 %                       $ci++;
 351 %               }
 352 <tr class="datarow<% $datarow %>" id="<% $rowid %>">
 353 <td align=right><% $item->{A} |h %>
 354 <td align=right><% $item->{P} |h %>
 355 <td align=right><% $item->{Leagues} |h %>
 356 <td align=left><a href="<% $item->{Url} |h %>"><%
 357                   $item->{ArchesString} |h %></a>
 358 <td align=left><% $item->{Start} |h %>,
 359 <td align=left><% $item->{ViasString} |h %>
 360 <td align=left><% $item->{Finish} |h %>
 361 </td>
 362 %               $datarow ^= 1;
 363 %       } # $isles
 364 </table>
 365 <&| tabsort,    table => "ap${ap}_table", sortkeys => "ap${ap}_sortkeys",
 366                 throw => "ap${ap}_sortrow", rowclass => "datarow", cols => [
 367                 { DoReverse => 1, Numeric => 1 },
 368                 { DoReverse => 1, Numeric => 1 },
 369                 { DoReverse => 1, Numeric => 1 },
 370                 { },
 371                 { },
 372                 { },
 373                 { },
 374         ] &>
 375   ap<% $ap %>_sortkeys= <% to_json_protecttags(\%sortkeys) %>;
 376 </&tabsort>
 377 % } # $ap
 378
 379 <p>
 380
 381 <h2>Notes</h2>
 382
 383 Per league values count each island visited as one
 384 (additional) league; the "Dist." column is however the actual distance
 385 to be sailed.  All profit figures are somewhat approximate; get a
 386 complete trading plan for a route for accurate information.
 387
 388 </div>