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