chiark / gitweb /
routesearch: support circular routes
[ypp-sc-tools.db-live.git] / 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>