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