1 # Units.pl: convert units of measurement
2 # Author: M-J. Dominus (mjd-perl-units-id-iut+buobvys+@plover.com)
3 # License: GPL, Copyright (C) 1996,1999
4 # NOTE: Integrated into blootbot by xk.
13 my %unittab; # Definitions loaded here
15 # Metric prefixes. These must be powers of ten or change the
16 # token_value subroutine
18 %PREF = (yocto => -24,
43 $PREF = join '|', sort { $PREF{$a} <=> $PREF{$b} } (keys %PREF);
47 ################################################################
51 ################################################################
54 $defs_read += read_defs("$::bot_data_dir/unittab");
57 &::ERROR("Could not read any of the initialization files UNITTAB");
66 $from =~ s/\^(\-?\d+)/$1/;
67 $to =~ s/\^(\-?\d+)/$1/;
72 foreach (keys %powers) {
73 $from =~ s/(\D+) $powers{$_}$/$1\Q$_/;
74 $to =~ s/(\D+) $powers{$_}$/$1\Q$_/;
80 if ($from =~ s/^\s*\#\s*//) {
81 if (definition_line($from)) {
84 &::DEBUG("Error: $PARSE_ERROR.");
86 &::DEBUG("FAILURE 1.");
89 unless ($from =~ /\S/) {
90 &::DEBUG("FAILURE 2");
94 my $hu = parse_unit($from);
96 &::DEBUG($PARSE_ERROR);
97 &::msg($::who, $PARSE_ERROR);
104 redo unless $to =~ /\S/;
105 $wu = parse_unit($to);
107 &::DEBUG($PARSE_ERROR);
110 my $quot = unit_divide($hu, $wu);
111 if (is_dimensionless($quot)) {
114 &::performStrictReply("$to is an invalid unit?");
117 # yet another powers hack.
118 $from =~ s/([[:alpha:]]+)(\d)/$1\^$2/g;
119 $to =~ s/([[:alpha:]]+)(\d)/$1\^$2/g;
121 &::performStrictReply(sprintf("$from is approximately \002%.6g\002 $to", $q));
123 &::performStrictReply("$from cannot be correctly converted to $to.");
126 # "conformability (Not the same dimension)\n",
127 # "\t", $from, " is ", text_unit($hu), "\n",
128 # "\t", $to, " is ", text_unit($wu), "\n",
134 ################################################################
138 unless (open D, $file) {
139 if ($show_file_loading) {
140 print STDERR "Couldn't open file `$file': $!; skipping.\n";
149 print ">>> $_\n" if $DEBUG_d;
150 my $r = definition_line($_);
151 unless (defined $r) {
152 warn "Error in line $. of $file: $PARSE_ERROR. Skipping.\n";
155 print STDERR "Loaded file `$file'.\n" if $show_file_loading;
159 sub definition_line {
161 my ($name, $data) = split /\s+/, $line, 2;
162 my $value = parse_unit($data);
163 if (is_Zero($value)) {
166 if (is_fundamental($value)) {
167 return $unittab{$name} = {_ => 1, $name => 1};
169 return $unittab{$name} = $value;
178 sub Zero () { +{ _ => 0 } }
186 print STDERR "Looking up unit `$name'\n" if $DEBUG_l;
187 return $unittab{$name} if exists $unittab{$name};
189 my $shortname = $name;
190 $shortname =~ s/s$//;
191 return $unittab{$shortname} if exists $unittab{$shortname};
193 my ($prefix, $rest) = ($name =~ /^($PREF-?)(.*)/o);
195 $PARSE_ERROR = "Unknown unit `$name'";
198 my $base_unit = unit_lookup($rest); # Recursive
199 con_multiply($base_unit, 10**$PREF{$prefix});
204 print STDERR "Multiplying @{[%$a]} by @{[%$b]}: \n" if $DEBUG_o;
210 $r->{$u} += $b->{$u};
212 print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
219 &::DEBUG("Division by zero error");
227 $r->{$u} -= $b->{$u};
234 print STDERR "Raising unit @{[%$u]} to power $p.\n" if $DEBUG_o;
242 print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
246 sub unit_dimensionless {
247 print "Turning $_[0] into a dimensionless unit.\n" if $DEBUG_o;
248 return +{_ => $_[0]};
253 print STDERR "Multiplying unit @{[%$u]} by constant $c.\n" if $DEBUG_o;
256 print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
260 sub is_dimensionless {
265 return if $r->{$u} != 0;
270 # Generate bogus unit value that signals that a new fundamental unit
272 sub new_fundamental_unit {
273 return +{__ => 'new', _ => 1};
276 # Recognize this bogus value when it appears again.
286 for $k (sort keys %$u) {
288 push @pos, $k if $u->{$k} > 0;
289 push @neg, $k if $u->{$k} < 0;
291 my $text = ($c == 1 ? '' : $c);
296 $text .= "^$e" if $e > 1;
299 $text .= ' per' if @neg;
303 $text .= "^$e" if $e > 1;
308 ################################################################
314 sub sh { ['shift', $_[0]] };
315 sub go { ['goto', $_[0]] };
322 FUNDAMENTAL => sh(4),
329 # State 1: constant -> PREFIX .
330 { _ => ['reduce', 1, 'constant']},
331 # State 2: constant -> NUMBER .
332 { _ => ['reduce', 1, 'constant']},
333 # State 3: unit -> NAME .
334 { _ => ['reduce', 1, 'unit', \&unit_lookup ]},
335 # State 4: unit -> FUNDAMENTAL .
336 { _ => ['reduce', 1, 'unit', \&new_fundamental_unit ]},
337 # State 5: constant -> FRACTION .
338 { _ => ['reduce', 1, 'constant']},
339 # State 6: unit -> '(' . unit ')'
343 FUNDAMENTAL => sh(4),
349 # State 7: topunit -> unit .
350 # unit -> unit . TIMES unit
351 # unit -> unit . DIVIDE unit
352 # unit -> unit . NUMBER
356 _ => ['reduce', 1, 'topunit'],
358 # State 8: unit -> constant . unit
361 NUMBER => sh(2), # Shift-reduce conflict resolved in favor of shift
363 FUNDAMENTAL => sh(4),
366 _ => ['reduce', 1, 'unit', \&unit_dimensionless],
370 # State 9: unit -> unit . TIMES unit
371 # unit -> unit . DIVIDE unit
372 # unit -> '(' unit . ')'
373 # unit -> unit . NUMBER
379 # State 10: unit -> unit NUMBER .
380 { _ => ['reduce', 2, 'unit',
382 unless (int($_[1]) == $_[1]) {
383 ABORT("Nonintegral power $_[1]");
390 # State 11: unit -> unit TIMES . unit
394 FUNDAMENTAL => sh(4),
400 # State 12: unit -> unit DIVIDE . unit
404 FUNDAMENTAL => sh(4),
410 # State 13: unit -> unit . TIMES unit
411 # unit -> unit . DIVIDE unit
412 # unit -> constant unit .
413 # unit -> unit . NUMBER
414 {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
415 TIMES => sh(11), # Shift-reduce conflict resolved in favor of shift
416 DIVIDE => sh(12), # Shift-reduce conflict resolved in favor of shift
417 _ => ['reduce', 2, 'unit', \&con_multiply],
419 # State 14: unit => '(' unit ')' .
420 { _ => ['reduce', 3, 'unit', sub {$_[1]}] },
421 # State 15: unit -> unit . TIMES unit
422 # unit -> unit TIMES unit .
423 # unit -> unit . DIVIDE unit
424 # unit -> unit . NUMBER
425 {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
426 _ => ['reduce', 3, 'unit', sub {unit_multiply($_[0], $_[2])}],
428 # State 16: unit -> unit . TIMES unit
429 # unit -> unit DIVIDE unit .
430 # unit -> unit . DIVIDE unit
431 # unit -> unit . NUMBER
432 {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
433 _ => ['reduce', 3, 'unit', sub{unit_divide($_[2], $_[0])}],
435 # State 17: Finishing path
437 # State 18: Final state
443 $PARSE_ERROR = shift;
448 my $tokens = lex($s);
450 my (@state_st, @val_st);
452 $PARSE_ERROR = undef;
454 # Now let's run the parser
456 return Zero if $PARSE_ERROR;
457 my $la = @$tokens ? token_type($tokens->[0]) : 'EOF';
458 print STDERR "Now in state $STATE. Lookahead type is $la.\n" if $DEBUG_p;
459 print STDERR "State stack is (@state_st).\n" if $DEBUG_p;
460 my $actiontab = $actions[$STATE];
461 my $action = $actiontab->{$la} || $actiontab->{_};
463 $PARSE_ERROR = 'Syntax error';
467 my ($primary, @actargs) = @$action;
468 print STDERR " $primary (@actargs)\n" if $DEBUG_p;
469 if ($primary eq 'accept') {
470 return $val_st[0]; # Success!
471 } elsif ($primary eq 'shift') {
472 my $token = shift @$tokens;
473 my $val = token_value($token);
475 push @state_st, $STATE;
476 $STATE = $actargs[0];
477 } elsif ($primary eq 'goto') {
478 $STATE = $actargs[0];
479 } elsif ($primary eq 'reduce') {
480 my ($n_args, $result_type, $semantic) = @actargs;
482 # push @state_st, 'FAKE'; # So that we only really remove n-1 states
484 push @arglist, pop @val_st;
485 $STATE = pop @state_st;
487 my $result = $semantic ? &$semantic(@arglist) : $arglist[0];
488 push @val_st, $result;
489 push @state_st, $STATE;
490 # $STATE = $state_st[-1];
491 print STDERR "Post-reduction state is $STATE.\n" if $DEBUG_p;
493 # Now look for `goto' actions
494 my $goto = $actions[$STATE]{$result_type};
495 unless ($goto && $goto->[0] eq 'goto') {
496 &::ERROR("No post-reduction goto in state $STATE for $result_type.");
499 print STDERR "goto $goto->[1]\n" if $DEBUG_p;
502 &::ERROR("Bad primary $primary");
512 \*{3} # Special `new unit' symbol
514 | \s*(?:\/|\bper\b)\s* # Division
515 | \d*\.\d+(?:[eE]-?\d+)? # Decimal number
516 | \d+\|\d+ # Fraction
518 # | (?:$PREF)-? # Prefix (handle differently)
519 | [A-Za-z_][A-Za-z_.]* # identifier
522 @t = grep {$_ ne ''} @t; # Discard empty and all-white tokens
528 return $token->[0] if ref $token;
529 return $token if $token =~ /[()]/;
530 return TIMES if $token =~ /^\s+$/;
531 return FUNDAMENTAL if $token eq '***';
532 return DIVIDE if $token =~ /^\s*(\/|\bper\b)\s*$/;
533 return TIMES if $token eq '*' || $token eq '-';
534 return FRACTION if $token =~ /^\d+\|\d+$/;
535 return NUMBER if $token =~ /^[.\d]/;
536 # return PREFIX if $token =~ /^$PREF/o;
542 return $token if $token =~ /^([()*\/-]|\s*\bper\b\s*)$/;
543 if ($token =~ /(\d+)\|(\d+)/) {
545 ABORT("Zero denominator in fraction `$token'");
549 # } elsif ($token =~ /$PREF/o) {
551 # return 10**($PREF{$token});
553 return $token; # Perl takes care of the others.