chiark / gitweb /
Fix name in copyright notices
[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+ //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>