lisp/calc/calc-units.el

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