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     perresult => sub {
 101         ($max_volume,$max_mass) = @_;
 102     }
 103  &>
 104  size=30
 105 </&>
 106
 107 <td>
 108 &nbsp;
 109 &nbsp;
 110
 111 <td>
 112 Expected losses:
 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 % }