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