chiark / gitweb /
Cosmetic and error report bugfixes
[ypp-sc-tools.main.git] / yarrg / web / query_route
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 `trade route' query.
33
34
35 </%doc>
36 <%args>
37 $quri
38 $dbh
39 $prselector
40 $routestring => '';
41 $capacitystring => '';
42 $lossperleague => '';
43 $someresults
44 $emsgokorprint
45 </%args>
46
47 <%perl>
48 my $emsg;
49 my @archipelagoes;
50 my @islandids;
51 my %islandid2;
52 my ($max_volume, $max_mass);
53 my $lossperleaguepct;
54
55 my $qa= \%ARGS;
56
57 my $be_post;
58 my $startform= sub {
59         ($be_post)= @_;
60 </%perl>
61 <form action="<% $quri->() |h %>" method="<% $be_post ? 'post' : 'get' %>">
62 <%perl>
63 };
64 my $goupdate= sub { $be_post ? 'Update' : 'Go' };
65
66 </%perl>
67
68 <h1>Specify route</h1>
69
70 % $prselector->('ShowStalls');
71
72 %#---------- textbox, user enters route as string ----------
73 % if (!$qa->{Dropdowns}) {
74
75 Enter route (islands, or archipelagoes, separated by |s or commas;
76  abbreviations are OK):<br>
77
78 % $startform->($routestring =~ m/\S/);
79
80 <&| qtextstring, qa => $qa, dbh => $dbh,
81     thingstring => 'routestring', emsgstore => \$emsg,
82     perresult => sub {
83         my ($canonname, $island, $arch) = @_;
84         push @islandids, $island;
85         push @archipelagoes, defined $island ? undef : $arch;
86     }
87  &>
88  size=80
89 </&>
90
91 <strong>Advanced options - you may leave these blank:</strong>
92 <p>
93 <table>
94 <tr>
95 <td>
96
97 Vessel capacity:
98 <&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'cs',
99     thingstring => 'capacitystring', emsgstore => \$emsg,
100     perresult => sub {
101         ($max_volume,$max_mass) = @_;
102     }
103  &>
104  size=30
105 </&>
106
107 <td>
108 &nbsp;
109 &nbsp;
110
111 <td>
112 Estimated loss per league:
113
114 <&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'll',
115     thingstring => 'lossperleague', emsgstore => \$emsg,
116     perresult => sub { ($lossperleaguepct)= @_; }
117  &>
118  size=10
119 </&>
120
121 </table>
122
123 % } else { #---------- dropdowns, user selects from menus ----------
124
125 % $startform->(grep {
126 %               defined $ARGS{"archipelago$_"} ||
127 %               defined $ARGS{"islandid$_"}
128 %       } (0..$qa->{Dropdowns}-1));
129
130 <%perl>
131 my ($sth,$row);
132 my @archlistdata;
133 my %islandlistdata;
134 $islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
135
136 my $optionlistmap= sub {
137         my ($optlist, $selected) = @_;
138         my $out='';
139         foreach my $entry (@$optlist) {
140                 $out.= sprintf('<option value="%s" %s>%s</option>',
141                         encode_entities($entry->[0]),
142                         defined $selected && $entry->[0] eq $selected
143                                 ? 'selected' : '',
144                         encode_entities($entry->[1]));
145         }
146         return $out;
147 };
148
149 $sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
150                             ORDER BY archipelago;");
151 $sth->execute();
152
153 while ($row=$sth->fetchrow_arrayref) {
154         my ($arch)= @$row;
155         push @archlistdata, [ $arch, $arch ];
156         $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
157 }
158
159 $sth= $dbh->prepare("SELECT islandid,islandname,archipelago
160                             FROM islands
161                             ORDER BY islandname;");
162 $sth->execute();
163
164 while ($row=$sth->fetchrow_arrayref) {
165         my $arch= $row->[2];
166         push @{ $islandlistdata{'none'} }, [ @$row ];
167         push @{ $islandlistdata{$arch} }, [ @$row ];
168         $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
169 }
170
171 my %resetislandlistdata;
172 foreach my $arch (keys %islandlistdata) {
173         $resetislandlistdata{$arch}=
174                 $optionlistmap->($islandlistdata{$arch}, '');
175 }
176
177 </%perl>
178
179 <&| script &>
180 ms_lists= <% to_json_protecttags(\%resetislandlistdata) %>;
181 function ms_Setarch(dd) {
182   debug('ms_SetArch '+dd+' arch='+arch);
183   var arch= document.getElementsByName('archipelago'+dd).item(0).value;
184   var got= ms_lists[arch];
185   if (got == undefined) return; // unknown arch ?  hrm
186   debug('ms_SetArch '+dd+' arch='+arch+' got ok');
187   var select= document.getElementsByName('islandid'+dd).item(0);
188   select.innerHTML= got;
189   debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
190 }
191 </&script>
192
193 <table style="table-layout:fixed; width:90%;">
194
195 <tr>
196 %       for my $dd (0..$qa->{Dropdowns}-1) {
197 <td>
198 <select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
199 <option value="none">Whole ocean</option>
200 <% $optionlistmap->(\@archlistdata, $ARGS{"archipelago$dd"}) %></select></td>
201 %       }
202 </tr>
203
204 <tr>
205 %       for my $dd (0..$qa->{Dropdowns}-1) {
206 %               my $arch= $ARGS{"archipelago$dd"};
207 %               $arch= 'none' if !defined $arch;
208 <td>
209 <select name="islandid<% $dd %>">
210 <% $optionlistmap->($islandlistdata{$arch}, $ARGS{"islandid$dd"}) %>
211 </select></td>
212 %       }
213 </tr>
214
215 </table>
216
217 % } #---------- end of dropdowns, now common middle of page code ----------
218
219 <input type=submit name=submit value="<% $goupdate->() %>">
220 % my $ours= sub { $_[0] =~
221 %  m/^island|^archipelago|^routestring|^capacitystring|^lossperleague|^[RT]/;
222 % };
223 <& "lookup:formhidden", ours => $ours &>
224
225 <%perl>
226 #========== results ==========
227
228 $emsgokorprint->($emsg) or @islandids=();
229
230 my $argorundef= sub {
231         my ($dd,$base) = @_;
232         my $thing= $ARGS{"${base}${dd}"};
233         $thing= undef if defined $thing and $thing eq 'none';
234         return $thing;
235 };
236
237 for my $dd (0..$qa->{Dropdowns}-1) {
238         my $arch= $argorundef->($dd,'archipelago');
239         my $island= $argorundef->($dd,'islandid');
240         next unless defined $arch or defined $island;
241         if (defined $island and defined $arch) {
242                 my $ii= $islandid2{$island};
243                 my $iarch= $ii->{Arch};
244                 if ($iarch ne $arch) {
245                         $someresults->();
246 </%perl>
247  Specified archipelago <% $arch %> but
248  island <% $ii->{Name} %>
249  which is in <% $iarch %>; using the island.<br>
250 <%perl>
251                 }
252                 $arch= undef;
253         }
254         push @archipelagoes, $arch;
255         push @islandids, $island;
256 }
257
258 </%perl>
259
260 % if (@islandids) {
261 %       $someresults->('Relevant trades');
262 <& routetrade,
263    dbh => $dbh,
264    islandids => \@islandids,
265    archipelagoes => \@archipelagoes,
266    qa => $qa,
267    max_mass => $max_mass,
268    max_volume => $max_volume,
269    lossperleaguepct => $lossperleaguepct
270  &>
271 </form>
272 % }