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