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