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