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