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 <%method execute>
  36 <%args>
  37 $string
  38 $dbh
  39 $debugf
  40 </%args>
  41 <%perl>
  42
  43 my $commodsth;
  44
  45 my @mv_names= qw(mass volume);
  46 my @mv_units= qw(kg l);
  47
  48 my (@mv)= (undef,undef);
  49 return ('',@mv) unless $string =~ m/\S/;
  50
  51 my @canon= ();
  52 my ($signum,$signopstr)= (+1,undef);
  53 my $show_answer=0;
  54 my $first_term=1;
  55 my $last_signopstr= 'NONE';
  56
  57 my $canon_numeric= sub {
  58         my ($val,$mvi) = @_;
  59         sprintf "%g%s", $val, $mv_units[$mvi];
  60 };
  61
  62 my $parse_values= sub {
  63   local ($_) = @_;
  64   $debugf->("TERM VALUES '$_'");
  65   $_ .= ' ';
  66   my $def= sub {
  67         my ($mvi,$val) = @_;
  68         if ($first_term) {
  69                 expected_error("Initial term specifies".
  70                                 " $mv_names[$mvi] more than once.")
  71                         if defined $mv[$mvi];
  72                 $mv[$mvi]= $val;
  73         } else {
  74                 expected_error("Cannot add or subtract mass to/from volume")
  75                         unless defined $mv[$mvi];
  76                 $mv[$mvi] += $signum * $val;
  77         }
  78         push @canon, $canon_numeric->($val,$mvi);
  79   };
  80   while (m/\S/) {
  81         $debugf->("VALUE '$_'");
  82         my $iqtyrex= '[1-9] \d{0,8}';
  83         my $fqtyrex= '\d{1,9} \. \d{0,3} |' . $iqtyrex;
  84         if    (s/^( $fqtyrex ) \s* kg \s+ //xo) { $def->(0, $1          ); }
  85         elsif (s/^( $fqtyrex ) \s* t  \s+ //xo) { $def->(0, $1 * 1000.0 ); }
  86         elsif (s/^( $fqtyrex ) \s* l  \s+ //xo) { $def->(1, $1          ); }
  87         elsif (s/^( $fqtyrex ) \s* kl \s+ //xo) { $def->(1, $1 * 1000.0 ); }
  88         elsif (s/^( $iqtyrex ) \s* ([a-z ]+) \s+ //xo) {
  89                 my ($qty,$spec) = ($1,$2);
  90                 $debugf->("VALUE COMMOD $qty '$spec'");
  91                 expected_error("Capacity specification must start with".
  92                                " ship size or amount with units")
  93                         if $first_term;
  94                 $commodsth ||=
  95                     $dbh->prepare("SELECT commodname,unitmass,unitvolume
  96                                      FROM commods WHERE commodname LIKE ?");
  97                 my ($emsg,$commod,@umv)=
  98                     dbw_lookup_string($spec,$commodsth,1,0,0,
  99                                 "No commodity or unit matches \`$spec'",
 100                                 "Ambiguous commodity (or unit) \`$spec'",
 101                                 undef);
 102                 expected_error($emsg) if defined $emsg;
 103                 $debugf->("VALUE COMMOD FOUND '$commod' @umv");
 104                 foreach my $mvi (0,1) {
 105                        next unless defined $mv[$mvi];
 106                        $mv[$mvi] += $signum * $qty * $umv[$mvi] * 0.001;
 107                 }
 108                 push @canon, sprintf "%d", $qty;
 109                 push @canon, $commod;
 110         } else {
 111                 s/\s+$//;
 112                 expected_error("Did not understand value \`$_'");
 113         }
 114   }
 115 };
 116
 117 my $parse_term= sub {
 118         local ($_) = @_;
 119         $debugf->("TERM '$_' signum=$signum");
 120         s/^\s+//; s/\s+$//;
 121         expected_error("empty term in capacity") unless m/\S/;
 122         if (m/^\s*(\d{1,2}(?:\.\d{0,4})?)\%\s*$/) {
 123                 $debugf->("TERM PERCENT $1");
 124                 expected_error("percentage may not be first item")
 125                         if $first_term;
 126                 my $pct= 100.0 + $signum * $1;
 127                 foreach (@mv) {
 128                         next unless defined;
 129                         $_ *= $pct / 100.0;
 130                 }
 131                 push @canon, sprintf "%g%%", $pct;
 132         } elsif (!m/[^a-z]/) {
 133                 $debugf->("TERM NAME");
 134                 expected_error("Name (should be unit or commodity) \`$_'".
 135                                 " without preceding quantity")
 136                         unless $first_term;
 137                 my $sth= $dbh->prepare("SELECT name,mass,volume".
 138                                        "  FROM vessels WHERE name LIKE ?");
 139                 my ($emsg,$ship,@smv)=
 140                     dbw_lookup_string($_,$sth,1,1,2,
 141                                 "Ship name `$_' not understood.",
 142                                 "Too many matching ship types.",
 143                                 sub { "Ambiguous - could be $_[0]" });
 144                 expected_error($emsg) if defined $emsg;
 145                 $debugf->("TERM NAME SHIP '$ship' @smv");
 146                 $show_answer= 1;
 147                 @mv = @smv;
 148                 push @canon, $ship;
 149         } else {
 150                 $parse_values->($_);
 151         }
 152         $first_term= 0;
 153 };
 154
 155 while ($string =~ s/^(.*?)(\bminus\b|-|\bplus\b|\+)//) {
 156         my ($lhs)= ($1);
 157         my @nextsign= $2 =~ m/^p|^\+/ ? (+1,'+') : (-1,'-');
 158         $show_answer= 1;
 159         $debugf->("GROUP S='$2'");
 160         $parse_term->($lhs);
 161         ($signum,$signopstr)= @nextsign;
 162         push @canon, ($last_signopstr=$signopstr)
 163                 if $signopstr ne $last_signopstr;
 164 }
 165 $parse_term->($string);
 166
 167 my $canon= join ' ', @canon;
 168
 169 if ($show_answer) {
 170         $canon .= "  [=";
 171         foreach my $mvi (0,1) {
 172                 next unless defined $mv[$mvi];
 173                 $canon .= ' '.$canon_numeric->($mv[$mvi], $mvi);
 174         }
 175         $canon .= "]";
 176 }
 177
 178 $debugf->("FINISHING canon='$canon'");
 179
 180 foreach my $mvi (0,1) {
 181         next unless defined $mv[$mvi];
 182         next if $mv[$mvi] >= 0;
 183         expected_error(sprintf "%s limit is negative: %s",
 184                 ucfirst($mv_names[$mvi]), $canon_numeric->($mv[$mvi], $mvi));
 185 }
 186
 187 return ($canon, @mv);
 188
 189 </%perl>
 190 </%method>