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