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.
11 my %unittab; # Definitions loaded here
13 # Metric prefixes. These must be powers of ten or change the
14 # token_value subroutine
16 %PREF = (yocto => -24,
41 $PREF = join '|', sort {$PREF{$a} <=> $PREF{$b}} (keys %PREF);
45 ################################################################
49 ################################################################
52 $defs_read += read_defs("$::bot_misc_dir/unittab");
55 &::ERROR("Could not read any of the initialization files UNITTAB");
64 $from =~ s/\^(\-?\d+)/$1/;
65 $to =~ s/\^(\-?\d+)/$1/;
70 foreach (keys %powers) {
71 $from =~ s/(\D+) $powers{$_}$/$1\Q$_/;
72 $to =~ s/(\D+) $powers{$_}$/$1\Q$_/;
78 if ($from =~ s/^\s*\#\s*//) {
79 if (definition_line($from)) {
82 &::DEBUG("Error: $PARSE_ERROR.");
84 &::DEBUG("FAILURE 1.");
87 unless ($from =~ /\S/) {
88 &::DEBUG("FAILURE 2");
92 my $hu = parse_unit($from);
94 &::DEBUG($PARSE_ERROR);
95 &::msg($::who, $PARSE_ERROR);
102 redo unless $to =~ /\S/;
103 $wu = parse_unit($to);
105 &::DEBUG($PARSE_ERROR);
108 my $quot = unit_divide($hu, $wu);
109 if (is_dimensionless($quot)) {
112 &::performStrictReply("$to is an invalid unit?");
115 # yet another powers hack.
116 $from =~ s/(\D+)(\d)/$1\^$2/g;
117 $to =~ s/(\D+)(\d)/$1\^$2/g;
119 &::performStrictReply(sprintf("$from is approximately \002%.6g\002 $to", $q));
121 &::performStrictReply("$from cannot be correctly converted to $to.");
124 # "conformability (Not the same dimension)\n",
125 # "\t", $from, " is ", text_unit($hu), "\n",
126 # "\t", $to, " is ", text_unit($wu), "\n",
132 ################################################################
136 unless (open D, $file) {
137 if ($show_file_loading) {
138 print STDERR "Couldn't open file `$file': $!; skipping.\n";
147 print ">>> $_\n" if $DEBUG_d;
148 my $r = definition_line($_);
149 unless (defined $r) {
150 warn "Error in line $. of $file: $PARSE_ERROR. Skipping.\n";
153 print STDERR "Loaded file `$file'.\n" if $show_file_loading;
157 sub definition_line {
159 my ($name, $data) = split /\s+/, $line, 2;
160 my $value = parse_unit($data);
161 if (is_Zero($value)) {
164 if (is_fundamental($value)) {
165 return $unittab{$name} = {_ => 1, $name => 1};
167 return $unittab{$name} = $value;
176 sub Zero () { +{ _ => 0 } }
184 print STDERR "Looking up unit `$name'\n" if $DEBUG_l;
185 return $unittab{$name} if exists $unittab{$name};
187 my $shortname = $name;
188 $shortname =~ s/s$//;
189 return $unittab{$shortname} if exists $unittab{$shortname};
191 my ($prefix, $rest) = ($name =~ /^($PREF-?)(.*)/o);
193 $PARSE_ERROR = "Unknown unit `$name'";
196 my $base_unit = unit_lookup($rest); # Recursive
197 con_multiply($base_unit, 10**$PREF{$prefix});
202 print STDERR "Multiplying @{[%$a]} by @{[%$b]}: \n" if $DEBUG_o;
208 $r->{$u} += $b->{$u};
210 print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
217 &::DEBUG("Division by zero error");
225 $r->{$u} -= $b->{$u};
232 print STDERR "Raising unit @{[%$u]} to power $p.\n" if $DEBUG_o;
240 print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
244 sub unit_dimensionless {
245 print "Turning $_[0] into a dimensionless unit.\n" if $DEBUG_o;
246 return +{_ => $_[0]};
251 print STDERR "Multiplying unit @{[%$u]} by constant $c.\n" if $DEBUG_o;
254 print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
258 sub is_dimensionless {
263 return if $r->{$u} != 0;
268 # Generate bogus unit value that signals that a new fundamental unit
270 sub new_fundamental_unit {
271 return +{__ => 'new', _ => 1};
274 # Recognize this bogus value when it appears again.
284 for $k (sort keys %$u) {
286 push @pos, $k if $u->{$k} > 0;
287 push @neg, $k if $u->{$k} < 0;
289 my $text = ($c == 1 ? '' : $c);
294 $text .= "^$e" if $e > 1;
297 $text .= ' per' if @neg;
301 $text .= "^$e" if $e > 1;
306 ################################################################
312 sub sh { ['shift', $_[0]] };
313 sub go { ['goto', $_[0]] };
320 FUNDAMENTAL => sh(4),
327 # State 1: constant -> PREFIX .
328 { _ => ['reduce', 1, 'constant']},
329 # State 2: constant -> NUMBER .
330 { _ => ['reduce', 1, 'constant']},
331 # State 3: unit -> NAME .
332 { _ => ['reduce', 1, 'unit', \&unit_lookup ]},
333 # State 4: unit -> FUNDAMENTAL .
334 { _ => ['reduce', 1, 'unit', \&new_fundamental_unit ]},
335 # State 5: constant -> FRACTION .
336 { _ => ['reduce', 1, 'constant']},
337 # State 6: unit -> '(' . unit ')'
341 FUNDAMENTAL => sh(4),
347 # State 7: topunit -> unit .
348 # unit -> unit . TIMES unit
349 # unit -> unit . DIVIDE unit
350 # unit -> unit . NUMBER
354 _ => ['reduce', 1, 'topunit'],
356 # State 8: unit -> constant . unit
359 NUMBER => sh(2), # Shift-reduce conflict resolved in favor of shift
361 FUNDAMENTAL => sh(4),
364 _ => ['reduce', 1, 'unit', \&unit_dimensionless],
368 # State 9: unit -> unit . TIMES unit
369 # unit -> unit . DIVIDE unit
370 # unit -> '(' unit . ')'
371 # unit -> unit . NUMBER
377 # State 10: unit -> unit NUMBER .
378 { _ => ['reduce', 2, 'unit',
380 unless (int($_[1]) == $_[1]) {
381 ABORT("Nonintegral power $_[1]");
388 # State 11: unit -> unit TIMES . unit
392 FUNDAMENTAL => sh(4),
398 # State 12: unit -> unit DIVIDE . unit
402 FUNDAMENTAL => sh(4),
408 # State 13: unit -> unit . TIMES unit
409 # unit -> unit . DIVIDE unit
410 # unit -> constant unit .
411 # unit -> unit . NUMBER
412 {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
413 TIMES => sh(11), # Shift-reduce conflict resolved in favor of shift
414 DIVIDE => sh(12), # Shift-reduce conflict resolved in favor of shift
415 _ => ['reduce', 2, 'unit', \&con_multiply],
417 # State 14: unit => '(' unit ')' .
418 { _ => ['reduce', 3, 'unit', sub {$_[1]}] },
419 # State 15: unit -> unit . TIMES unit
420 # unit -> unit TIMES unit .
421 # unit -> unit . DIVIDE unit
422 # unit -> unit . NUMBER
423 {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
424 _ => ['reduce', 3, 'unit', sub {unit_multiply($_[0], $_[2])}],
426 # State 16: unit -> unit . TIMES unit
427 # unit -> unit DIVIDE unit .
428 # unit -> unit . DIVIDE unit
429 # unit -> unit . NUMBER
430 {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
431 _ => ['reduce', 3, 'unit', sub{unit_divide($_[2], $_[0])}],
433 # State 17: Finishing path
435 # State 18: Final state
441 $PARSE_ERROR = shift;
446 my $tokens = lex($s);
448 my (@state_st, @val_st);
450 $PARSE_ERROR = undef;
452 # Now let's run the parser
454 return Zero if $PARSE_ERROR;
455 my $la = @$tokens ? token_type($tokens->[0]) : 'EOF';
456 print STDERR "Now in state $STATE. Lookahead type is $la.\n" if $DEBUG_p;
457 print STDERR "State stack is (@state_st).\n" if $DEBUG_p;
458 my $actiontab = $actions[$STATE];
459 my $action = $actiontab->{$la} || $actiontab->{_};
461 $PARSE_ERROR = 'Syntax error';
465 my ($primary, @actargs) = @$action;
466 print STDERR " $primary (@actargs)\n" if $DEBUG_p;
467 if ($primary eq 'accept') {
468 return $val_st[0]; # Success!
469 } elsif ($primary eq 'shift') {
470 my $token = shift @$tokens;
471 my $val = token_value($token);
473 push @state_st, $STATE;
474 $STATE = $actargs[0];
475 } elsif ($primary eq 'goto') {
476 $STATE = $actargs[0];
477 } elsif ($primary eq 'reduce') {
478 my ($n_args, $result_type, $semantic) = @actargs;
480 # push @state_st, 'FAKE'; # So that we only really remove n-1 states
482 push @arglist, pop @val_st;
483 $STATE = pop @state_st;
485 my $result = $semantic ? &$semantic(@arglist) : $arglist[0];
486 push @val_st, $result;
487 push @state_st, $STATE;
488 # $STATE = $state_st[-1];
489 print STDERR "Post-reduction state is $STATE.\n" if $DEBUG_p;
491 # Now look for `goto' actions
492 my $goto = $actions[$STATE]{$result_type};
493 unless ($goto && $goto->[0] eq 'goto') {
494 &::ERROR("No post-reduction goto in state $STATE for $result_type.");
497 print STDERR "goto $goto->[1]\n" if $DEBUG_p;
500 &::ERROR("Bad primary $primary");
510 \*{3} # Special `new unit' symbol
512 | \s*(?:\/|\bper\b)\s* # Division
513 | \d*\.\d+(?:[eE]-?\d+)? # Decimal number
514 | \d+\|\d+ # Fraction
516 # | (?:$PREF)-? # Prefix (handle differently)
517 | [A-Za-z_][A-Za-z_.]* # identifier
520 @t = grep {$_ ne ''} @t; # Discard empty and all-white tokens
526 return $token->[0] if ref $token;
527 return $token if $token =~ /[()]/;
528 return TIMES if $token =~ /^\s+$/;
529 return FUNDAMENTAL if $token eq '***';
530 return DIVIDE if $token =~ /^\s*(\/|\bper\b)\s*$/;
531 return TIMES if $token eq '*' || $token eq '-';
532 return FRACTION if $token =~ /^\d+\|\d+$/;
533 return NUMBER if $token =~ /^[.\d]/;
534 # return PREFIX if $token =~ /^$PREF/o;
540 return $token if $token =~ /^([()*\/-]|\s*\bper\b\s*)$/;
541 if ($token =~ /(\d+)\|(\d+)/) {
543 ABORT("Zero denominator in fraction `$token'");
547 # } elsif ($token =~ /$PREF/o) {
549 # return 10**($PREF{$token});
551 return $token; # Perl takes care of the others.