</%doc>
<%attr>
+maxambig => 2
+abbrev_initials => 1
</%attr>
<%method preparse>
</%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>
~yarrgweb / ypp-sc-tools.db-live.git / blobdiff