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+ //ixo) {
  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 ".escerrq($spec),
 100                         "Ambiguous commodity (or unit) ".escerrq($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                         escerrq($_));
 114         }
 115   }
 116 };
 117
 118 my $parse_term= sub {
 119         local ($_) = @_;
 120         $debugf->("TERM '$_' signum=$signum");
 121         s/^\s+//; s/\s+$//;
 122         expected_error("empty term in capacity") unless m/\S/;
 123         if (m/^\s*(\d{1,2}(?:\.\d{0,4})?)\%\s*$/) {
 124                 $debugf->("TERM PERCENT $1");
 125                 expected_error("percentage may not be first item")
 126                         if $first_term;
 127                 my $pct= 100.0 + $signum * $1;
 128                 foreach (@mv) {
 129                         next unless defined;
 130                         $_ *= $pct / 100.0;
 131                 }
 132                 push @canon, sprintf "%g%%", $pct;
 133         } elsif (!m/[^a-z ]/i) {
 134                 $debugf->("TERM NAME");
 135                 expected_error("Name (should be unit or commodity)".
 136                                 escerrq($_).
 137                                 " without preceding quantity")
 138                         unless $first_term;
 139                 my $sth= $dbh->prepare("SELECT name,mass,volume".
 140                                        "  FROM vessels WHERE name LIKE ?");
 141                 my ($emsg,$ship,@smv)=
 142                     dbw_lookup_string($_,$sth,1,1,2,
 143                                 "Ship name ".escerrq($_)." not understood.",
 144                                 "Too many matching ship types.",
 145                                 sub { "Ambiguous - could be $_[1]" });
 146                 expected_error($emsg) if defined $emsg;
 147                 $debugf->("TERM NAME SHIP '$ship' @smv");
 148                 $show_answer= 1;
 149                 @mv = @smv;
 150                 push @canon, $ship;
 151         } else {
 152                 $parse_values->($_);
 153         }
 154         $first_term= 0;
 155 };
 156
 157 while ($string =~ s/^(.*?)(\bminus\b|-|\bplus\b|\+)//i) {
 158         my ($lhs)= ($1);
 159         my @nextsign= $2 =~ m/^p|^\+/ ? (+1,'+') : (-1,'-');
 160         $show_answer= 1;
 161         $debugf->("GROUP S='$2'");
 162         $parse_term->($lhs);
 163         ($signum,$signopstr)= @nextsign;
 164         push @canon, ($last_signopstr=$signopstr)
 165                 if $signopstr ne $last_signopstr;
 166 }
 167 $parse_term->($string);
 168
 169 my $canon= join ' ', @canon;
 170
 171 if ($show_answer) {
 172         $canon .= "  [=";
 173         foreach my $mvi (0,1) {
 174                 next unless defined $mv[$mvi];
 175                 $canon .= ' '.$canon_numeric->($mv[$mvi], $mvi);
 176         }
 177         $canon .= "]";
 178 }
 179
 180 $debugf->("FINISHING canon='$canon'");
 181
 182 foreach my $mvi (0,1) {
 183         next unless defined $mv[$mvi];
 184         next if $mv[$mvi] >= 0;
 185         expected_error(sprintf "%s limit is negative: %s",
 186                 ucfirst($mv_names[$mvi]), $canon_numeric->($mv[$mvi], $mvi));
 187 }
 188
 189 return ($canon, @mv);
 190
 191 </%perl>
 192 </%method>