yarrg/web/check_capacitystring

   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 simply defines how to interpret capacities.
  33
  34 </%doc>
  35
  36 <%attr>
  37 maxambig => 2
  38 </%attr>
  39
  40 <%method preparse>
  41 <%args>
  42 $h
  43 </%args>
  44 <%perl>
  45
  46 my $parse_numeric= sub {
  47         # returns (mass,volume,emsg)
  48         my ($string,$default)= @_;
  49
  50         my @mve= (undef,undef,undef);
  51
  52         if ($string !~ m/\d/) {
  53                 return (undef,undef,
  54                         'Adjustments to capacity must contain digits.');
  55         }
  56
  57         my $def= sub {
  58                 my ($ix,$what,$val) = @_;
  59                 if (defined $h->{$what}) {
  60                         $mve[2]= "\`$string' specifies $what more than once.";
  61                 }
  62                 print STDERR "SET $what $val\n";
  63                 $mve[$ix]= $val;
  64         };
  65
  66 print STDERR "PAN \`$string'\n";
  67         local $_;
  68         foreach $_ (split /\s+/, $string) {
  69                 print STDERR "ITEM \`$_'\n";
  70                 next unless length;
  71                 if (m/^([1-9]\d{0,8})l$/) {
  72                         $def->(1, 'volume', $1);
  73                 } elsif (m/^([1-9]\d{0,8})kg$/) {
  74                         $def->(0, 'mass', $1);
  75                 } elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)kl/) {
  76                         $def->(1, 'volume', $1 * 1000);
  77                 } elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)t/) {
  78                         $def->(0, 'mass', $1 * 1000);
  79                 } else {
  80                         $mve[2]= "Cannot understand item \`$_'".
  81                                 " in numeric capacity";
  82                 }
  83         }
  84 #       foreach my $ix (qw(0 1)) {
  85 #               $mve[$ix]= $default unless defined $mve[$ix];
  86 #       }
  87         return @mve;
  88 };
  89
  90 $h->{'deltas'}= [ ];
  91 print STDERR "NDELTA0 $#{ $h->{'deltas'} }\n";
  92
  93 local ($_)= ${ $h->{String} };
  94 while (m/^(.*)(\bminus\b|-|\bplus\b|\+)/) {
  95         my ($lhs,$rhs)= ($1,$');
  96         print STDERR "TERM L=\`$1' M=\`$2' R=\`$''\n";
  97         my ($signum,$signopstr)=
  98                 $2 =~ m/^p|^\+/ ? (+1,'plus') : (-1,'minus');
  99         my (@mve)= $parse_numeric->($rhs, 0);
 100         ${ $h->{Emsg} }= $mve[2] if defined $mve[2];
 101         unshift @{ $h->{'deltas'} }, [ @mve,$signum,$signopstr ];
 102         print STDERR "NDELTA $#{ $h->{'deltas'} }\n";
 103         $_= $lhs;
 104 }
 105
 106 s/^\s+//; s/\s+$//;
 107
 108 if (m/^[a-z ]+$/) {
 109         push @{ $h->{Specs} }, $_;
 110 } elsif (m/\d/) {
 111         my (@mve)= $parse_numeric->($_, undef);
 112         if (defined $mve[2]) { ${ $h->{Emsg} }= $mve[2]; return; }
 113         $h->{'initial'}= \@mve;
 114 } elsif (m/\S/) {
 115         ${ $h->{Emsg} }= "Cannot understand capacity specification \`$_'.";
 116 } else {
 117         $h->{'initial'}= [undef,undef];
 118 }
 119
 120 </%perl>
 121 </%method>
 122
 123 <%method sqlstmt>
 124 SELECT name,mass,volume
 125         FROM vessels WHERE name LIKE ?
 126 </%method>
 127
 128 <%method nomatch>
 129   Did not understand ship name.
 130 </%method>
 131
 132 <%method ambiguous>
 133   Ambiguous - could be <% $ARGS{couldbe} |h %>
 134 </%method>
 135
 136 <%method manyambig>
 137   Too many matching ship types.
 138 </%method>
 139
 140 <%method postquery>
 141 <%args>
 142 $h
 143 </%args>
 144 <%perl>
 145
 146 return if length ${ $h->{Emsg} };
 147
 148 my @mv_names= qw(mass volume);
 149
 150 my $canon_numeric= sub {
 151         print STDERR "CANNUM @_\n";
 152         my $sep= '';
 153         my $out= '';
 154         foreach my $ix (qw(0 1)) {
 155                 next unless defined $_[$ix];
 156                 $out .= $sep; $sep= ' ';
 157                 $out .= sprintf "%g%s", $_[$ix], (qw(kg l))[$ix];
 158         }
 159         return $out;
 160 };
 161
 162 my @mv;
 163 if (@{ $h->{Specs} }) {
 164         @mv= @{ $h->{Results}[0] }[1,2];
 165         print STDERR "INITIAL VESSEL @mv\n";
 166 } else {
 167         @mv= @{ $h->{'initial'} };
 168         ${ $h->{Canon} }= $canon_numeric->(@mv);
 169 }
 170
 171 print STDERR "NDELTAE $#{ $h->{'deltas'} }\n";
 172 foreach my $delta (@{ $h->{'deltas'} }) {
 173         print STDERR "DELTA @$delta\n";
 174         die if defined $delta->[2]; # emsg
 175         foreach my $ix (qw(0 1)) {
 176                 next unless defined $delta->[$ix];
 177                 print STDERR "DELTA I $ix\n";
 178                 if (!defined $mv[$ix]) {
 179                         ${ $h->{Emsg} }= "Cannot add or subtract".
 180                                 " $mv_names[$ix] to/from $mv_names[!$ix]";
 181                         return;
 182                 }
 183                 $mv[$ix] += $delta->[$ix] * $delta->[3];
 184         }
 185         ${ $h->{Canon} }.= " $delta->[4] ". $canon_numeric->(@$delta);
 186 }
 187
 188 if (@{ $h->{Specs} } || @{ $h->{'deltas'} }) {
 189         ${ $h->{Canon} }.= "  [= ". $canon_numeric->(@mv). "]";
 190 }
 191
 192 foreach my $ix (qw(0 1)) {
 193         next unless defined $mv[$ix];
 194         next if $mv[$ix] >= 0;
 195         ${ $h->{Emsg} }= sprintf "%s limit is negative: %s",
 196                 ucfirst($mv_names[$ix]), $canon_numeric->(@mv);
 197         return;
 198 }
 199
 200 @{ $h->{Results} }= [ @mv ];
 201
 202 </%perl>
 203 </%method>