X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=blobdiff_plain;f=yarrg%2Fweb%2Fcheck_capacitystring;h=13403b19505bc9ae366c99b5f7a952280397cbb1;hp=3d8f7a52701fd2983c09ca6bdc6629af1467ec91;hb=555b3391b3cd9967a29b219fff242b583137d2b8;hpb=742ec1631db983f22545c9c7d6d573865bdc85fa

diff --git a/yarrg/web/check_capacitystring b/yarrg/web/check_capacitystring
index 3d8f7a5..13403b1 100644
--- a/yarrg/web/check_capacitystring
+++ b/yarrg/web/check_capacitystring
@@ -34,6 +34,8 @@
 </%doc>
 
 <%attr>
+maxambig => 2
+abbrev_initials => 1
 </%attr>
 
 <%method preparse>
@@ -42,47 +44,179 @@ $h
 </%args>
 <%perl>
 
-my $def= sub {
-	my ($what,$val) = @_;
-	if (defined $h->{$what}) {
-		$h->{Emsg}= "Multiple definitions of maximum $what.";
+my $parse_numeric= sub {
+	# returns (mass,volume,emsg)
+	my ($string,$default)= @_;
+
+	my @mve= (undef,undef,undef);
+
+	if ($string !~ m/\d/) {
+		return (undef,undef,
+			'Adjustments to capacity must contain digits.');
+	}
+
+	my $def= sub {
+		my ($ix,$what,$val) = @_;
+		if (defined $h->{$what}) {
+			$mve[2]= "\`$string' specifies $what more than once.";
+		}
+		print STDERR "SET $what $val\n";
+		$mve[$ix]= $val;
+	};
+
+print STDERR "PAN \`$string'\n";
+	local $_;
+	foreach $_ (split /\s+/, $string) {
+		print STDERR "ITEM \`$_'\n";
+		next unless length;
+		if (m/^([1-9]\d{0,8})l$/) {
+			$def->(1, 'volume', $1);
+		} elsif (m/^([1-9]\d{0,8})kg$/) {
+			$def->(0, 'mass', $1);
+		} elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)kl/) {
+			$def->(1, 'volume', $1 * 1000);
+		} elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)t/) {
+			$def->(0, 'mass', $1 * 1000);
+		} else {
+			$mve[2]= "Cannot understand item \`$_'".
+				" in numeric capacity";
+		}
+	}
+#	foreach my $ix (qw(0 1)) {
+#		$mve[$ix]= $default unless defined $mve[$ix];
+#	}
+	return @mve;
+};
+
+my @mv_names= qw(mass volume);
+my $canon_numeric= $h->{'canon_numeric'}= sub {
+	print STDERR "CANNUM @_\n";
+	my $sep= '';
+	my $out= '';
+	foreach my $ix (qw(0 1)) {
+		next unless defined $_[$ix];
+		$out .= $sep; $sep= ' ';
+		$out .= sprintf "%g%s", $_[$ix], (qw(kg l))[$ix];
 	}
-	print STDERR "SET $what $val\n";
-	$h->{$what}= $val;
+	return $out;
 };
 
