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