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 <table>
  92 <tr>
  93 <td>
  94
  95 Vessel capacity:
  96 <&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'cs',
  97     thingstring => 'capacitystring', emsgstore => \$emsg,
  98     perresult => sub {
  99         ($max_volume,$max_mass) = @_;
 100     }
 101  &>
 102 </&>
 103
 104 <td>
 105 &nbsp;
 106 &nbsp;
 107
 108 <td>
 109 Estimated loss per league:
 110
 111 <&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'll',
 112     thingstring => 'lossperleague', emsgstore => \$emsg,
 113     perresult => sub { ($lossperleaguepct)= @_; }
 114  &>
 115 </&>
 116
 117 </table>
 118
 119 % } else { #---------- dropdowns, user selects from menus ----------
 120
 121 % $startform->(grep {
 122 %               defined $ARGS{"archipelago$_"} ||
 123 %               defined $ARGS{"islandid$_"}
 124 %       } (0..$qa->{Dropdowns}-1));
 125
 126 <%perl>
 127 my ($sth,$row);
 128 my @archlistdata;
 129 my %islandlistdata;
 130 $islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
 131
 132 my $optionlistmap= sub {
 133         my ($optlist, $selected) = @_;
 134         my $out='';
 135         foreach my $entry (@$optlist) {
 136                 $out.= sprintf('<option value="%s" %s>%s</option>',
 137                         encode_entities($entry->[0]),
 138                         defined $selected && $entry->[0] eq $selected
 139                                 ? 'selected' : '',
 140                         encode_entities($entry->[1]));
 141         }
 142         return $out;
 143 };
 144
 145 $sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
 146                             ORDER BY archipelago;");
 147 $sth->execute();
 148
 149 while ($row=$sth->fetchrow_arrayref) {
 150         my ($arch)= @$row;
 151         push @archlistdata, [ $arch, $arch ];
 152         $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
 153 }
 154
 155 $sth= $dbh->prepare("SELECT islandid,islandname,archipelago
 156                             FROM islands
 157                             ORDER BY islandname;");
 158 $sth->execute();
 159
 160 while ($row=$sth->fetchrow_arrayref) {
 161         my $arch= $row->[2];
 162         push @{ $islandlistdata{'none'} }, [ @$row ];
 163         push @{ $islandlistdata{$arch} }, [ @$row ];
 164         $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
 165 }
 166
 167 my %resetislandlistdata;
 168 foreach my $arch (keys %islandlistdata) {
 169         $resetislandlistdata{$arch}=
 170                 $optionlistmap->($islandlistdata{$arch}, '');
 171 }
 172
 173 </%perl>
 174
 175 <&| script &>
 176 ms_lists= <% to_json_protecttags(\%resetislandlistdata) %>;
 177 function ms_Setarch(dd) {
 178   debug('ms_SetArch '+dd+' arch='+arch);
 179   var arch= document.getElementsByName('archipelago'+dd).item(0).value;
 180   var got= ms_lists[arch];
 181   if (got == undefined) return; // unknown arch ?  hrm
 182   debug('ms_SetArch '+dd+' arch='+arch+' got ok');
 183   var select= document.getElementsByName('islandid'+dd).item(0);
 184   select.innerHTML= got;
 185   debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
 186 }
 187 </&script>
 188
 189 <table style="table-layout:fixed; width:90%;">
 190
 191 <tr>
 192 %       for my $dd (0..$qa->{Dropdowns}-1) {
 193 <td>
 194 <select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
 195 <option value="none">Whole ocean</option>
 196 <% $optionlistmap->(\@archlistdata, $ARGS{"archipelago$dd"}) %></select></td>
 197 %       }
 198 </tr>
 199
 200 <tr>
 201 %       for my $dd (0..$qa->{Dropdowns}-1) {
 202 %               my $arch= $ARGS{"archipelago$dd"};
 203 %               $arch= 'none' if !defined $arch;
 204 <td>
 205 <select name="islandid<% $dd %>">
 206 <% $optionlistmap->($islandlistdata{$arch}, $ARGS{"islandid$dd"}) %>
 207 </select></td>
 208 %       }
 209 </tr>
 210
 211 </table>
 212
 213 % } #---------- end of dropdowns, now common middle of page code ----------
 214
 215 <input type=submit name=submit value="<% $goupdate->() %>">
 216 % my $ours= sub { $_[0] =~
 217 %  m/^island|^archipelago|^routestring|^capacitystring|^lossperleague|^[RT]/;
 218 % };
 219 <& "lookup:formhidden", ours => $ours &>
 220
 221 <%perl>
 222 #========== results ==========
 223
 224 $emsgokorprint->($emsg) or @islandids=();
 225
 226 my $argorundef= sub {
 227         my ($dd,$base) = @_;
 228         my $thing= $ARGS{"${base}${dd}"};
 229         $thing= undef if defined $thing and $thing eq 'none';
 230         return $thing;
 231 };
 232
 233 for my $dd (0..$qa->{Dropdowns}-1) {
 234         my $arch= $argorundef->($dd,'archipelago');
 235         my $island= $argorundef->($dd,'islandid');
 236         next unless defined $arch or defined $island;
 237         if (defined $island and defined $arch) {
 238                 my $ii= $islandid2{$island};
 239                 my $iarch= $ii->{Arch};
 240                 if ($iarch ne $arch) {
 241                         $someresults->();
 242 </%perl>
 243  Specified archipelago <% $arch %> but
 244  island <% $ii->{Name} %>
 245  which is in <% $iarch %>; using the island.<br>
 246 <%perl>
 247                 }
 248                 $arch= undef;
 249         }
 250         push @archipelagoes, $arch;
 251         push @islandids, $island;
 252 }
 253
 254 </%perl>
 255
 256 % if (@islandids) {
 257 %       $someresults->('Relevant trades');
 258 <& routetrade,
 259    dbh => $dbh,
 260    islandids => \@islandids,
 261    archipelagoes => \@archipelagoes,
 262    qa => $qa,
 263    max_mass => $max_mass,
 264    max_volume => $max_volume,
 265    lossperleaguepct => $lossperleaguepct
 266  &>
 267 </form>
 268 % }