lisp/calc/calc-units.el

   1 ;;; calc-units.el --- unit conversion functions for Calc
   2
   3 ;; Copyright (C) 1990-1993, 2001-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: David Gillespie <daveg@synaptics.com>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 ;; This file is autoloaded from calc-ext.el.
  27
  28 (require 'calc-ext)
  29 (require 'calc-macs)
  30 (eval-when-compile
  31   (require 'calc-alg))
  32
  33 ;;; Units operations.
  34
  35 ;;; Units table last updated 9-Jan-91 by Ulrich Mueller (ulm@vsnhd1.cern.ch)
  36 ;;; with some additions by Przemek Klosowski (przemek@rrdstrad.nist.gov)
  37 ;;; Updated April 2002 by Jochen Küpper
  38
  39 ;;; Updated August 2007, using
  40 ;;;     CODATA (http://physics.nist.gov/cuu/Constants/index.html)
  41 ;;;     NIST   (http://physics.nist.gov/Pubs/SP811/appenB9.html)
  42 ;;;     ESUWM  (Encyclopaedia of Scientific Units, Weights and
  43 ;;;             Measures, by François Cardarelli)
  44 ;;; All conversions are exact unless otherwise noted.
  45
  46 ;; CODATA values updated February 2016, using 2014 adjustment
  47 ;; http://arxiv.org/pdf/1507.07956.pdf
  48
  49 (defvar math-standard-units
  50   '( ;; Length
  51     ( m       nil                    "*Meter" )
  52     ( in      "254*10^(-2) cm"       "Inch"  nil
  53               "2.54 cm")
  54     ( ft      "12 in"                "Foot")
  55     ( yd      "3 ft"                 "Yard" )
  56     ( mi      "5280 ft"              "Mile" )
  57     ( au      "149597870691. m"      "Astronomical Unit" nil
  58               "149597870691 m (*)")
  59               ;; (approx) NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html)
  60     ( lyr     "c yr"                 "Light Year" )
  61     ( pc      "3.0856775854*10^16 m" "Parsec  (**)" nil
  62               "3.0856775854 10^16 m (*)") ;; (approx) ESUWM
  63     ( nmi     "1852 m"               "Nautical Mile" )
  64     ( fath    "6 ft"                 "Fathom" )
  65     ( fur     "660 ft"               "Furlong")
  66     ( mu      "1 um"                 "Micron" )
  67     ( mil     "(1/1000) in"          "Mil" )
  68     ( point   "(1/72) in"            "Point  (PostScript convention)" )
  69     ( Ang     "10^(-10) m"           "Angstrom" )
  70     ( mfi     "mi+ft+in"             "Miles + feet + inches" )
  71     ;; TeX lengths
  72     ( texpt   "(100/7227) in"        "Point  (TeX convention) (**)" )
  73     ( texpc   "12 texpt"             "Pica  (TeX convention) (**)" )
  74     ( texbp   "point"                "Big point  (TeX convention) (**)" )
  75     ( texdd   "(1238/1157) texpt"    "Didot point  (TeX convention) (**)" )
  76     ( texcc   "12 texdd"             "Cicero  (TeX convention) (**)" )
  77     ( texsp   "(1/65536) texpt"      "Scaled TeX point (TeX convention) (**)" )
  78
  79     ;; Area
  80     ( hect    "10000 m^2"            "*Hectare" )
  81     ( a       "100 m^2"              "Are")
  82     ( acre    "(1/640) mi^2"         "Acre" )
  83     ( b       "10^(-28) m^2"         "Barn" )
  84
  85     ;; Volume
  86     ( L       "10^(-3) m^3"          "*Liter" )
  87     ( l       "L"                    "Liter" )
  88     ( gal     "4 qt"                 "US Gallon" )
  89     ( qt      "2 pt"                 "Quart" )
  90     ( pt      "2 cup"                "Pint (**)" )
  91     ( cup     "8 ozfl"               "Cup" )
  92     ( ozfl    "2 tbsp"               "Fluid Ounce" )
  93     ( floz    "2 tbsp"               "Fluid Ounce" )
  94     ( tbsp    "3 tsp"                "Tablespoon" )
  95     ;; ESUWM defines a US gallon as 231 in^3.
  96     ;; That gives the following exact value for tsp.
  97     ( tsp     "492892159375*10^(-11) ml" "Teaspoon" nil
  98               "4.92892159375 ml")
  99     ( vol     "tsp+tbsp+ozfl+cup+pt+qt+gal" "Gallons + ... + teaspoons" nil
 100               "tsp+tbsp+ozfl+cup+pt+qt+gal")
 101     ( galC    "galUK"                "Canadian Gallon" )
 102     ( galUK   "454609*10^(-5) L"     "UK Gallon" nil
 103               "4.54609 L") ;; NIST
 104
 105     ;; Time
 106     ( s       nil                    "*Second" )
 107     ( sec     "s"                    "Second" )
 108     ( min     "60 s"                 "Minute" )
 109     ( hr      "60 min"               "Hour" )
 110     ( day     "24 hr"                "Day" )
 111     ( wk      "7 day"                "Week" )
 112     ( hms     "wk+day+hr+min+s"      "Hours, minutes, seconds" )
 113     ( yr      "36525*10^(-2) day"    "Year (Julian)" nil
 114               "365.25 day")
 115     ( Hz      "1/s"                  "Hertz" )
 116
 117     ;; Speed
 118     ( mph     "mi/hr"                "*Miles per hour" )
 119     ( kph     "km/hr"                "Kilometers per hour" )
 120     ( knot    "nmi/hr"               "Knot" )
 121     ( c       "299792458 m/s"        "Speed of light" ) ;;; CODATA
 122
 123     ;; Acceleration
 124     ( ga      "980665*10^(-5) m/s^2" "*\"g\" acceleration" nil
 125               "9.80665 m / s^2") ;; CODATA
 126
 127     ;; Mass
 128     ( g       nil                    "*Gram" )
 129     ( lb      "16 oz"                "Pound (mass)" )
 130     ( oz      "28349523125*10^(-9) g" "Ounce (mass)" nil
 131               "28.349523125 g") ;; ESUWM
 132     ( ton     "2000 lb"              "Ton" )
 133     ( tpo     "ton+lb+oz"            "Tons + pounds + ounces (mass)" )
 134     ( t       "1000 kg"              "Metric ton" )
 135     ( tonUK   "10160469088*10^(-7) kg" "UK ton" nil
 136               "1016.0469088 kg") ;; ESUWM
 137     ( lbt     "12 ozt"               "Troy pound" )
 138     ( ozt     "311034768*10^(-7) g"        "Troy ounce" nil
 139               "31.10347680 g") ;; ESUWM, 1/12 exact value for lbt
 140     ( ct      "(2/10) g"             "Carat" nil
 141               "0.2 g") ;; ESUWM
 142     ( u       "1.660539040*10^(-27) kg"    "Unified atomic mass" nil
 143               "1.660539040 10^-27 kg (*)");;(approx) CODATA
 144
 145     ;; Force
 146     ( N       "m kg/s^2"             "*Newton" )
 147     ( dyn     "10^(-5) N"            "Dyne" )
 148     ( gf      "ga g"                 "Gram (force)" )
 149     ( lbf     "ga lb"                "Pound (force)" )
 150     ( kip     "1000 lbf"             "Kilopound (force)" )
 151     ( pdl     "138254954376*10^(-12) N" "Poundal" nil
 152               "0.138254954376 N") ;; ESUWM
 153
 154     ;; Energy
 155     ( J       "N m"                  "*Joule" )
 156     ( erg     "10^(-7) J"            "Erg" )
 157     ( cal     "41868*10^(-4) J"      "International Table Calorie" nil
 158               "4.1868 J") ;; NIST
 159     ( calth   "4184*10^(-3) J"       "Thermochemical Calorie" nil
 160               "4.184 J") ;; NIST
 161     ( Cal     "1000 cal"             "Large Calorie")
 162     ( Btu     "105505585262*10^(-8) J" "International Table Btu" nil
 163               "1055.05585262 J") ;; ESUWM
 164     ( eV      "ech V"                "Electron volt" )
 165     ( ev      "eV"                   "Electron volt" )
 166     ( therm   "105506000 J"          "EEC therm" )
 167     ( invcm   "h c/cm"               "Energy in inverse centimeters" )
 168     ( Kayser  "invcm"                "Kayser (inverse centimeter energy)" )
 169     ( men     "100/invcm"            "Inverse energy in meters" )
 170     ( Hzen    "h Hz"                 "Energy in Hertz")
 171     ( Ken     "k K"                  "Energy in Kelvins")
 172     ( Wh      "W hr"                 "Watt hour")
 173     ( Ws      "W s"                  "Watt second")
 174
 175     ;; Power
 176     ( W       "J/s"                  "*Watt" )
 177     ( hp      "550 ft lbf/s"         "Horsepower") ;;ESUWM
 178     ( hpm     "75 m kgf/s"           "Metric Horsepower") ;;ESUWM
 179
 180     ;; Temperature
 181     ( K       nil                    "*Degree Kelvin"     K )
 182     ( dK      "K"                    "Degree Kelvin"      K )
 183     ( degK    "K"                    "Degree Kelvin"      K )
 184     ( dC      "K"                    "Degree Celsius"     C )
 185     ( degC    "K"                    "Degree Celsius"     C )
 186     ( dF      "(5/9) K"              "Degree Fahrenheit"  F )
 187     ( degF    "(5/9) K"              "Degree Fahrenheit"  F )
 188
 189     ;; Pressure
 190     ( Pa      "N/m^2"                "*Pascal" )
 191     ( bar     "10^5 Pa"              "Bar" )
 192     ( atm     "101325 Pa"            "Standard atmosphere" ) ;; CODATA
 193     ( Torr    "(1/760) atm"          "Torr")
 194     ( mHg     "1000 Torr"            "Meter of mercury" )
 195     ( inHg    "254*10^(-1) mmHg"     "Inch of mercury" nil
 196               "25.4 mmHg")
 197     ( inH2O   "2.490889*10^2 Pa"        "Inch of water" nil
 198               "2.490889 10^2 Pa (*)") ;;(approx) NIST
 199     ( psi     "lbf/in^2"             "Pounds per square inch" )
 200
 201     ;; Viscosity
 202     ( P       "(1/10) Pa s"           "*Poise" )
 203     ( St      "10^(-4) m^2/s"         "Stokes" )
 204
 205     ;; Electromagnetism
 206     ( A       nil                     "*Ampere" )
 207     ( C       "A s"                   "Coulomb" )
 208     ( Fdy     "ech Nav"               "Faraday" )
 209     ( e       "ech"                   "Elementary charge" )
 210     ( ech     "1.6021766208*10^(-19) C"     "Elementary charge" nil
 211               "1.6021766208 10^-19 C (*)") ;;(approx) CODATA
 212     ( V       "W/A"                   "Volt" )
 213     ( ohm     "V/A"                   "Ohm" )
 214     ( Ω       "ohm"                   "Ohm" )
 215     ( mho     "A/V"                   "Mho" )
 216     ( S       "A/V"                   "Siemens" )
 217     ( F       "C/V"                   "Farad" )
 218     ( H       "Wb/A"                  "Henry" )
 219     ( T       "Wb/m^2"                "Tesla" )
 220     ( Gs      "10^(-4) T"             "Gauss" )
 221     ( Wb      "V s"                   "Weber" )
 222
 223     ;; Luminous intensity
 224     ( cd      nil                     "*Candela" )
 225     ( sb      "10000 cd/m^2"          "Stilb" )
 226     ( lm      "cd sr"                 "Lumen" )
 227     ( lx      "lm/m^2"                "Lux" )
 228     ( ph      "10000 lx"              "Phot" )
 229     ( fc      "lm/ft^2"               "Footcandle") ;; ESUWM
 230     ( lam     "10000 lm/m^2"          "Lambert" )
 231     ( flam    "(1/pi) cd/ft^2"        "Footlambert") ;; ESUWM
 232
 233     ;; Radioactivity
 234     ( Bq      "1/s"                    "*Becquerel" )
 235     ( Ci      "37*10^9 Bq"             "Curie" ) ;; ESUWM
 236     ( Gy      "J/kg"                   "Gray" )
 237     ( Sv      "Gy"                     "Sievert" )
 238     ( R       "258*10^(-6) C/kg"       "Roentgen" ) ;; NIST
 239     ( rd      "(1/100) Gy"             "Rad" )
 240     ( rem     "rd"                     "Rem" )
 241
 242     ;; Amount of substance
 243     ( mol     nil                      "*Mole" )
 244
 245     ;; Plane angle
 246     ( rad     nil                      "*Radian" )
 247     ( circ    "2 pi rad"               "Full circle" )
 248     ( rev     "circ"                   "Full revolution" )
 249     ( deg     "circ/360"               "Degree" )
 250     ( arcmin  "deg/60"                 "Arc minute" )
 251     ( arcsec  "arcmin/60"              "Arc second" )
 252     ( grad    "circ/400"               "Grade" )
 253     ( rpm     "rev/min"                "Revolutions per minute" )
 254
 255     ;; Solid angle
 256     ( sr      nil                      "*Steradian" )
 257
 258     ;; Other physical quantities
 259     ;; The values are from CODATA, and are approximate.
 260     ( h       "6.626070040*10^(-34) J s"     "*Planck's constant" nil
 261               "6.626070040 10^-34 J s (*)")
 262     ( hbar    "h / (2 pi)"                  "Planck's constant" ) ;; Exact
 263     ( mu0     "4 pi 10^(-7) H/m"            "Permeability of vacuum") ;; Exact
 264     ( μ0      "mu0"                         "Permeability of vacuum") ;; Exact
 265     ( eps0    "1 / (mu0 c^2)"               "Permittivity of vacuum" )
 266     ( ε0      "eps0"                        "Permittivity of vacuum" )
 267     ( G       "6.67408*10^(-11) m^3/(kg s^2)"    "Gravitational constant" nil
 268               "6.67408 10^-11 m^3/(kg s^2) (*)")
 269     ( Nav     "6.022140857*10^(23) / mol"    "Avogadro's constant" nil
 270               "6.022140857 10^23 / mol (*)")
 271     ( me      "9.10938356*10^(-31) kg"      "Electron rest mass" nil
 272               "9.10938356 10^-31 kg (*)")
 273     ( mp      "1.672621898*10^(-27) kg"     "Proton rest mass" nil
 274               "1.672621898 10^-27 kg (*)")
 275     ( mn      "1.674927471*10^(-27) kg"     "Neutron rest mass" nil
 276               "1.674927471 10^-27 kg (*)")
 277     ( mmu     "1.883531594*10^(-28) kg"      "Muon rest mass" nil
 278               "1.883531594 10^-28 kg (*)")
 279     ( mμ      "mmu"                         "Muon rest mass" nil
 280               "1.883531594 10^-28 kg (*)")
 281     ( Ryd     "10973731.568508 /m"          "Rydberg's constant" nil
 282               "10973731.568508 /m (*)")
 283     ( k       "1.38064852*10^(-23) J/K"      "Boltzmann's constant" nil
 284               "1.38064852 10^-23 J/K (*)")
 285     ( sigma   "5.670367*10^(-8) W/(m^2 K^4)" "Stefan-Boltzmann constant" nil
 286               "5.670367 10^-8 W/(m^2 K^4) (*)")
 287     ( σ       "sigma" "Stefan-Boltzmann constant" nil
 288               "5.670367 10^-8 W/(m^2 K^4) (*)")
 289     ( alpha   "7.2973525664*10^(-3)"        "Fine structure constant" nil
 290               "7.2973525664 10^-3 (*)")
 291     ( α       "alpha"                        "Fine structure constant" nil
 292               "7.2973525664 10^-3 (*)")
 293     ( muB     "927.4009994*10^(-26) J/T"     "Bohr magneton" nil
 294               "927.4009994 10^-26 J/T (*)")
 295     ( muN     "5.050783699*10^(-27) J/T"     "Nuclear magneton" nil
 296               "5.050783699 10^-27 J/T (*)")
 297     ( mue     "-928.4764620*10^(-26) J/T"    "Electron magnetic moment" nil
 298               "-928.4764620 10^-26 J/T (*)")
 299     ( mup     "1.4106067873*10^(-26) J/T"    "Proton magnetic moment" nil
 300               "1.4106067873 10^-26 J/T (*)")
 301     ( R0      "8.3144598 J/(mol K)"          "Molar gas constant" nil
 302               "8.3144598 J/(mol K) (*)")
 303     ( V0      "22.710947*10^(-3) m^3/mol"   "Standard volume of ideal gas" nil
 304               "22.710947 10^-3 m^3/mol (*)")
 305     ;; Logarithmic units
 306     ( Np      nil    "*Neper")
 307     ( dB      "(ln(10)/20) Np" "decibel")))
 308
 309
 310 (defvar math-additional-units nil
 311   "Additional units table for user-defined units.
 312 Must be formatted like `math-standard-units'.
 313 If you change this, be sure to set `math-units-table' to nil to ensure
 314 that the combined units table will be rebuilt.")
 315
 316 (defvar math-unit-prefixes
 317   '( ( ?Y  (^ 10 24)  "Yotta"  )
 318      ( ?Z  (^ 10 21)  "Zetta"  )
 319      ( ?E  (^ 10 18)  "Exa"    )
 320      ( ?P  (^ 10 15)  "Peta"   )
 321      ( ?T  (^ 10 12)  "Tera"   )
 322      ( ?G  (^ 10 9)   "Giga"   )
 323      ( ?M  (^ 10 6)   "Mega"   )
 324      ( ?k  (^ 10 3)   "Kilo"   )
 325      ( ?K  (^ 10 3)   "Kilo"   )
 326      ( ?h  (^ 10 2)   "Hecto"  )
 327      ( ?H  (^ 10 2)   "Hecto"  )
 328      ( ?D  (^ 10 1)   "Deka"   )
 329      ( 0   (^ 10 0)    nil     )
 330      ( ?d  (^ 10 -1)  "Deci"   )
 331      ( ?c  (^ 10 -2)  "Centi"  )
 332      ( ?m  (^ 10 -3)  "Milli"  )
 333      ( ?u  (^ 10 -6)  "Micro"  )
 334      ( ?μ  (^ 10 -6)  "Micro"  )
 335      ( ?n  (^ 10 -9)  "Nano"   )
 336      ( ?p  (^ 10 -12) "Pico"   )
 337      ( ?f  (^ 10 -15) "Femto"  )
 338      ( ?a  (^ 10 -18) "Atto"   )
 339      ( ?z  (^ 10 -21) "zepto"  )
 340      ( ?y  (^ 10 -24) "yocto"  )))
 341
 342 (defvar math-standard-units-systems
 343   '( ( base  nil )
 344      ( si    ( ( g   '(/ (var kg var-kg) 1000) ) ) )
 345      ( mks   ( ( g   '(/ (var kg var-kg) 1000) ) ) )
 346      ( cgs   ( ( m   '(* (var cm var-cm) 100 ) ) ) )))
 347
 348 (defvar math-units-table nil
 349   "Internal units table.
 350 Derived from `math-standard-units' and `math-additional-units'.
 351 Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).")
 352
 353 (defvar math-units-table-buffer-valid nil)
 354
 355 ;;; Units commands.
 356
 357 (defun calc-base-units ()
 358   (interactive)
 359   (calc-slow-wrapper
 360    (let ((calc-autorange-units nil))
 361      (calc-enter-result 1 "bsun" (math-simplify-units
 362                                   (math-to-standard-units (calc-top-n 1)
 363                                                           nil))))))
 364
 365 (defvar calc-ensure-consistent-units)
 366
 367 (defun calc-quick-units ()
 368   (interactive)
 369   (calc-slow-wrapper
 370    (let* ((num (- last-command-event ?0))
 371           (pos (if (= num 0) 10 num))
 372           (units (calc-var-value 'var-Units))
 373           (expr (calc-top-n 1)))
 374      (unless (and (>= num 0) (<= num 9))
 375        (error "Bad unit number"))
 376      (unless (math-vectorp units)
 377        (error "No \"quick units\" are defined"))
 378      (unless (< pos (length units))
 379        (error "Unit number %d not defined" pos))
 380      (if (math-units-in-expr-p expr nil)
 381          (progn
 382            (if calc-ensure-consistent-units
 383                (math-check-unit-consistency expr (nth pos units)))
 384            (calc-enter-result 1 (format "cun%d" num)
 385                               (math-convert-units expr (nth pos units))))
 386        (calc-enter-result 1 (format "*un%d" num)
 387                           (math-simplify-units
 388                            (math-mul expr (nth pos units))))))))
 389
 390 (defun math-get-standard-units (expr)
 391   "Return the standard units in EXPR."
 392   (math-simplify-units
 393    (math-extract-units
 394     (math-to-standard-units expr nil))))
 395
 396 (defun math-get-units (expr)
 397   "Return the units in EXPR."
 398   (math-simplify-units
 399    (math-extract-units expr)))
 400
 401 (defun math-make-unit-string (expr)
 402   "Return EXPR in string form.
 403 If EXPR is nil, return nil."
 404   (if expr
 405       (let ((cexpr (math-compose-expr expr 0)))
 406         (replace-regexp-in-string
 407          " / " "/"
 408          (if (stringp cexpr)
 409              cexpr
 410            (math-composition-to-string cexpr))))))
 411
 412 (defvar math-default-units-table
 413   (make-hash-table :test 'equal)
 414   "A table storing previously converted units.")
 415
 416 (defun math-get-default-units (expr)
 417   "Get default units to use when converting the units in EXPR."
 418   (let* ((units (math-get-units expr))
 419          (standard-units (math-get-standard-units expr))
 420          (default-units (gethash
 421                          standard-units
 422                          math-default-units-table)))
 423     (if (equal units (car default-units))
 424         (math-make-unit-string (cadr default-units))
 425       (math-make-unit-string (car default-units)))))
 426
 427 (defun math-put-default-units (expr &optional comp std)
 428   "Put the units in EXPR in the default units table.
 429 If COMP or STD is non-nil, put that in the units table instead."
 430   (let* ((new-units (or comp std (math-get-units expr)))
 431          (standard-units (math-get-standard-units
 432                           (cond
 433                            (comp (math-simplify-units expr))
 434                            (std expr)
 435                            (t new-units))))
 436          (default-units (gethash standard-units math-default-units-table)))
 437     (unless (eq standard-units 1)
 438       (cond
 439        ((not default-units)
 440         (puthash standard-units (list new-units) math-default-units-table))
 441        ((not (equal new-units (car default-units)))
 442         (puthash standard-units
 443                  (list new-units (car default-units))
 444                  math-default-units-table))))))
 445
 446 (defvar calc-allow-units-as-numbers t)
 447
 448 (defun calc-convert-units (&optional old-units new-units)
 449   (interactive)
 450   (calc-slow-wrapper
 451    (let ((expr (calc-top-n 1))
 452          (uoldname nil)
 453          (unitscancel nil)
 454          (nouold nil)
 455          unew
 456          units
 457          defunits)
 458      (if (or (not (math-units-in-expr-p expr t))
 459              (setq unitscancel (and
 460                                 (if (get 'calc-allow-units-as-numbers 'saved-value)
 461                                     (car (get 'calc-allow-units-as-numbers 'saved-value))
 462                                   calc-allow-units-as-numbers)
 463                                 (eq (math-get-standard-units expr) 1))))
 464        (let ((uold (or old-units
 465                        (progn
 466                          (setq uoldname
 467                                (if unitscancel
 468                                    (read-string
 469                                     "(The expression is unitless when simplified) Old Units: ")
 470                                  (read-string "Old units: ")))
 471                          (if (equal uoldname "")
 472                              (progn
 473                                (setq nouold unitscancel)
 474                                (setq uoldname "1")
 475                                1)
 476                            (if (string-match "\\` */" uoldname)
 477                                (setq uoldname (concat "1" uoldname)))
 478                            (math-read-expr uoldname))))))
 479          (unless (math-units-in-expr-p uold t)
 480            (error "No units specified"))
 481          (when (eq (car-safe uold) 'error)
 482            (error "Bad format in units expression: %s" (nth 1 uold)))
 483          (setq expr (math-mul expr uold))))
 484      (setq defunits (math-get-default-units expr))
 485      (unless new-units
 486        (setq new-units
 487              (read-string (concat
 488                            (if (and uoldname (not nouold))
 489                                (concat "Old units: "
 490                                        uoldname
 491                                        ", new units")
 492                              "New units")
 493                            (if defunits
 494                                (concat
 495                                 " (default "
 496                                 defunits
 497                                 "): ")
 498                              ": "))))
 499        (if (and
 500             (string= new-units "")
 501             defunits)
 502            (setq new-units defunits)))
 503      (when (string-match "\\` */" new-units)
 504        (setq new-units (concat "1" new-units)))
 505      (setq units (math-read-expr new-units))
 506      (when (eq (car-safe units) 'error)
 507        (error "Bad format in units expression: %s" (nth 2 units)))
 508      (if calc-ensure-consistent-units
 509          (math-check-unit-consistency expr units))
 510      (let ((unew (math-units-in-expr-p units t))
 511            (std (and (eq (car-safe units) 'var)
 512                      (assq (nth 1 units) math-standard-units-systems)))
 513            (comp (eq (car-safe units) '+)))
 514        (unless (or unew std)
 515          (error "No units specified"))
 516        (let* ((noold (and uoldname (not (equal uoldname "1"))))
 517               (res
 518                (if std
 519                    (math-simplify-units (math-to-standard-units expr (nth 1 std)))
 520                  (math-convert-units expr units noold))))
 521          (unless std
 522            (math-put-default-units (if noold units res) (if comp units)))
 523          (calc-enter-result 1 "cvun" res))))))
 524
 525 (defun calc-convert-exact-units ()
 526   (interactive)
 527   (calc-slow-wrapper
 528    (let* ((expr (calc-top-n 1)))
 529      (unless (math-units-in-expr-p expr t)
 530        (error "No units in expression."))
 531      (let* ((old-units (math-extract-units expr))
 532             (defunits (math-get-default-units expr))
 533             units
 534             (new-units
 535              (read-string (concat "New units"
 536                                   (if defunits
 537                                      (concat
 538                                       " (default "
 539                                       defunits
 540                                       "): ")
 541                                    ": ")))))
 542        (if (and
 543             (string= new-units "")
 544             defunits)
 545            (setq new-units defunits))
 546        (setq units (math-read-expr new-units))
 547        (when (eq (car-safe units) 'error)
 548          (error "Bad format in units expression: %s" (nth 2 units)))
 549        (math-check-unit-consistency old-units units)
 550        (let ((res
 551               (list '* (math-mul (math-remove-units expr)
 552                                  (math-simplify-units
 553                                   (math-to-standard-units (list '/ old-units units) nil)))
 554                     units)))
 555          (calc-enter-result 1 "cvxu" res))))))
 556
 557 (defun calc-autorange-units (arg)
 558   (interactive "P")
 559   (calc-wrapper
 560    (calc-change-mode 'calc-autorange-units arg nil t)
 561    (message (if calc-autorange-units
 562                 "Adjusting target unit prefix automatically"
 563               "Using target units exactly"))))
 564
 565 (defun calc-convert-temperature (&optional old-units new-units)
 566   (interactive)
 567   (calc-slow-wrapper
 568    (let ((tempunits (delq nil
 569                           (mapcar
 570                            (lambda (x)
 571                              (if (nth 3 x) (car x)))
 572                            math-standard-units)))
 573          (expr (calc-top-n 1))
 574          (uold nil)
 575          (uoldname nil)
 576          unew
 577          defunits)
 578      (setq uold (or old-units
 579                     (let ((units (math-single-units-in-expr-p expr)))
 580                       (if units
 581                           (if (consp units)
 582                               (list 'var (car units)
 583                                     (intern (concat "var-"
 584                                                     (symbol-name
 585                                                      (car units)))))
 586                             (error "Not a pure temperature expression"))
 587                         (math-read-expr
 588                          (setq uoldname (completing-read
 589                                          "Old temperature units: "
 590                                          tempunits)))))))
 591      (when (eq (car-safe uold) 'error)
 592        (error "Bad format in units expression: %s" (nth 2 uold)))
 593      (or (math-units-in-expr-p expr nil)
 594          (setq expr (math-mul expr uold)))
 595      (setq defunits (math-get-default-units expr))
 596      (setq unew (or new-units
 597                     (completing-read
 598                      (concat
 599                       (if uoldname
 600                           (concat "Old temperature units: "
 601                                   uoldname
 602                                   ", new units")
 603                         "New temperature units")
 604                       (if defunits
 605                           (concat " (default "
 606                                   defunits
 607                                   "): ")
 608                         ": "))
 609                      tempunits)))
 610      (setq unew (math-read-expr (if (string= unew "") defunits unew)))
 611      (when (eq (car-safe unew) 'error)
 612        (error "Bad format in units expression: %s" (nth 2 unew)))
 613      (math-put-default-units unew)
 614      (let ((ntemp (calc-normalize
 615                    (math-simplify-units
 616                     (math-convert-temperature expr uold unew
 617                                               uoldname)))))
 618        (if (Math-zerop ntemp)
 619            (setq ntemp (list '* ntemp unew)))
 620        (let ((calc-simplify-mode 'none))
 621          (calc-enter-result 1 "cvtm" ntemp))))))
 622
 623 (defun calc-remove-units ()
 624   (interactive)
 625   (calc-slow-wrapper
 626    (calc-enter-result 1 "rmun" (math-simplify-units
 627                                 (math-remove-units (calc-top-n 1))))))
 628
 629 (defun calc-extract-units ()
 630   (interactive)
 631   (calc-slow-wrapper
 632    (calc-enter-result 1 "exun" (math-simplify-units
 633                                 (math-extract-units (calc-top-n 1))))))
 634
 635 ;; The variables calc-num-units and calc-den-units are local to
 636 ;; calc-explain-units, but are used by calc-explain-units-rec,
 637 ;; which is called by calc-explain-units.
 638 (defvar calc-num-units)
 639 (defvar calc-den-units)
 640
 641 (defun calc-explain-units ()
 642   (interactive)
 643   (calc-wrapper
 644    (let ((calc-num-units nil)
 645          (calc-den-units nil))
 646      (calc-explain-units-rec (calc-top-n 1) 1)
 647      (and calc-den-units (string-match "^[^(].* .*[^)]$" calc-den-units)
 648           (setq calc-den-units (concat "(" calc-den-units ")")))
 649      (if calc-num-units
 650          (if calc-den-units
 651              (message "%s per %s" calc-num-units calc-den-units)
 652            (message "%s" calc-num-units))
 653        (if calc-den-units
 654            (message "1 per %s" calc-den-units)
 655          (message "No units in expression"))))))
 656
 657 (defun calc-explain-units-rec (expr pow)
 658   (let ((u (math-check-unit-name expr))
 659         pos)
 660     (if (and u (not (math-zerop pow)))
 661         (let ((name (or (nth 2 u) (symbol-name (car u)))))
 662           (if (eq (aref name 0) ?\*)
 663               (setq name (substring name 1)))
 664           (if (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name)
 665               (if (string-match "^[a-zA-Zα-ωΑ-Ω0-9' ()]*$" name)
 666                   (while (setq pos (string-match "[ ()]" name))
 667                     (setq name (concat (substring name 0 pos)
 668                                        (if (eq (aref name pos) 32) "-" "")
 669                                        (substring name (1+ pos)))))
 670                 (setq name (concat "(" name ")"))))
 671           (or (eq (nth 1 expr) (car u))
 672               (setq name (concat (nth 2 (assq (aref (symbol-name
 673                                                      (nth 1 expr)) 0)
 674                                               math-unit-prefixes))
 675                                  (if (and (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name)
 676                                           (not (memq (car u) '(mHg gf))))
 677                                      (concat "-" name)
 678                                    (downcase name)))))
 679           (cond ((or (math-equal-int pow 1)
 680                      (math-equal-int pow -1)))
 681                 ((or (math-equal-int pow 2)
 682                      (math-equal-int pow -2))
 683                  (if (equal (nth 4 u) '((m . 1)))
 684                      (setq name (concat "Square-" name))
 685                    (setq name (concat name "-squared"))))
 686                 ((or (math-equal-int pow 3)
 687                      (math-equal-int pow -3))
 688                  (if (equal (nth 4 u) '((m . 1)))
 689                      (setq name (concat "Cubic-" name))
 690                    (setq name (concat name "-cubed"))))
 691                 (t
 692                  (setq name (concat name "^"
 693                                     (math-format-number (math-abs pow))))))
 694           (if (math-posp pow)
 695               (setq calc-num-units (if calc-num-units
 696                                   (concat calc-num-units " " name)
 697                                 name))
 698             (setq calc-den-units (if calc-den-units
 699                                 (concat calc-den-units " " name)
 700                               name))))
 701       (cond ((eq (car-safe expr) '*)
 702              (calc-explain-units-rec (nth 1 expr) pow)
 703              (calc-explain-units-rec (nth 2 expr) pow))
 704             ((eq (car-safe expr) '/)
 705              (calc-explain-units-rec (nth 1 expr) pow)
 706              (calc-explain-units-rec (nth 2 expr) (- pow)))
 707             ((memq (car-safe expr) '(neg + -))
 708              (calc-explain-units-rec (nth 1 expr) pow))
 709             ((and (eq (car-safe expr) '^)
 710                   (math-realp (nth 2 expr)))
 711              (calc-explain-units-rec (nth 1 expr)
 712                                      (math-mul pow (nth 2 expr))))))))
 713
 714 (defun calc-simplify-units ()
 715   (interactive)
 716   (calc-slow-wrapper
 717    (calc-with-default-simplification
 718     (calc-enter-result 1 "smun" (math-simplify-units (calc-top-n 1))))))
 719
 720 (defun calc-view-units-table (n)
 721   (interactive "P")
 722   (and n (setq math-units-table-buffer-valid nil))
 723   (let ((win (get-buffer-window "*Units Table*")))
 724     (if (and win
 725              math-units-table
 726              math-units-table-buffer-valid)
 727         (progn
 728           (bury-buffer (window-buffer win))
 729           (let ((curwin (selected-window)))
 730             (select-window win)
 731             (switch-to-buffer nil)
 732             (select-window curwin)))
 733       (math-build-units-table-buffer nil))))
 734
 735 (defun calc-enter-units-table (n)
 736   (interactive "P")
 737   (and n (setq math-units-table-buffer-valid nil))
 738   (math-build-units-table-buffer t)
 739   (message "%s" (substitute-command-keys "Type \\[calc] to return to the Calculator")))
 740
 741 (defun calc-define-unit (uname desc &optional disp)
 742   (interactive "SDefine unit name: \nsDescription: \nP")
 743   (if disp (setq disp (read-string "Display definition: ")))
 744   (calc-wrapper
 745    (let ((form (calc-top-n 1))
 746          (unit (assq uname math-additional-units)))
 747      (or unit
 748          (setq math-additional-units
 749                (cons (setq unit (list uname nil nil nil nil))
 750                      math-additional-units)
 751                math-units-table nil))
 752      (setcar (cdr unit) (and (not (and (eq (car-safe form) 'var)
 753                                        (eq (nth 1 form) uname)))
 754                              (not (math-equal-int form 1))
 755                              (math-format-flat-expr form 0)))
 756      (setcar (cdr (cdr unit)) (and (not (equal desc ""))
 757                                    desc))
 758      (if disp
 759          (setcar (cdr (cdr (cdr (cdr unit)))) disp))))
 760   (calc-invalidate-units-table))
 761
 762 (defun calc-undefine-unit (uname)
 763   (interactive "SUndefine unit name: ")
 764   (calc-wrapper
 765    (let ((unit (assq uname math-additional-units)))
 766      (or unit
 767          (if (assq uname math-standard-units)
 768              (error "\"%s\" is a predefined unit name" uname)
 769            (error "Unit name \"%s\" not found" uname)))
 770      (setq math-additional-units (delq unit math-additional-units)
 771            math-units-table nil)))
 772   (calc-invalidate-units-table))
 773
 774 (defun calc-invalidate-units-table ()
 775   (setq math-units-table nil)
 776   (let ((buf (get-buffer "*Units Table*")))
 777     (and buf
 778          (with-current-buffer buf
 779            (save-excursion
 780              (goto-char (point-min))
 781              (if (looking-at "Calculator Units Table")
 782                  (let ((inhibit-read-only t))
 783                    (insert "(Obsolete) "))))))))
 784
 785 (defun calc-get-unit-definition (uname)
 786   (interactive "SGet definition for unit: ")
 787   (calc-wrapper
 788    (math-build-units-table)
 789    (let ((unit (assq uname math-units-table)))
 790      (or unit
 791          (error "Unit name \"%s\" not found" uname))
 792      (let ((msg (nth 2 unit)))
 793        (if (stringp msg)
 794            (if (string-match "^\\*" msg)
 795                (setq msg (substring msg 1)))
 796          (setq msg (symbol-name uname)))
 797        (if (nth 1 unit)
 798            (progn
 799              (calc-enter-result 0 "ugdf" (nth 1 unit))
 800              (message "Derived unit: %s" msg))
 801          (calc-enter-result 0 "ugdf" (list 'var uname
 802                                            (intern
 803                                             (concat "var-"
 804                                                     (symbol-name uname)))))
 805          (message "Base unit: %s" msg))))))
 806
 807 (defun calc-permanent-units ()
 808   (interactive)
 809   (calc-wrapper
 810    (let (pos)
 811      (set-buffer (find-file-noselect (substitute-in-file-name
 812                                       calc-settings-file)))
 813      (goto-char (point-min))
 814      (if (and (search-forward ";;; Custom units stored by Calc" nil t)
 815               (progn
 816                 (beginning-of-line)
 817                 (setq pos (point))
 818                 (search-forward "\n;;; End of custom units" nil t)))
 819          (progn
 820            (beginning-of-line)
 821            (forward-line 1)
 822            (delete-region pos (point)))
 823        (goto-char (point-max))
 824        (insert "\n\n")
 825        (forward-char -1))
 826      (insert ";;; Custom units stored by Calc on " (current-time-string) "\n")
 827      (if math-additional-units
 828          (let (expr)
 829            (insert "(setq math-additional-units '(\n")
 830            (dolist (u math-additional-units)
 831              (insert "  (" (symbol-name (car u)) " "
 832                      (if (setq expr (nth 1 u))
 833                          (if (stringp expr)
 834                              (prin1-to-string expr)
 835                            (prin1-to-string (math-format-flat-expr expr 0)))
 836                        "nil")
 837                      " "
 838                      (prin1-to-string (nth 2 u))
 839                      ")\n"))
 840            (insert "))\n"))
 841        (insert ";;; (no custom units defined)\n"))
 842      (insert ";;; End of custom units\n")
 843      (save-buffer))))
 844
 845
 846 ;; The variable math-cu-unit-list is local to math-build-units-table,
 847 ;; but is used by math-compare-unit-names, which is called (indirectly)
 848 ;; by math-build-units-table.
 849 ;; math-cu-unit-list is also local to math-convert-units, but is used
 850 ;; by math-convert-units-rec, which is called by math-convert-units.
 851 (defvar math-cu-unit-list)
 852
 853 (defun math-build-units-table ()
 854   (or math-units-table
 855       (let* ((combined-units (append math-additional-units
 856                                      math-standard-units))
 857              (math-cu-unit-list (mapcar 'car combined-units))
 858              tab)
 859         (message "Building units table...")
 860         (setq math-units-table-buffer-valid nil)
 861         (setq tab (mapcar (function
 862                            (lambda (x)
 863                              (list (car x)
 864                                    (and (nth 1 x)
 865                                         (if (stringp (nth 1 x))
 866                                             (let ((exp (math-read-plain-expr
 867                                                         (nth 1 x))))
 868                                               (if (eq (car-safe exp) 'error)
 869                                                   (error "Format error in definition of %s in units table: %s"
 870                                                          (car x) (nth 2 exp))
 871                                                 exp))
 872                                           (nth 1 x)))
 873                                    (nth 2 x)
 874                                    (nth 3 x)
 875                                    (and (not (nth 1 x))
 876                                         (list (cons (car x) 1)))
 877                                    (nth 4 x))))
 878                           combined-units))
 879         (let ((math-units-table tab))
 880           (mapc 'math-find-base-units tab))
 881         (message "Building units table...done")
 882         (setq math-units-table tab))))
 883
 884 ;; The variables math-fbu-base and math-fbu-entry are local to
 885 ;; math-find-base-units, but are used by math-find-base-units-rec,
 886 ;; which is called by math-find-base-units.
 887 (defvar math-fbu-base)
 888 (defvar math-fbu-entry)
 889
 890 (defun math-find-base-units (math-fbu-entry)
 891   (if (eq (nth 4 math-fbu-entry) 'boom)
 892       (error "Circular definition involving unit %s" (car math-fbu-entry)))
 893   (or (nth 4 math-fbu-entry)
 894       (let (math-fbu-base)
 895         (setcar (nthcdr 4 math-fbu-entry) 'boom)
 896         (math-find-base-units-rec (nth 1 math-fbu-entry) 1)
 897         '(or math-fbu-base
 898             (error "Dimensionless definition for unit %s" (car math-fbu-entry)))
 899         (while (eq (cdr (car math-fbu-base)) 0)
 900           (setq math-fbu-base (cdr math-fbu-base)))
 901         (let ((b math-fbu-base))
 902           (while (cdr b)
 903             (if (eq (cdr (car (cdr b))) 0)
 904                 (setcdr b (cdr (cdr b)))
 905               (setq b (cdr b)))))
 906         (setq math-fbu-base (sort math-fbu-base 'math-compare-unit-names))
 907         (setcar (nthcdr 4 math-fbu-entry) math-fbu-base)
 908         math-fbu-base)))
 909
 910 (defun math-compare-unit-names (a b)
 911   (memq (car b) (cdr (memq (car a) math-cu-unit-list))))
 912
 913 (defun math-find-base-units-rec (expr pow)
 914   (let ((u (math-check-unit-name expr)))
 915     (cond (u
 916            (dolist (x (math-find-base-units u))
 917              (let ((p (* (cdr x) pow))
 918                    (old (assq (car x) math-fbu-base)))
 919                (if old
 920                    (setcdr old (+ (cdr old) p))
 921                  (setq math-fbu-base
 922                        (cons (cons (car x) p) math-fbu-base))))))
 923           ((math-scalarp expr))
 924           ((and (eq (car expr) '^)
 925                 (integerp (nth 2 expr)))
 926            (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr))))
 927           ((eq (car expr) '*)
 928            (math-find-base-units-rec (nth 1 expr) pow)
 929            (math-find-base-units-rec (nth 2 expr) pow))
 930           ((eq (car expr) '/)
 931            (math-find-base-units-rec (nth 1 expr) pow)
 932            (math-find-base-units-rec (nth 2 expr) (- pow)))
 933           ((eq (car expr) 'neg)
 934            (math-find-base-units-rec (nth 1 expr) pow))
 935           ((eq (car expr) '+)
 936            (math-find-base-units-rec (nth 1 expr) pow))
 937           ((eq (car expr) 'var)
 938            (or (eq (nth 1 expr) 'pi)
 939                (error "Unknown name %s in defining expression for unit %s"
 940                       (nth 1 expr) (car math-fbu-entry))))
 941           ((equal expr '(calcFunc-ln 10)))
 942           (t (error "Malformed defining expression for unit %s" (car math-fbu-entry))))))
 943
 944
 945 (defun math-units-in-expr-p (expr sub-exprs)
 946   (and (consp expr)
 947        (if (eq (car expr) 'var)
 948            (math-check-unit-name expr)
 949          (if (eq (car expr) 'neg)
 950              (math-units-in-expr-p (nth 1 expr) sub-exprs)
 951            (and (or sub-exprs
 952                     (memq (car expr) '(* / ^)))
 953                 (or (math-units-in-expr-p (nth 1 expr) sub-exprs)
 954                     (math-units-in-expr-p (nth 2 expr) sub-exprs)))))))
 955
 956 (defun math-only-units-in-expr-p (expr)
 957   (and (consp expr)
 958        (if (eq (car expr) 'var)
 959            (math-check-unit-name expr)
 960          (if (memq (car expr) '(* /))
 961              (and (math-only-units-in-expr-p (nth 1 expr))
 962                   (math-only-units-in-expr-p (nth 2 expr)))
 963            (and (eq (car expr) '^)
 964                 (and (math-only-units-in-expr-p (nth 1 expr))
 965                      (math-realp (nth 2 expr))))))))
 966
 967 (defun math-single-units-in-expr-p (expr)
 968   (cond ((math-scalarp expr) nil)
 969         ((eq (car expr) 'var)
 970          (math-check-unit-name expr))
 971         ((eq (car expr) 'neg)
 972          (math-single-units-in-expr-p (nth 1 expr)))
 973         ((eq (car expr) '*)
 974          (let ((u1 (math-single-units-in-expr-p (nth 1 expr)))
 975                (u2 (math-single-units-in-expr-p (nth 2 expr))))
 976            (or (and u1 u2 'wrong)
 977                u1
 978                u2)))
 979         ((eq (car expr) '/)
 980          (if (math-units-in-expr-p (nth 2 expr) nil)
 981              'wrong
 982            (math-single-units-in-expr-p (nth 1 expr))))
 983         (t 'wrong)))
 984
 985 (defun math-consistent-units-p (expr newunits)
 986   "Non-nil if EXPR and NEWUNITS have consistent units."
 987   (or
 988    (and (eq (car-safe newunits) 'var)
 989         (assq (nth 1 newunits) math-standard-units-systems))
 990    (math-numberp (math-get-units (math-to-standard-units (list '/ expr newunits) nil)))))
 991
 992 (defun math-check-unit-consistency (expr units)
 993   "Give an error if EXPR and UNITS do not have consistent units."
 994   (unless  (math-consistent-units-p expr units)
 995     (error "New units (%s) are inconsistent with current units (%s)"
 996            (math-format-value units)
 997            (math-format-value (math-get-units expr)))))
 998
 999 (defun math-check-unit-name (v)
1000   (and (eq (car-safe v) 'var)
1001        (or (assq (nth 1 v) (or math-units-table (math-build-units-table)))
1002            (let ((name (symbol-name (nth 1 v))))
1003              (and (> (length name) 1)
1004                   (assq (aref name 0) math-unit-prefixes)
1005                   (or (assq (intern (substring name 1)) math-units-table)
1006                       (and (eq (aref name 0) ?M)
1007                            (> (length name) 3)
1008                            (eq (aref name 1) ?e)
1009                            (eq (aref name 2) ?g)
1010                            (assq (intern (substring name 3))
1011                                  math-units-table))))))))
1012
1013 ;; The variable math-which-standard is local to math-to-standard-units,
1014 ;; but is used by math-to-standard-rec, which is called by
1015 ;; math-to-standard-units.
1016 (defvar math-which-standard)
1017
1018 (defun math-to-standard-units (expr math-which-standard)
1019   (math-to-standard-rec expr))
1020
1021 (defun math-to-standard-rec (expr)
1022   (if (eq (car-safe expr) 'var)
1023       (let ((u (math-check-unit-name expr))
1024             (base (nth 1 expr)))
1025         (if u
1026             (progn
1027               (if (nth 1 u)
1028                   (setq expr (math-to-standard-rec (nth 1 u)))
1029                 (let ((st (assq (car u) math-which-standard)))
1030                   (if st
1031                       (setq expr (nth 1 st))
1032                     (setq expr (list 'var (car u)
1033                                      (intern (concat "var-"
1034                                                      (symbol-name
1035                                                       (car u)))))))))
1036               (or (null u)
1037                   (eq base (car u))
1038                   (setq expr (list '*
1039                                    (nth 1 (assq (aref (symbol-name base) 0)
1040                                                 math-unit-prefixes))
1041                                    expr)))
1042               expr)
1043           (if (eq base 'pi)
1044               (math-pi)
1045             expr)))
1046     (if (or
1047          (Math-primp expr)
1048          (and (eq (car-safe expr) 'calcFunc-subscr)
1049               (eq (car-safe (nth 1 expr)) 'var)))
1050         expr
1051       (cons (car expr)
1052             (mapcar 'math-to-standard-rec (cdr expr))))))
1053
1054 (defun math-apply-units (expr units ulist &optional pure)
1055   (setq expr (math-simplify-units expr))
1056   (if ulist
1057       (let ((new 0)
1058             value)
1059         (or (math-numberp expr)
1060             (error "Incompatible units"))
1061         (while (cdr ulist)
1062           (setq value (math-div expr (nth 1 (car ulist)))
1063                 value (math-floor (let ((calc-internal-prec
1064                                          (1- calc-internal-prec)))
1065                                     (math-normalize value)))
1066                 new (math-add new (math-mul value (car (car ulist))))
1067                 expr (math-sub expr (math-mul value (nth 1 (car ulist))))
1068                 ulist (cdr ulist)))
1069         (math-add new (math-mul (math-div expr (nth 1 (car ulist)))
1070                                 (car (car ulist)))))
1071     (if pure
1072         expr
1073       (math-simplify-units (list '* expr units)))))
1074
1075 (defvar math-decompose-units-cache nil)
1076 (defun math-decompose-units (units)
1077   (let ((u (math-check-unit-name units)))
1078     (and u (eq (car-safe (nth 1 u)) '+)
1079          (setq units (nth 1 u))))
1080   (setq units (calcFunc-expand units))
1081   (and (eq (car-safe units) '+)
1082        (let ((entry (list units calc-internal-prec calc-prefer-frac)))
1083          (or (equal entry (car math-decompose-units-cache))
1084              (let ((ulist nil)
1085                    (utemp units)
1086                    qty unit)
1087                (while (eq (car-safe utemp) '+)
1088                  (setq ulist (cons (math-decompose-unit-part (nth 2 utemp))
1089                                    ulist)
1090                        utemp (nth 1 utemp)))
1091                (setq ulist (cons (math-decompose-unit-part utemp) ulist)
1092                      utemp ulist)
1093                (while (setq utemp (cdr utemp))
1094                  (unless (equal (nth 2 (car utemp)) (nth 2 (car ulist)))
1095                    (error "Inconsistent units in sum")))
1096                (setq math-decompose-units-cache
1097                      (cons entry
1098                            (sort ulist
1099                                  (function
1100                                   (lambda (x y)
1101                                     (not (Math-lessp (nth 1 x)
1102                                                      (nth 1 y))))))))))
1103          (cdr math-decompose-units-cache))))
1104
1105 (defun math-decompose-unit-part (unit)
1106   (cons unit
1107         (math-is-multiple (math-simplify-units (math-to-standard-units
1108                                                 unit nil))
1109                           t)))
1110
1111 ;; The variable math-fcu-u is local to math-find-compatible-unit,
1112 ;; but is used by math-find-compatible-rec which is called by
1113 ;; math-find-compatible-unit.
1114 (defvar math-fcu-u)
1115
1116 (defun math-find-compatible-unit (expr unit)
1117   (let ((math-fcu-u (math-check-unit-name unit)))
1118     (if math-fcu-u
1119         (math-find-compatible-unit-rec expr 1))))
1120
1121 (defun math-find-compatible-unit-rec (expr pow)
1122   (cond ((eq (car-safe expr) '*)
1123          (or (math-find-compatible-unit-rec (nth 1 expr) pow)
1124              (math-find-compatible-unit-rec (nth 2 expr) pow)))
1125         ((eq (car-safe expr) '/)
1126          (or (math-find-compatible-unit-rec (nth 1 expr) pow)
1127              (math-find-compatible-unit-rec (nth 2 expr) (- pow))))
1128         ((eq (car-safe expr) 'neg)
1129          (math-find-compatible-unit-rec (nth 1 expr) pow))
1130         ((and (eq (car-safe expr) '^)
1131               (integerp (nth 2 expr)))
1132          (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr))))
1133         (t
1134          (let ((u2 (math-check-unit-name expr)))
1135            (if (equal (nth 4 math-fcu-u) (nth 4 u2))
1136                (cons expr pow))))))
1137
1138 ;; The variables math-cu-new-units and math-cu-pure are local to
1139 ;; math-convert-units, but are used by math-convert-units-rec,
1140 ;; which is called by math-convert-units.
1141 (defvar math-cu-new-units)
1142 (defvar math-cu-pure)
1143
1144 (defun math-convert-units (expr math-cu-new-units &optional math-cu-pure)
1145   (if (eq (car-safe math-cu-new-units) 'var)
1146       (let ((unew (assq (nth 1 math-cu-new-units)
1147                         (math-build-units-table))))
1148         (if (eq (car-safe (nth 1 unew)) '+)
1149             (setq math-cu-new-units (nth 1 unew)))))
1150   (math-with-extra-prec 2
1151     (let ((compat (and (not math-cu-pure)
1152                        (math-find-compatible-unit expr math-cu-new-units)))
1153           (math-cu-unit-list nil)
1154           (math-combining-units nil))
1155       (if compat
1156           (math-simplify-units
1157            (math-mul (math-mul (math-simplify-units
1158                                 (math-div expr (math-pow (car compat)
1159                                                          (cdr compat))))
1160                                (math-pow math-cu-new-units (cdr compat)))
1161                      (math-simplify-units
1162                       (math-to-standard-units
1163                        (math-pow (math-div (car compat) math-cu-new-units)
1164                                  (cdr compat))
1165                        nil))))
1166         (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units))
1167           (setq math-cu-new-units (nth 2 (car math-cu-unit-list))))
1168         (when (eq (car-safe expr) '+)
1169           (setq expr (math-simplify-units expr)))
1170         (if (math-units-in-expr-p expr t)
1171             (math-convert-units-rec expr)
1172           (math-apply-units (math-to-standard-units
1173                              (list '/ expr math-cu-new-units) nil)
1174                             math-cu-new-units math-cu-unit-list math-cu-pure))))))
1175
1176 (defun math-convert-units-rec (expr)
1177   (if (math-units-in-expr-p expr nil)
1178       (math-apply-units (math-to-standard-units
1179                          (list '/ expr math-cu-new-units) nil)
1180                         math-cu-new-units math-cu-unit-list math-cu-pure)
1181     (if (Math-primp expr)
1182         expr
1183       (cons (car expr)
1184             (mapcar 'math-convert-units-rec (cdr expr))))))
1185
1186 (defun math-convert-temperature (expr old new &optional pure)
1187   (let* ((units (math-single-units-in-expr-p expr))
1188          (uold (if old
1189                    (if (or (null units)
1190                            (equal (nth 1 old) (car units)))
1191                        (math-check-unit-name old)
1192                      (error "Inconsistent temperature units"))
1193                  units))
1194          (unew (math-check-unit-name new)))
1195     (unless (and (consp unew) (nth 3 unew))
1196       (error "Not a valid temperature unit"))
1197     (unless (and (consp uold) (nth 3 uold))
1198       (error "Not a pure temperature expression"))
1199     (let ((v (car uold)))
1200       (setq expr (list '/ expr (list 'var v
1201                                      (intern (concat "var-"
1202                                                      (symbol-name v)))))))
1203     (or (eq (nth 3 uold) (nth 3 unew))
1204         (cond ((eq (nth 3 uold) 'K)
1205                (setq expr (list '- expr '(/ 27315 100)))
1206                (if (eq (nth 3 unew) 'F)
1207                    (setq expr (list '+ (list '* expr '(/ 9 5)) 32))))
1208               ((eq (nth 3 uold) 'C)
1209                (if (eq (nth 3 unew) 'F)
1210                    (setq expr (list '+ (list '* expr '(/ 9 5)) 32))
1211                  (setq expr (list '+ expr '(/ 27315 100)))))
1212               (t
1213                (setq expr (list '* (list '- expr 32) '(/ 5 9)))
1214                (if (eq (nth 3 unew) 'K)
1215                    (setq expr (list '+ expr '(/ 27315 100)))))))
1216     (if pure
1217         expr
1218       (list '* expr new))))
1219
1220
1221
1222 (defun math-simplify-units (a)
1223   (let ((math-simplifying-units t)
1224         (calc-matrix-mode 'scalar))
1225     (math-simplify a)))
1226 (defalias 'calcFunc-usimplify 'math-simplify-units)
1227
1228 ;; The function created by math-defsimplify uses the variable
1229 ;; math-simplify-expr, and so is used by functions in math-defsimplify
1230 (defvar math-simplify-expr)
1231
1232 (math-defsimplify (+ -)
1233   (and math-simplifying-units
1234        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1235        (let* ((units (math-extract-units (nth 1 math-simplify-expr)))
1236               (ratio (math-simplify (math-to-standard-units
1237                                      (list '/ (nth 2 math-simplify-expr) units) nil))))
1238          (if (math-units-in-expr-p ratio nil)
1239              (progn
1240                (calc-record-why "*Inconsistent units" math-simplify-expr)
1241                math-simplify-expr)
1242            (list '* (math-add (math-remove-units (nth 1 math-simplify-expr))
1243                               (if (eq (car math-simplify-expr) '-)
1244                                   (math-neg ratio) ratio))
1245                  units)))))
1246
1247 (math-defsimplify *
1248   (math-simplify-units-prod))
1249
1250 (defun math-simplify-units-prod ()
1251   (and math-simplifying-units
1252        calc-autorange-units
1253        (Math-realp (nth 1 math-simplify-expr))
1254        (let* ((num (math-float (nth 1 math-simplify-expr)))
1255               (xpon (calcFunc-xpon num))
1256               (unitp (cdr (cdr math-simplify-expr)))
1257               (unit (car unitp))
1258               (pow (if (eq (car math-simplify-expr) '*) 1 -1))
1259               u)
1260          (and (eq (car-safe unit) '*)
1261               (setq unitp (cdr unit)
1262                     unit (car unitp)))
1263          (and (eq (car-safe unit) '^)
1264               (integerp (nth 2 unit))
1265               (setq pow (* pow (nth 2 unit))
1266                     unitp (cdr unit)
1267                     unit (car unitp)))
1268          (and (setq u (math-check-unit-name unit))
1269               (integerp xpon)
1270               (or (< xpon 0)
1271                   (>= xpon (if (eq (car u) 'm) 1 3)))
1272               (let* ((uxpon 0)
1273                      (pref (if (< pow 0)
1274                                (reverse math-unit-prefixes)
1275                              math-unit-prefixes))
1276                      (p pref)
1277                      pxpon pname)
1278                 (or (eq (car u) (nth 1 unit))
1279                     (setq uxpon (* pow
1280                                    (nth 2 (nth 1 (assq
1281                                                   (aref (symbol-name
1282                                                          (nth 1 unit)) 0)
1283                                                   math-unit-prefixes))))))
1284                 (setq xpon (+ xpon uxpon))
1285                 (while (and p
1286                             (or (memq (car (car p)) '(?d ?D ?h ?H))
1287                                 (and (eq (car (car p)) ?c)
1288                                      (not (eq (car u) 'm)))
1289                                 (< xpon (setq pxpon (* (nth 2 (nth 1 (car p)))
1290                                                        pow)))
1291                                 (progn
1292                                   (setq pname (math-build-var-name
1293                                                (if (eq (car (car p)) 0)
1294                                                    (car u)
1295                                                  (concat (char-to-string
1296                                                           (car (car p)))
1297                                                          (symbol-name
1298                                                           (car u))))))
1299                                   (and (/= (car (car p)) 0)
1300                                        (assq (nth 1 pname)
1301                                              math-units-table)))))
1302                   (setq p (cdr p)))
1303                 (and p
1304                      (/= pxpon uxpon)
1305                      (or (not (eq p pref))
1306                          (< xpon (+ pxpon (* (math-abs pow) 3))))
1307                      (progn
1308                        (setcar (cdr math-simplify-expr)
1309                                (let ((calc-prefer-frac nil))
1310                                  (calcFunc-scf (nth 1 math-simplify-expr)
1311                                                (- uxpon pxpon))))
1312                        (setcar unitp pname)
1313                        math-simplify-expr)))))))
1314
1315 (defvar math-try-cancel-units)
1316
1317 (math-defsimplify /
1318   (and math-simplifying-units
1319        (let ((np (cdr math-simplify-expr))
1320              (math-try-cancel-units 0)
1321              n nn)
1322          (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
1323                      (cdr (nth 2 math-simplify-expr))
1324                    (nthcdr 2 math-simplify-expr)))
1325          (if (math-realp (car n))
1326              (progn
1327                (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr)
1328                                             (let ((calc-prefer-frac nil))
1329                                               (math-div 1 (car n)))))
1330                (setcar n 1)))
1331          (while (eq (car-safe (setq n (car np))) '*)
1332            (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr)))
1333            (setq np (cdr (cdr n))))
1334          (math-simplify-units-divisor np (cdr (cdr math-simplify-expr)))
1335          (if (eq math-try-cancel-units 0)
1336              (let* ((math-simplifying-units nil)
1337                     (base (math-simplify
1338                            (math-to-standard-units math-simplify-expr nil))))
1339                (if (Math-numberp base)
1340                    (setq math-simplify-expr base))))
1341          (if (eq (car-safe math-simplify-expr) '/)
1342              (math-simplify-units-prod))
1343          math-simplify-expr)))
1344
1345 (defun math-simplify-units-divisor (np dp)
1346   (let ((n (car np))
1347         d dd temp)
1348     (while (eq (car-safe (setq d (car dp))) '*)
1349       (when (setq temp (math-simplify-units-quotient n (nth 1 d)))
1350         (setcar np (setq n temp))
1351         (setcar (cdr d) 1))
1352       (setq dp (cdr (cdr d))))
1353     (when (setq temp (math-simplify-units-quotient n d))
1354       (setcar np (setq n temp))
1355       (setcar dp 1))))
1356
1357 ;; Simplify, e.g., "in / cm" to "2.54" in a units expression.
1358 (defun math-simplify-units-quotient (n d)
1359   (let ((pow1 1)
1360         (pow2 1))
1361     (when (and (eq (car-safe n) '^)
1362                (integerp (nth 2 n)))
1363       (setq pow1 (nth 2 n) n (nth 1 n)))
1364     (when (and (eq (car-safe d) '^)
1365                (integerp (nth 2 d)))
1366       (setq pow2 (nth 2 d) d (nth 1 d)))
1367     (let ((un (math-check-unit-name n))
1368           (ud (math-check-unit-name d)))
1369       (and un ud
1370            (if (and (equal (nth 4 un) (nth 4 ud))
1371                     (eq pow1 pow2))
1372                (if (eq pow1 1)
1373                    (math-to-standard-units (list '/ n d) nil)
1374                  (list '^ (math-to-standard-units (list '/ n d) nil) pow1))
1375              (setq un (nth 4 un)
1376                    ud (nth 4 ud))
1377              (dolist (x un)
1378                (dolist (y ud)
1379                  (when (eq (car x) (car y))
1380                    (setq math-try-cancel-units
1381                          (+ math-try-cancel-units
1382                             (- (* (cdr x) pow1)
1383                                (* (cdr (car ud)) pow2))))))))))))
1384
1385 (math-defsimplify ^
1386   (and math-simplifying-units
1387        (math-realp (nth 2 math-simplify-expr))
1388        (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1389            (list (car (nth 1 math-simplify-expr))
1390                  (list '^ (nth 1 (nth 1 math-simplify-expr))
1391                        (nth 2 math-simplify-expr))
1392                  (list '^ (nth 2 (nth 1 math-simplify-expr))
1393                        (nth 2 math-simplify-expr)))
1394          (math-simplify-units-pow (nth 1 math-simplify-expr)
1395                                   (nth 2 math-simplify-expr)))))
1396
1397 (math-defsimplify calcFunc-sqrt
1398   (and math-simplifying-units
1399        (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1400            (list (car (nth 1 math-simplify-expr))
1401                  (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1402                  (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr))))
1403          (math-simplify-units-pow (nth 1 math-simplify-expr) '(frac 1 2)))))
1404
1405 (math-defsimplify (calcFunc-floor
1406                    calcFunc-ceil
1407                    calcFunc-round
1408                    calcFunc-rounde
1409                    calcFunc-roundu
1410                    calcFunc-trunc
1411                    calcFunc-float
1412                    calcFunc-frac
1413                    calcFunc-abs
1414                    calcFunc-clean)
1415   (and math-simplifying-units
1416        (= (length math-simplify-expr) 2)
1417        (if (math-only-units-in-expr-p (nth 1 math-simplify-expr))
1418            (nth 1 math-simplify-expr)
1419          (if (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1420                   (or (math-only-units-in-expr-p
1421                        (nth 1 (nth 1 math-simplify-expr)))
1422                       (math-only-units-in-expr-p
1423                        (nth 2 (nth 1 math-simplify-expr)))))
1424              (list (car (nth 1 math-simplify-expr))
1425                    (cons (car math-simplify-expr)
1426                          (cons (nth 1 (nth 1 math-simplify-expr))
1427                                (cdr (cdr math-simplify-expr))))
1428                    (cons (car math-simplify-expr)
1429                          (cons (nth 2 (nth 1 math-simplify-expr))
1430                                (cdr (cdr math-simplify-expr)))))))))
1431
1432 (defun math-simplify-units-pow (a pow)
1433   (if (and (eq (car-safe a) '^)
1434            (math-check-unit-name (nth 1 a))
1435            (math-realp (nth 2 a)))
1436       (list '^ (nth 1 a) (math-mul pow (nth 2 a)))
1437     (let* ((u (math-check-unit-name a))
1438            (pf (math-to-simple-fraction pow))
1439            (d (and (eq (car-safe pf) 'frac) (nth 2 pf))))
1440       (and u d
1441            (math-units-are-multiple u d)
1442            (list '^ (math-to-standard-units a nil) pow)))))
1443
1444
1445 (defun math-units-are-multiple (u n)
1446   (setq u (nth 4 u))
1447   (while (and u (= (% (cdr (car u)) n) 0))
1448     (setq u (cdr u)))
1449   (null u))
1450
1451 (math-defsimplify calcFunc-sin
1452   (and math-simplifying-units
1453        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1454        (let ((rad (math-simplify-units
1455                    (math-evaluate-expr
1456                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1457              (calc-angle-mode 'rad))
1458          (and (eq (car-safe rad) '*)
1459               (math-realp (nth 1 rad))
1460               (eq (car-safe (nth 2 rad)) 'var)
1461               (eq (nth 1 (nth 2 rad)) 'rad)
1462               (list 'calcFunc-sin (nth 1 rad))))))
1463
1464 (math-defsimplify calcFunc-cos
1465   (and math-simplifying-units
1466        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1467        (let ((rad (math-simplify-units
1468                    (math-evaluate-expr
1469                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1470              (calc-angle-mode 'rad))
1471          (and (eq (car-safe rad) '*)
1472               (math-realp (nth 1 rad))
1473               (eq (car-safe (nth 2 rad)) 'var)
1474               (eq (nth 1 (nth 2 rad)) 'rad)
1475               (list 'calcFunc-cos (nth 1 rad))))))
1476
1477 (math-defsimplify calcFunc-tan
1478   (and math-simplifying-units
1479        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1480        (let ((rad (math-simplify-units
1481                    (math-evaluate-expr
1482                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1483              (calc-angle-mode 'rad))
1484          (and (eq (car-safe rad) '*)
1485               (math-realp (nth 1 rad))
1486               (eq (car-safe (nth 2 rad)) 'var)
1487               (eq (nth 1 (nth 2 rad)) 'rad)
1488               (list 'calcFunc-tan (nth 1 rad))))))
1489
1490 (math-defsimplify calcFunc-sec
1491   (and math-simplifying-units
1492        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1493        (let ((rad (math-simplify-units
1494                    (math-evaluate-expr
1495                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1496              (calc-angle-mode 'rad))
1497          (and (eq (car-safe rad) '*)
1498               (math-realp (nth 1 rad))
1499               (eq (car-safe (nth 2 rad)) 'var)
1500               (eq (nth 1 (nth 2 rad)) 'rad)
1501               (list 'calcFunc-sec (nth 1 rad))))))
1502
1503 (math-defsimplify calcFunc-csc
1504   (and math-simplifying-units
1505        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1506        (let ((rad (math-simplify-units
1507                    (math-evaluate-expr
1508                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1509              (calc-angle-mode 'rad))
1510          (and (eq (car-safe rad) '*)
1511               (math-realp (nth 1 rad))
1512               (eq (car-safe (nth 2 rad)) 'var)
1513               (eq (nth 1 (nth 2 rad)) 'rad)
1514               (list 'calcFunc-csc (nth 1 rad))))))
1515
1516 (math-defsimplify calcFunc-cot
1517   (and math-simplifying-units
1518        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1519        (let ((rad (math-simplify-units
1520                    (math-evaluate-expr
1521                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1522              (calc-angle-mode 'rad))
1523          (and (eq (car-safe rad) '*)
1524               (math-realp (nth 1 rad))
1525               (eq (car-safe (nth 2 rad)) 'var)
1526               (eq (nth 1 (nth 2 rad)) 'rad)
1527               (list 'calcFunc-cot (nth 1 rad))))))
1528
1529
1530 (defun math-remove-units (expr)
1531   (if (math-check-unit-name expr)
1532       1
1533     (if (Math-primp expr)
1534         expr
1535       (cons (car expr)
1536             (mapcar 'math-remove-units (cdr expr))))))
1537
1538 (defun math-extract-units (expr)
1539   (cond
1540    ((memq (car-safe expr) '(* /))
1541     (cons (car expr)
1542           (mapcar 'math-extract-units (cdr expr))))
1543    ((eq (car-safe expr) 'neg)
1544     (math-extract-units (nth 1 expr)))
1545    ((eq (car-safe expr) '^)
1546     (list '^ (math-extract-units (nth 1 expr)) (nth 2 expr)))
1547    ((math-check-unit-name expr) expr)
1548    (t 1)))
1549
1550 (defun math-build-units-table-buffer (enter-buffer)
1551   (if (not (and math-units-table math-units-table-buffer-valid
1552                 (get-buffer "*Units Table*")))
1553       (let ((buf (get-buffer-create "*Units Table*"))
1554             (uptr (math-build-units-table))
1555             (calc-language (if (eq calc-language 'big) nil calc-language))
1556             (calc-float-format '(float 0))
1557             (calc-group-digits nil)
1558             (calc-number-radix 10)
1559             (calc-twos-complement-mode nil)
1560             (calc-point-char ".")
1561             (std nil)
1562             u name shadowed)
1563         (save-excursion
1564           (message "Formatting units table...")
1565           (set-buffer buf)
1566           (let ((inhibit-read-only t))
1567             (erase-buffer)
1568             (insert "Calculator Units Table:\n\n")
1569             (insert "(All definitions are exact unless marked with an asterisk (*).)\n\n")
1570             (insert "Unit    Type  Definition                  Description\n\n")
1571             (dolist (u uptr)
1572               (setq name (nth 2 u))
1573               (when (eq (car u) 'm)
1574                 (setq std t))
1575               (setq shadowed (and std (assq (car u) math-additional-units)))
1576               (when (and name
1577                          (> (length name) 1)
1578                          (eq (aref name 0) ?\*))
1579                 (unless (eq uptr math-units-table)
1580                   (insert "\n"))
1581                 (setq name (substring name 1)))
1582               (insert " ")
1583               (and shadowed (insert "("))
1584               (insert (symbol-name (car u)))
1585               (and shadowed (insert ")"))
1586               (if (nth 3 u)
1587                   (progn
1588                     (indent-to 10)
1589                     (insert (symbol-name (nth 3 u))))
1590                 (or std
1591                     (progn
1592                       (indent-to 10)
1593                       (insert "U"))))
1594               (indent-to 14)
1595               (and shadowed (insert "("))
1596               (if (nth 5 u)
1597                   (insert (nth 5 u))
1598                 (if (nth 1 u)
1599                     (insert (math-format-value (nth 1 u) 80))
1600                   (insert (symbol-name (car u)))))
1601               (and shadowed (insert ")"))
1602               (indent-to 41)
1603               (insert " ")
1604               (when name
1605                 (insert name))
1606               (if shadowed
1607                   (insert " (redefined above)")
1608                 (unless (nth 1 u)
1609                   (insert " (base unit)")))
1610               (insert "\n"))
1611             (insert "\n\nUnit Prefix Table:\n\n")
1612             (setq uptr math-unit-prefixes)
1613             (while uptr
1614               (setq u (car uptr))
1615               (insert " " (char-to-string (car u)))
1616               (if (equal (nth 1 u) (nth 1 (nth 1 uptr)))
1617                   (insert " " (char-to-string (car (car (setq uptr (cdr uptr)))))
1618                           "   ")
1619                 (insert "     "))
1620               (insert "10^" (int-to-string (nth 2 (nth 1 u))))
1621               (indent-to 15)
1622               (insert "   " (nth 2 u) "\n")
1623               (while (eq (car (car (setq uptr (cdr uptr)))) 0)))
1624             (insert "\n\n")
1625             (insert
1626              (format-message
1627               (concat
1628                "(**) When in TeX or LaTeX display mode, the TeX specific unit\n"
1629                "names will not use the `tex' prefix; the unit name for a\n"
1630                "TeX point will be `pt' instead of `texpt', for example.\n"
1631                "To avoid conflicts, the unit names for pint and parsec will\n"
1632                "be `pint' and `parsec' instead of `pt' and `pc'."))))
1633           (special-mode)
1634           (message "Formatting units table...done"))
1635         (setq math-units-table-buffer-valid t)
1636         (let ((oldbuf (current-buffer)))
1637           (set-buffer buf)
1638           (goto-char (point-min))
1639           (set-buffer oldbuf))
1640         (if enter-buffer
1641             (pop-to-buffer buf)
1642           (display-buffer buf)))
1643     (if enter-buffer
1644         (pop-to-buffer (get-buffer "*Units Table*"))
1645       (display-buffer (get-buffer "*Units Table*")))))
1646
1647 ;;; Logarithmic units functions
1648
1649 (defvar math-logunits '((var dB var-dB)
1650                         (var Np var-Np)))
1651
1652 (defun math-conditional-apply (fn &rest args)
1653   "Evaluate f(args) unless in symbolic mode.
1654 In symbolic mode, return the list (fn args)."
1655   (if calc-symbolic-mode
1656       (cons fn args)
1657     (apply fn args)))
1658
1659 (defun math-conditional-pow (a b)
1660   "Evaluate a^b unless in symbolic mode.
1661 In symbolic mode, return the list (^ a b)."
1662   (if calc-symbolic-mode
1663       (list '^ a b)
1664     (math-pow a b)))
1665
1666 (defun math-extract-logunits (expr)
1667   (if (memq (car-safe expr) '(* /))
1668       (cons (car expr)
1669             (mapcar 'math-extract-logunits (cdr expr)))
1670     (if (memq (car-safe expr) '(^))
1671         (list '^ (math-extract-logunits (nth 1 expr)) (nth 2 expr))
1672       (if (member expr math-logunits) expr 1))))
1673
1674 (defun math-logunits-add (a b neg power)
1675   (let ((aunit (math-simplify (math-extract-logunits a))))
1676     (if (not (eq (car-safe aunit) 'var))
1677         (calc-record-why "*Improper logarithmic unit" aunit)
1678       (let* ((units (math-extract-units a))
1679             (acoeff (math-simplify (math-remove-units a)))
1680             (bcoeff (math-simplify (math-to-standard-units
1681                                     (list '/ b units) nil))))
1682         (if (math-units-in-expr-p bcoeff nil)
1683             (calc-record-why "*Inconsistent units" nil)
1684           (if (and neg
1685                    (or (math-lessp acoeff bcoeff)
1686                        (math-equal acoeff bcoeff)))
1687               (calc-record-why "*Improper coefficients" nil)
1688             (math-mul
1689              (if (equal aunit '(var dB var-dB))
1690                  (let ((coef (if power 10 20)))
1691                    (math-mul coef
1692                              (math-conditional-apply 'calcFunc-log10
1693                               (if neg
1694                                   (math-sub
1695                                    (math-conditional-pow 10 (math-div acoeff coef))
1696                                    (math-conditional-pow 10 (math-div bcoeff coef)))
1697                                 (math-add
1698                                  (math-conditional-pow 10 (math-div acoeff coef))
1699                                  (math-conditional-pow 10 (math-div bcoeff coef)))))))
1700                (let ((coef (if power 2 1)))
1701                  (math-div
1702                   (math-conditional-apply 'calcFunc-ln
1703                    (if neg
1704                        (math-sub
1705                         (math-conditional-apply 'calcFunc-exp (math-mul coef acoeff))
1706                         (math-conditional-apply 'calcFunc-exp (math-mul coef bcoeff)))
1707                      (math-add
1708                       (math-conditional-apply 'calcFunc-exp (math-mul coef acoeff))
1709                       (math-conditional-apply 'calcFunc-exp (math-mul coef bcoeff)))))
1710                   coef)))
1711              units)))))))
1712
1713 (defun calcFunc-lufadd (a b)
1714   (math-logunits-add a b nil nil))
1715
1716 (defun calcFunc-lupadd (a b)
1717   (math-logunits-add a b nil t))
1718
1719 (defun calcFunc-lufsub (a b)
1720   (math-logunits-add a b t nil))
1721
1722 (defun calcFunc-lupsub (a b)
1723   (math-logunits-add a b t t))
1724
1725 (defun calc-lu-plus (arg)
1726   (interactive "P")
1727   (calc-slow-wrapper
1728    (if (calc-is-inverse)
1729        (if (calc-is-hyperbolic)
1730            (calc-binary-op "lu-" 'calcFunc-lufsub arg)
1731          (calc-binary-op "lu-" 'calcFunc-lupsub arg))
1732      (if (calc-is-hyperbolic)
1733          (calc-binary-op "lu+" 'calcFunc-lufadd arg)
1734        (calc-binary-op "lu+" 'calcFunc-lupadd arg)))))
1735
1736 (defun calc-lu-minus (arg)
1737   (interactive "P")
1738   (calc-slow-wrapper
1739    (if (calc-is-inverse)
1740        (if (calc-is-hyperbolic)
1741            (calc-binary-op "lu+" 'calcFunc-lufadd arg)
1742          (calc-binary-op "lu+" 'calcFunc-lupadd arg))
1743      (if (calc-is-hyperbolic)
1744          (calc-binary-op "lu-" 'calcFunc-lufsub arg)
1745        (calc-binary-op "lu-" 'calcFunc-lupsub arg)))))
1746
1747 (defun math-logunits-mul (a b power)
1748   (let (logunit coef units number)
1749     (cond
1750      ((and
1751        (setq logunit (math-simplify (math-extract-logunits a)))
1752        (eq (car-safe logunit) 'var)
1753        (eq (math-simplify (math-extract-units b)) 1))
1754       (setq coef (math-simplify (math-remove-units a))
1755             units (math-extract-units a)
1756             number b))
1757      ((and
1758        (setq logunit (math-simplify (math-extract-logunits b)))
1759        (eq (car-safe logunit) 'var)
1760        (eq (math-simplify (math-extract-units a)) 1))
1761       (setq coef (math-simplify (math-remove-units b))
1762             units (math-extract-units b)
1763             number a))
1764      (t (setq logunit nil)))
1765     (if logunit
1766         (cond
1767          ((equal logunit '(var dB var-dB))
1768           (math-simplify
1769            (math-mul
1770             (math-add
1771              coef
1772              (math-mul (if power 10 20)
1773                        (math-conditional-apply 'calcFunc-log10 number)))
1774             units)))
1775          (t
1776           (math-simplify
1777            (math-mul
1778             (math-add
1779              coef
1780              (math-div (math-conditional-apply 'calcFunc-ln number) (if power 2 1)))
1781             units))))
1782       (calc-record-why "*Improper units" nil))))
1783
1784 (defun math-logunits-divide (a b power)
1785   (let ((logunit (math-simplify (math-extract-logunits a))))
1786     (if (not (eq (car-safe logunit) 'var))
1787         (calc-record-why "*Improper logarithmic unit" logunit)
1788       (if (math-units-in-expr-p b nil)
1789           (calc-record-why "*Improper units quantity" b)
1790         (let* ((units (math-extract-units a))
1791                (coef (math-simplify (math-remove-units a))))
1792           (cond
1793            ((equal logunit '(var dB var-dB))
1794             (math-simplify
1795              (math-mul
1796               (math-sub
1797                coef
1798                (math-mul (if power 10 20)
1799                          (math-conditional-apply 'calcFunc-log10 b)))
1800               units)))
1801          (t
1802           (math-simplify
1803            (math-mul
1804             (math-sub
1805              coef
1806              (math-div (math-conditional-apply 'calcFunc-ln b) (if power 2 1)))
1807             units)))))))))
1808
1809 (defun calcFunc-lufmul (a b)
1810   (math-logunits-mul a b nil))
1811
1812 (defun calcFunc-lupmul (a b)
1813   (math-logunits-mul a b t))
1814
1815 (defun calc-lu-times (arg)
1816   (interactive "P")
1817   (calc-slow-wrapper
1818    (if (calc-is-inverse)
1819        (if (calc-is-hyperbolic)
1820            (calc-binary-op "lu/" 'calcFunc-lufdiv arg)
1821          (calc-binary-op "lu/" 'calcFunc-lupdiv arg))
1822      (if (calc-is-hyperbolic)
1823          (calc-binary-op "lu*" 'calcFunc-lufmul arg)
1824        (calc-binary-op "lu*" 'calcFunc-lupmul arg)))))
1825
1826 (defun calcFunc-lufdiv (a b)
1827   (math-logunits-divide a b nil))
1828
1829 (defun calcFunc-lupdiv (a b)
1830   (math-logunits-divide a b t))
1831
1832 (defun calc-lu-divide (arg)
1833   (interactive "P")
1834   (calc-slow-wrapper
1835    (if (calc-is-inverse)
1836        (if (calc-is-hyperbolic)
1837            (calc-binary-op "lu*" 'calcFunc-lufmul arg)
1838          (calc-binary-op "lu*" 'calcFunc-lupmul arg))
1839      (if (calc-is-hyperbolic)
1840          (calc-binary-op "lu/" 'calcFunc-lufdiv arg)
1841        (calc-binary-op "lu/" 'calcFunc-lupdiv arg)))))
1842
1843 (defun math-logunits-quant (val ref power)
1844   (let* ((units (math-simplify (math-extract-units val)))
1845          (lunit (math-simplify (math-extract-logunits units))))
1846     (if (not (eq (car-safe lunit) 'var))
1847         (calc-record-why "*Improper logarithmic unit" lunit)
1848       (let ((runits (math-simplify (math-div units lunit)))
1849             (coeff (math-simplify (math-div val units))))
1850         (math-mul
1851          (if (equal lunit '(var dB var-dB))
1852              (math-mul
1853               ref
1854               (math-conditional-pow
1855                10
1856                (math-div
1857                 coeff
1858                 (if power 10 20))))
1859            (math-mul
1860             ref
1861             (math-conditional-apply 'calcFunc-exp
1862              (if power
1863                  (math-mul 2 coeff)
1864                coeff))))
1865          runits)))))
1866
1867 (defvar calc-lu-field-reference)
1868 (defvar calc-lu-power-reference)
1869
1870 (defun calcFunc-lufquant (val &optional ref)
1871   (unless ref
1872     (setq ref (math-read-expr calc-lu-field-reference)))
1873   (math-logunits-quant val ref nil))
1874
1875 (defun calcFunc-lupquant (val &optional ref)
1876   (unless ref
1877     (setq ref (math-read-expr calc-lu-power-reference)))
1878   (math-logunits-quant val ref t))
1879
1880 (defun calc-lu-quant (arg)
1881   (interactive "P")
1882   (calc-slow-wrapper
1883    (if (calc-is-hyperbolic)
1884        (if (calc-is-option)
1885            (calc-binary-op "lupq" 'calcFunc-lufquant arg)
1886          (calc-unary-op "lupq" 'calcFunc-lufquant arg))
1887      (if (calc-is-option)
1888          (calc-binary-op "lufq" 'calcFunc-lupquant arg)
1889        (calc-unary-op "lufq" 'calcFunc-lupquant arg)))))
1890
1891 (defun math-logunits-level (val ref db power)
1892   "Compute the value of VAL in decibels or nepers."
1893       (let* ((ratio (math-simplify-units (math-div val ref)))
1894              (ratiou (math-simplify-units (math-remove-units ratio)))
1895              (units (math-simplify (math-extract-units ratio))))
1896         (math-mul
1897          (if db
1898              (math-mul
1899               (math-mul (if power 10 20)
1900                         (math-conditional-apply 'calcFunc-log10 ratiou))
1901               '(var dB var-dB))
1902            (math-mul
1903             (math-div (math-conditional-apply 'calcFunc-ln ratiou) (if power 2 1))
1904             '(var Np var-Np)))
1905          units)))
1906
1907 (defun calcFunc-dbfield (val &optional ref)
1908   (unless ref
1909     (setq ref (math-read-expr calc-lu-field-reference)))
1910   (math-logunits-level val ref t nil))
1911
1912 (defun calcFunc-dbpower (val &optional ref)
1913   (unless ref
1914     (setq ref (math-read-expr calc-lu-power-reference)))
1915   (math-logunits-level val ref t t))
1916
1917 (defun calcFunc-npfield (val &optional ref)
1918   (unless ref
1919     (setq ref (math-read-expr calc-lu-field-reference)))
1920   (math-logunits-level val ref nil nil))
1921
1922 (defun calcFunc-nppower (val &optional ref)
1923   (unless ref
1924     (setq ref (math-read-expr calc-lu-power-reference)))
1925   (math-logunits-level val ref nil t))
1926
1927 (defun calc-db (arg)
1928   (interactive "P")
1929   (calc-slow-wrapper
1930    (if (calc-is-hyperbolic)
1931        (if (calc-is-option)
1932            (calc-binary-op "ludb" 'calcFunc-dbfield arg)
1933          (calc-unary-op "ludb" 'calcFunc-dbfield arg))
1934      (if (calc-is-option)
1935          (calc-binary-op "ludb" 'calcFunc-dbpower arg)
1936        (calc-unary-op "ludb" 'calcFunc-dbpower arg)))))
1937
1938 (defun calc-np (arg)
1939   (interactive "P")
1940   (calc-slow-wrapper
1941    (if (calc-is-hyperbolic)
1942        (if (calc-is-option)
1943            (calc-binary-op "lunp" 'calcFunc-npfield arg)
1944          (calc-unary-op "lunp" 'calcFunc-npfield arg))
1945      (if (calc-is-option)
1946          (calc-binary-op "lunp" 'calcFunc-nppower arg)
1947        (calc-unary-op "lunp" 'calcFunc-nppower arg)))))
1948
1949 ;;; Musical notes
1950
1951
1952 (defvar calc-note-threshold)
1953
1954 (defun math-midi-round (num)
1955   "Round NUM to an integer N if NUM is within calc-note-threshold cents of N."
1956   (let* ((n (math-round num))
1957          (diff (math-abs
1958                 (math-sub num n))))
1959     (if (< (math-compare diff
1960                          (math-div (math-read-expr calc-note-threshold) 100)) 0)
1961         n
1962       num)))
1963
1964 (defconst math-notes
1965   '(((var C var-C) . 0)
1966     ((var Csharp var-Csharp) . 1)
1967 ;    ((var C♯ var-C♯) . 1)
1968     ((var Dflat var-Dflat) . 1)
1969 ;    ((var D♭ var-D♭) . 1)
1970     ((var D var-D) . 2)
1971     ((var Dsharp var-Dsharp) . 3)
1972 ;    ((var D♯ var-D♯) . 3)
1973     ((var E var-E) . 4)
1974     ((var F var-F) . 5)
1975     ((var Fsharp var-Fsharp) . 6)
1976 ;    ((var F♯ var-F♯) . 6)
1977     ((var Gflat var-Gflat) . 6)
1978 ;    ((var G♭ var-G♭) . 6)
1979     ((var G var-G) . 7)
1980     ((var Gsharp var-Gsharp) . 8)
1981 ;    ((var G♯ var-G♯) . 8)
1982     ((var A var-A) . 9)
1983     ((var Asharp var-Asharp) . 10)
1984 ;    ((var A♯ var-A♯) . 10)
1985     ((var Bflat var-Bflat) . 10)
1986 ;    ((var B♭ var-B♭) . 10)
1987     ((var B var-B) . 11))
1988   "An alist of notes with their number of semitones above C.")
1989
1990 (defun math-freqp (freq)
1991   "Non-nil if FREQ is a positive number times the unit Hz.
1992 If non-nil, return the coefficient of Hz."
1993   (let ((freqcoef (math-simplify-units
1994                    (math-div freq '(var Hz var-Hz)))))
1995     (if (Math-posp freqcoef) freqcoef)))
1996
1997 (defun math-midip (num)
1998   "Non-nil if NUM is a possible MIDI note number.
1999 If non-nil, return NUM."
2000   (if (Math-numberp num) num))
2001
2002 (defun math-spnp (spn)
2003   "Non-nil if NUM is a scientific pitch note (note + cents).
2004 If non-nil, return a list consisting of the note and the cents coefficient."
2005   (let (note cents rnote rcents)
2006     (if (eq (car-safe spn) '+)
2007         (setq note (nth 1 spn)
2008               cents (nth 2 spn))
2009       (setq note spn
2010             cents nil))
2011     (cond
2012      ((and  ;; NOTE is a note, CENTS is nil or cents.
2013        (eq (car-safe note) 'calcFunc-subscr)
2014        (assoc (nth 1 note) math-notes)
2015        (integerp (nth 2 note))
2016        (setq rnote note)
2017        (or
2018         (not cents)
2019         (Math-numberp (setq rcents
2020                             (math-simplify
2021                              (math-div cents '(var cents var-cents)))))))
2022       (list rnote rcents))
2023      ((and  ;; CENTS is a note, NOTE is cents.
2024        (eq (car-safe cents) 'calcFunc-subscr)
2025        (assoc (nth 1 cents) math-notes)
2026        (integerp (nth 2 cents))
2027        (setq rnote cents)
2028        (or
2029         (not note)
2030         (Math-numberp (setq rcents
2031                             (math-simplify
2032                              (math-div note '(var cents var-cents)))))))
2033       (list rnote rcents)))))
2034
2035 (defun math-freq-to-midi (freq)
2036   "Return the midi note number corresponding to FREQ Hz."
2037   (let ((midi (math-add
2038                69
2039                (math-mul
2040                 12
2041                 (calcFunc-log
2042                  (math-div freq 440)
2043                  2)))))
2044     (math-midi-round midi)))
2045
2046 (defun math-spn-to-midi (spn)
2047   "Return the MIDI number corresponding to SPN."
2048   (let* ((note (cdr (assoc (nth 1 (car spn)) math-notes)))
2049          (octave (math-add (nth 2 (car spn)) 1))
2050          (cents (nth 1 spn))
2051          (midi  (math-add
2052                  (math-mul 12 octave)
2053                  note)))
2054     (if cents
2055         (math-add midi (math-div cents 100))
2056       midi)))
2057
2058 (defun math-midi-to-spn (midi)
2059   "Return the scientific pitch notation corresponding to midi number MIDI."
2060   (let (midin cents)
2061     (if (math-integerp midi)
2062         (setq midin midi
2063               cents nil)
2064       (setq midin (math-floor midi)
2065             cents (math-mul 100 (math-sub midi midin))))
2066     (let* ((nr ;; This should be (math-idivmod midin 12), but with
2067                ;; better behavior for negative midin.
2068             (if (Math-negp midin)
2069                 (let ((dm (math-idivmod (math-neg midin) 12)))
2070                   (if (= (cdr dm) 0)
2071                       (cons (math-neg (car dm)) 0)
2072                     (cons
2073                      (math-sub (math-neg (car dm)) 1)
2074                      (math-sub 12 (cdr dm)))))
2075               (math-idivmod midin 12)))
2076            (n (math-sub (car nr) 1))
2077            (note (car (rassoc (cdr nr) math-notes))))
2078       (if cents
2079           (list '+ (list 'calcFunc-subscr note n)
2080                    (list '* cents '(var cents var-cents)))
2081         (list 'calcFunc-subscr note n)))))
2082
2083 (defun math-freq-to-spn (freq)
2084   "Return the scientific pitch notation corresponding to FREQ Hz."
2085   (math-with-extra-prec 3
2086     (math-midi-to-spn (math-freq-to-midi freq))))
2087
2088 (defun math-midi-to-freq (midi)
2089   "Return the frequency of the note with midi number MIDI."
2090   (list '*
2091         (math-mul
2092          440
2093          (math-pow
2094           2
2095           (math-div
2096            (math-sub
2097             midi
2098             69)
2099            12)))
2100         '(var Hz var-Hz)))
2101
2102 (defun math-spn-to-freq (spn)
2103   "Return the frequency of the note with scientific pitch notation SPN."
2104   (math-midi-to-freq (math-spn-to-midi spn)))
2105
2106 (defun calcFunc-spn (expr)
2107   "Return EXPR written as scientific pitch notation + cents."
2108   ;; Get the coefficient of Hz
2109   (let (note)
2110     (cond
2111      ((setq note (math-freqp expr))
2112       (math-freq-to-spn note))
2113      ((setq note (math-midip expr))
2114       (math-midi-to-spn note))
2115      ((math-spnp expr)
2116       expr)
2117      (t
2118       (math-reject-arg expr "*Improper expression")))))
2119
2120 (defun calcFunc-midi (expr)
2121   "Return EXPR written as a MIDI number."
2122   (let (note)
2123     (cond
2124      ((setq note (math-freqp expr))
2125       (math-freq-to-midi note))
2126      ((setq note (math-spnp expr))
2127       (math-spn-to-midi note))
2128      ((math-midip expr)
2129       expr)
2130      (t
2131       (math-reject-arg expr "*Improper expression")))))
2132
2133 (defun calcFunc-freq (expr)
2134   "Return the frequency corresponding to EXPR."
2135   (let (note)
2136     (cond
2137      ((setq note (math-midip expr))
2138       (math-midi-to-freq note))
2139      ((setq note (math-spnp expr))
2140       (math-spn-to-freq note))
2141      ((math-freqp expr)
2142       expr)
2143      (t
2144       (math-reject-arg expr "*Improper expression")))))
2145
2146 (defun calc-freq (arg)
2147   "Return the frequency corresponding to the expression on the stack."
2148   (interactive "P")
2149   (calc-slow-wrapper
2150    (calc-unary-op "freq" 'calcFunc-freq arg)))
2151
2152 (defun calc-midi (arg)
2153   "Return the MIDI number corresponding to the expression on the stack."
2154   (interactive "P")
2155   (calc-slow-wrapper
2156    (calc-unary-op "midi" 'calcFunc-midi arg)))
2157
2158 (defun calc-spn (arg)
2159   "Return the scientific pitch notation corresponding to the expression on the stack."
2160   (interactive "P")
2161   (calc-slow-wrapper
2162    (calc-unary-op "spn" 'calcFunc-spn arg)))
2163
2164
2165 (provide 'calc-units)
2166
2167 ;;; calc-units.el ends here