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