-foreach $_ (split /\s+/, ${ $h->{String} }) {
-	print STDERR "ITEM \`$_'\n";
-	next unless length;
-	if (m/^([1-9]\d{0,8})l$/) {
-		$def->('volume', $1);
-	} elsif (m/^([1-9]\d{0,8})kg$/) {
-		$def->('mass', $1);
-	} elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)kl/) {
-		$def->('volume', $1 * 1000);
-	} elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)t/) {
-		$def->('mass', $1 * 1000);
+$h->{'deltas'}= [ ];
+print STDERR "NDELTA0 $#{ $h->{'deltas'} }\n";
+
+local ($_)= ${ $h->{String} };
+while (m/^(.*)(\bminus\b|-|\bplus\b|\+)/) {
+	my ($lhs,$rhs)= ($1,$');
+	print STDERR "TERM L=\`$1' M=\`$2' R=\`$''\n";
+	my ($signum,$signopstr)= 
+		$2 =~ m/^p|^\+/ ? (+1,'plus') : (-1,'minus');
+	my @mveco;
+	if ($rhs =~ m/^\s*(\d{1,2}(?:\.\d{0,4})?)\%\s*$/) {
+		my $pct= 100.0 + $signum * $1;
+		@mveco= ($pct,$pct,undef);
+		push @mveco, sprintf "%s %g%%", $signopstr, $1;
+		push @mveco, sub {
+			return undef unless defined $_[0];
+			$_[0] * $_[1] / 100.0
+		};
 	} else {
-		${ $h->{Emsg} }= "Cannot understand capacity \`$_'.";
-		last;
+		@mveco= $parse_numeric->($rhs, 0);
+		if (!defined $mveco[2]) {
+			push @mveco, $signopstr.' '.$canon_numeric->(@mveco);
+			push @mveco, sub {
+				${ $h->{Emsg} }= "Cannot add or subtract".
+					" mass to/from volume"
+					unless defined $_[0];
+				$_[0] + $_[1] * $signum
+			};
+		}
 	}
+	${ $h->{Emsg} }= $mveco[2] if defined $mveco[2];
+	unshift @{ $h->{'deltas'} }, [ @mveco ];
+	print STDERR "NDELTA $#{ $h->{'deltas'} }\n";
+	$_= $lhs;
 }
+
+s/^\s+//; s/\s+$//;
+
+if (m/^[a-z ]+$/) {
+	push @{ $h->{Specs} }, $_;
+} elsif (m/\d/) {
+	my (@mve)= $parse_numeric->($_, undef);
+	if (defined $mve[2]) { ${ $h->{Emsg} }= $mve[2]; return; }
+	$h->{'initial'}= \@mve;
+} elsif (m/\S/) {
+	${ $h->{Emsg} }= "Cannot understand capacity specification \`$_'.";
+} else {
+	$h->{'initial'}= [undef,undef];
+}
+
 </%perl>
 </%method>
 
+<%method sqlstmt>
+SELECT name,mass,volume
+	FROM vessels WHERE name LIKE ?
+</%method>
+
+<%method nomatch>
+  Did not understand ship name.
+</%method>
+
+<%method ambiguous>
+  Ambiguous - could be <% $ARGS{couldbe} |h %>
+</%method>
+
+<%method manyambig>
+  Too many matching ship types.
+</%method>
+
 <%method postquery>
 <%args>
 $h
 </%args>
 <%perl>
 
-if (defined $h->{'mass'} or defined $h->{'volume'}) {
-	@{ $h->{Results} } = [ $h->{'mass'}, $h->{'volume'} ];
+my $canon_numeric= $h->{'canon_numeric'};
+
+return if length ${ $h->{Emsg} };
 
-	${ $h->{Canon} }=
- 'mass limit: '.(defined $h->{'mass'} ? $h->{'mass'} .'kg' : 'none').'; '.
- 'volume limit: '.(defined $h->{'volume'} ? $h->{'volume'} .'l' : 'none').'.';
+my @mv;
+my @mv_names= qw(mass volume);
+if (@{ $h->{Specs} }) {
+	@mv= @{ $h->{Results}[0] }[1,2];
+} else {
+	@mv= @{ $h->{'initial'} };
+	${ $h->{Canon} }= $canon_numeric->(@mv);
 }
+print STDERR "INITIAL @mv\n";
+
+print STDERR "NDELTAE $#{ $h->{'deltas'} }\n";
+foreach my $delta (@{ $h->{'deltas'} }) {
+	print STDERR "DELTA @$delta\n";
+	die if defined $delta->[2]; # emsg
+	foreach my $ix (qw(0 1)) {
+		next unless defined $delta->[$ix];
+		print STDERR "DELTA I $ix\n";
+		$mv[$ix] = $delta->[4]->($mv[$ix], $delta->[$ix]);
+		return if length ${ $h->{Emsg} };
+	}
+	${ $h->{Canon} }.= ' '.$delta->[3];
+}
+
+if (@{ $h->{Specs} } || @{ $h->{'deltas'} }) {
+	${ $h->{Canon} }.= "  [= ". $canon_numeric->(@mv). "]";
+}
+
+foreach my $ix (qw(0 1)) {
+	next unless defined $mv[$ix];
+	next if $mv[$ix] >= 0;
+	${ $h->{Emsg} }= sprintf "%s limit is negative: %s",
+		ucfirst($mv_names[$ix]), $canon_numeric->(@mv);
+	return;
+}
+
+@{ $h->{Results} }= [ @mv ];
 
 </%perl>
 </%method>