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