src/Modules/Units.pl

   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.
   5
   6 package Units;
   7
   8 #$DEBUG_p = 1;
   9 #$DEBUG_o = 1;
  10 #$DEBUG_l = 1;
  11 my %unittab;                    # Definitions loaded here
  12
  13 # Metric prefixes.  These must be powers of ten or change the
  14 # token_value subroutine
  15 BEGIN {
  16   %PREF = (yocto => -24,
  17            zepto => -21,
  18            atto => -18,
  19            femto => -15,
  20            pico => -12,
  21            nano => -9,
  22            micro => -6,
  23 #             u => -6,
  24            milli => -3,
  25            centi => -2,
  26            deci => -1,
  27            deca => 1,
  28            deka => 1,
  29            hecto => 2,
  30            hect => 2,
  31            kilo => 3,
  32            myria => 4,
  33            mega => 6,
  34            giga => 9,
  35            tera => 12,
  36            peta => 15,
  37            exa => 18,
  38            yotta => 21,
  39            zetta => 24,
  40           );
  41   $PREF = join '|', sort {$PREF{$a} <=> $PREF{$b}} (keys %PREF);
  42 }
  43
  44
  45 ################################################################
  46 #
  47 # Main program here
  48 #
  49 ################################################################
  50
  51 { my $defs_read = 0;
  52   $defs_read += read_defs("$main::infobot_misc_dir/unittab");
  53
  54   unless ($defs_read) {
  55     &main::ERROR("Could not read any of the initialization files UNITTAB");
  56     return;
  57   }
  58 }
  59
  60 sub convertUnits {
  61   my ($from,$to) = @_;
  62
  63   # POWER HACK.
  64   $from =~ s/\^(\-?\d+)/$1/;
  65   $to   =~ s/\^(\-?\d+)/$1/;
  66   my %powers = (
  67         2       => 'squared?',
  68         3       => 'cubed?',
  69   );
  70   foreach (keys %powers) {
  71     $from =~ s/(\D+) $powers{$_}$/$1\Q$_/;
  72     $to   =~ s/(\D+) $powers{$_}$/$1\Q$_/;
  73   }
  74   # END OF POWER HACK.
  75
  76   ### FROM:
  77   trim($from);
  78   if ($from =~ s/^\s*\#\s*//) {
  79     if (definition_line($from)) {
  80       &main::DEBUG("Defined.");
  81     } else {
  82       &main::DEBUG("Error: $PARSE_ERROR.");
  83     }
  84     &main::DEBUG("FAILURE 1.");
  85     return;
  86   }
  87   unless ($from =~ /\S/) {
  88     &main::DEBUG("FAILURE 2");
  89     return;
  90   }
  91
  92   my $hu = parse_unit($from);
  93   if (is_Zero($hu)) {
  94     &main::DEBUG($PARSE_ERROR);
  95     &main::msg($main::who, $PARSE_ERROR);
  96     return;
  97   }
  98
  99   ### TO:
 100   my $wu;
 101   trim($to);
 102   redo unless $to =~ /\S/;
 103   $wu = parse_unit($to);
 104   if (is_Zero($wu)) {
 105     &main::DEBUG($PARSE_ERROR);
 106   }
 107
 108   my $quot = unit_divide($hu, $wu);
 109   if (is_dimensionless($quot)) {
 110     my $q = $quot->{_};
 111     if ($q == 0) {
 112         &main::performStrictReply("$to is an invalid unit?");
 113         return;
 114     }
 115     # yet another powers hack.
 116     $from =~ s/(\D+)(\d)/$1\^$2/g;
 117     $to   =~ s/(\D+)(\d)/$1\^$2/g;
 118
 119     &main::performStrictReply(sprintf("$from is approximately \002%.6g\002 $to", $q));
 120   } else {
 121     &main::performStrictReply("$from cannot be correctly converted to $to.");
 122
 123 #    print
 124 #      "conformability (Not the same dimension)\n",
 125 #      "\t", $from, " is ", text_unit($hu), "\n",
 126 #      "\t", $to, " is ", text_unit($wu), "\n",
 127 #      ;
 128   }
 129 }
 130
 131
 132 ################################################################
 133
 134 sub read_defs {
 135   my ($file) = @_;
 136   unless (open D, $file) {
 137     if ($show_file_loading) {
 138       print STDERR "Couldn't open file `$file': $!; skipping.\n";
 139     }
 140     return 0;
 141   }
 142   while (<D>) {
 143     s/\#.*$//;
 144     trim($_);
 145     next unless /\S/;
 146
 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";
 151     }
 152   }
 153   print STDERR "Loaded file `$file'.\n" if $show_file_loading;
 154   return 1;
 155 }
 156
 157 sub definition_line {
 158   my ($line) = @_;
 159   my ($name, $data) = split /\s+/, $line, 2;
 160   my $value = parse_unit($data);
 161   if (is_Zero($value)) {
 162     return;
 163   }
 164   if (is_fundamental($value)) {
 165     return $unittab{$name} = {_ => 1, $name => 1};
 166   } else {
 167     return $unittab{$name} = $value;
 168   }
 169 }
 170
 171 sub trim {
 172   $_[0] =~ s/\s+$//;
 173   $_[0] =~ s/^\s+//;
 174 }
 175
 176 sub Zero () { +{ _ => 0 } }
 177
 178 sub is_Zero {
 179   $_[0]{_} == 0;
 180 }
 181
 182 sub unit_lookup {
 183   my ($name) = @_;
 184   print STDERR "Looking up unit `$name'\n" if $DEBUG_l;
 185   return $unittab{$name} if exists $unittab{$name};
 186   if ($name =~ /s$/) {
 187     my $shortname = $name;
 188     $shortname =~ s/s$//;
 189     return $unittab{$shortname} if exists $unittab{$shortname};
 190   }
 191   my ($prefix, $rest) = ($name =~ /^($PREF-?)(.*)/o);
 192   unless ($prefix) {
 193     $PARSE_ERROR = "Unknown unit `$name'";
 194     return Zero;
 195   }
 196   my $base_unit = unit_lookup($rest); # Recursive
 197   con_multiply($base_unit, 10**$PREF{$prefix});
 198 }
 199
 200 sub unit_multiply {
 201   my ($a, $b) = @_;
 202   print STDERR "Multiplying @{[%$a]} by @{[%$b]}: \n" if $DEBUG_o;
 203   my $r = {%$a};
 204   $r->{_} *= $b->{_};
 205   my $u;
 206   for $u (keys %$b) {
 207     next if $u eq '_';
 208     $r->{$u} += $b->{$u};
 209   }
 210   print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
 211   $r;
 212 }
 213
 214 sub unit_divide {
 215   my ($a, $b) = @_;
 216   if ($b->{_} == 0) {
 217     &main::DEBUG("Division by zero error");
 218     return;
 219   }
 220   my $r = {%$a};
 221   $r->{_} /= $b->{_};
 222   my $u;
 223   for $u (keys %$b) {
 224     next if $u eq '_';
 225     $r->{$u} -= $b->{$u};
 226   }
 227   $r;
 228 }
 229
 230 sub unit_power {
 231   my ($p, $u) = @_;
 232   print STDERR "Raising unit @{[%$u]} to power $p.\n" if $DEBUG_o;
 233   my $r = {%$u};
 234   $r->{_} **= $p;
 235   my $d;
 236   for $d (keys %$r) {
 237     next if $d eq '_';
 238     $r->{$d} *= $p;
 239   }
 240   print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
 241   $r;
 242 }
 243
 244 sub unit_dimensionless {
 245   print "Turning $_[0] into a dimensionless unit.\n" if $DEBUG_o;
 246   return +{_ => $_[0]};
 247 }
 248
 249 sub con_multiply {
 250   my ($u, $c) = @_;
 251   print STDERR "Multiplying unit @{[%$u]} by constant $c.\n" if $DEBUG_o;
 252   my $r = {%$u};
 253   $r->{_} *= $c;
 254   print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
 255   $r;
 256 }
 257
 258 sub is_dimensionless {
 259   my ($r) = @_;
 260   my $u;
 261   for $u (keys %$r) {
 262     next if $u eq '_';
 263     return if $r->{$u} != 0;
 264   }
 265   return 1;
 266 }
 267
 268 # Generate bogus unit value that signals that a new fundamental unit
 269 # is being defined
 270 sub new_fundamental_unit {
 271   return +{__ => 'new', _ => 1};
 272 }
 273
 274 # Recognize this  bogus value when it appears again.
 275 sub is_fundamental {
 276   exists $_[0]{__};
 277 }
 278
 279 sub text_unit {
 280   my ($u) = @_;
 281   my (@pos, @neg);
 282   my $k;
 283   my $c = $u->{_};
 284   for $k (sort keys %$u) {
 285     next if $k eq '_';
 286     push @pos, $k if $u->{$k} > 0;
 287     push @neg, $k if $u->{$k} < 0;
 288   }
 289   my $text = ($c == 1 ? '' : $c);
 290   my $d;
 291   for $d (@pos) {
 292     my $e = $u->{$d};
 293     $text .= " $d";
 294     $text .= "^$e" if $e > 1;
 295   }
 296
 297   $text .= ' per' if @neg;
 298   for $d (@neg) {
 299     my $e = - $u->{$d};
 300     $text .= " $d";
 301     $text .= "^$e" if $e > 1;
 302   }
 303
 304   $text;
 305 }
 306 ################################################################
 307 #
 308 # I'm the parser
 309 #
 310
 311 BEGIN {
 312   sub sh { ['shift', $_[0]]  };
 313   sub go { ['goto', $_[0]] };
 314   @actions =
 315     (
 316      # Initial state
 317      {PREFIX => sh(1),
 318       NUMBER => sh(2),
 319       NAME   => sh(3),
 320       FUNDAMENTAL => sh(4),
 321       FRACTION => sh(5),
 322       '(' => sh(6),
 323       'unit' => go(7),
 324       'topunit' => go(17),
 325       'constant' => go(8),
 326      },
 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 ')'
 338      {PREFIX => sh(1),
 339       NUMBER => sh(2),
 340       NAME   => sh(3),
 341       FUNDAMENTAL => sh(4),
 342       FRACTION => sh(5),
 343       '(' => sh(6),
 344       'unit' => go(9),
 345       'constant' => go(8),
 346      },
 347      # State 7:   topunit -> unit .
 348      #            unit  ->  unit . TIMES unit
 349      #            unit  ->  unit . DIVIDE unit
 350      #            unit  ->  unit . NUMBER
 351      {NUMBER => sh(10),
 352       TIMES => sh(11),
 353       DIVIDE => sh(12),
 354       _ =>  ['reduce', 1, 'topunit'],
 355      },
 356      # State 8:   unit -> constant . unit
 357      #            unit -> constant .
 358      {PREFIX => sh(1),
 359       NUMBER => sh(2), # Shift-reduce conflict resolved in favor of shift
 360       NAME   => sh(3),
 361       FUNDAMENTAL => sh(4),
 362       FRACTION => sh(5),
 363       '(' => sh(6),
 364       _ =>   ['reduce', 1, 'unit', \&unit_dimensionless],
 365       'unit' => go(13),
 366       'constant' => go(8),
 367      },
 368      # State 9:   unit -> unit . TIMES unit
 369      #            unit -> unit . DIVIDE unit
 370      #            unit -> '(' unit . ')'
 371      #            unit -> unit . NUMBER
 372      {NUMBER => sh(10),
 373       TIMES => sh(11),
 374       DIVIDE => sh(12),
 375       ')' => sh(14),
 376      },
 377      # State 10:  unit -> unit NUMBER .
 378      { _ => ['reduce', 2, 'unit',
 379              sub {
 380                unless (int($_[1]) == $_[1]) {
 381                  ABORT("Nonintegral power $_[1]");
 382                  return Zero;
 383                }
 384                unit_power(@_);
 385              }
 386             ],
 387      },
 388      # State 11:  unit -> unit TIMES . unit
 389      {PREFIX => sh(1),
 390       NUMBER => sh(2),
 391       NAME   => sh(3),
 392       FUNDAMENTAL => sh(4),
 393       FRACTION => sh(5),
 394       '(' => sh(6),
 395       'unit' => go(15),
 396       'constant' => go(8),
 397      },
 398      # State 12:  unit -> unit DIVIDE . unit
 399      {PREFIX => sh(1),
 400       NUMBER => sh(2),
 401       NAME   => sh(3),
 402       FUNDAMENTAL => sh(4),
 403       FRACTION => sh(5),
 404       '(' => sh(6),
 405       'unit' => go(16),
 406       'constant' => go(8),
 407      },
 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],
 416      },
 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])}],
 425      },
 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])}],
 432      },
 433      # State 17: Finishing path
 434      {EOF => go(18),},
 435      # State 18: Final state
 436      {_ => ['accept']},
 437     );
 438 }
 439
 440 sub ABORT {
 441   $PARSE_ERROR = shift;
 442 }
 443
 444 sub parse_unit {
 445   my ($s) = @_;
 446   my $tokens = lex($s);
 447   my $STATE = 0;
 448   my (@state_st, @val_st);
 449
 450   $PARSE_ERROR = undef;
 451
 452   # Now let's run the parser
 453   for (;;) {
 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->{_};
 460     unless ($action) {
 461       $PARSE_ERROR = 'Syntax error';
 462       return Zero;
 463     }
 464
 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);
 472       push @val_st, $val;
 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;
 479       my @arglist;
 480 #      push @state_st, 'FAKE';  # So that we only really remove n-1 states
 481       while ($n_args--) {
 482         push @arglist, pop @val_st;
 483         $STATE = pop @state_st;
 484       }
 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;
 490
 491       # Now look for `goto' actions
 492       my $goto = $actions[$STATE]{$result_type};
 493       unless ($goto && $goto->[0] eq 'goto') {
 494         &main::ERROR("No post-reduction goto in state $STATE for $result_type.");
 495         return;
 496       }
 497       print STDERR "goto $goto->[1]\n" if $DEBUG_p;
 498       $STATE = $goto->[1];
 499     } else {
 500       &main::ERROR("Bad primary $primary");
 501       return;
 502     }
 503   }
 504 }
 505
 506
 507 sub lex {
 508   my ($s) = @_;
 509   my @t = split /(
 510                    \*{3}        # Special `new unit' symbol
 511                 |  [()*-]       # Symbol
 512                 |  \s*(?:\/|\bper\b)\s*      # Division
 513                 |  \d*\.\d+(?:[eE]-?\d+)? # Decimal number
 514                 |  \d+\|\d+     # Fraction
 515                 |  \d+          # Integer
 516 #                |  (?:$PREF)-?  # Prefix (handle differently)
 517                 |  [A-Za-z_][A-Za-z_.]* # identifier
 518                 |  \s+          # White space
 519                 )/ox, $s;
 520   @t = grep {$_ ne ''} @t;      # Discard empty and all-white tokens
 521   \@t;
 522 }
 523
 524 sub token_type {
 525   my ($token) = @_;
 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;
 535   return NAME;
 536 }
 537
 538 sub token_value {
 539   my ($token) = @_;
 540   return $token if $token =~ /^([()*\/-]|\s*\bper\b\s*)$/;
 541   if ($token =~ /(\d+)\|(\d+)/) {
 542     if ($2 == 0) {
 543       ABORT("Zero denominator in fraction `$token'");
 544       return 0;
 545     }
 546     return $1/$2;
 547 #  } elsif ($token =~ /$PREF/o) {
 548 #    $token =~ s/-$//;
 549 #    return 10**($PREF{$token});
 550   }
 551   return $token;                # Perl takes care of the others.
 552 }
 553
 554 1;