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