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