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     onresults => sub {
  85         foreach (@_) {
  86         my ($canonname, $island, $arch) = @$_;
  87                 push @islandids, $island;
  88                 push @archipelagoes, defined $island ? undef : $arch;
  89         }
  90     }
  91  &>
  92  size=80
  93 </&>
  94
  95 <strong>Advanced options - you may leave these blank:</strong>
  96 <p>
  97 <table>
  98 <tr>
  99 <td>
 100
 101 Vessel or capacity:
 102 <&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'cs',
 103     thingstring => 'capacitystring', emsgstore => \$emsg,
 104     helpref => 'capacity',
 105     onresults => sub { ($max_mass,$max_volume) = @_; }
 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     onresults => 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     onresults => 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>