chiark / gitweb /
Reorganise docs to include new howto material in intro etc.
[ypp-sc-tools.db-live.git] / 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>