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          (unless (math-units-in-expr-p uold t)
 474            (error "No units specified"))
 475          (when (eq (car-safe uold) 'error)
 476            (error "Bad format in units expression: %s" (nth 1 uold)))
 477          (setq expr (math-mul expr uold))))
 478      (setq defunits (math-get-default-units expr))
 479      (unless new-units
 480        (setq new-units
 481              (read-string (concat
 482                            (if (and uoldname (not nouold))
 483                                (concat "Old units: "
 484                                        uoldname
 485                                        ", new units")
 486                              "New units")
 487                            (if defunits
 488                                (concat
 489                                 " (default "
 490                                 defunits
 491                                 "): ")
 492                              ": "))))
 493        (if (and
 494             (string= new-units "")
 495             defunits)
 496            (setq new-units defunits)))
 497      (when (string-match "\\` */" new-units)
 498        (setq new-units (concat "1" new-units)))
 499      (setq units (math-read-expr new-units))
 500      (when (eq (car-safe units) 'error)
 501        (error "Bad format in units expression: %s" (nth 2 units)))
 502      (if calc-ensure-consistent-units
 503          (math-check-unit-consistency expr units))
 504      (let ((unew (math-units-in-expr-p units t))
 505            (std (and (eq (car-safe units) 'var)
 506                      (assq (nth 1 units) math-standard-units-systems)))
 507            (comp (eq (car-safe units) '+)))
 508        (unless (or unew std)
 509          (error "No units specified"))
 510        (let* ((noold (and uoldname (not (equal uoldname "1"))))
 511               (res
 512                (if std
 513                    (math-simplify-units (math-to-standard-units expr (nth 1 std)))
 514                  (math-convert-units expr units noold))))
 515          (unless std
 516            (math-put-default-units (if noold units res) (if comp units)))
 517          (calc-enter-result 1 "cvun" res))))))
 518
 519 (defun calc-convert-exact-units ()
 520   (interactive)
 521   (calc-slow-wrapper
 522    (let* ((expr (calc-top-n 1)))
 523      (unless (math-units-in-expr-p expr t)
 524        (error "No units in expression."))
 525      (let* ((old-units (math-extract-units expr))
 526             (defunits (math-get-default-units expr))
 527             units
 528             (new-units
 529              (read-string (concat "New units"
 530                                   (if defunits
 531                                      (concat
 532                                       " (default "
 533                                       defunits
 534                                       "): ")
 535                                    ": ")))))
 536        (if (and
 537             (string= new-units "")
 538             defunits)
 539            (setq new-units defunits))
 540        (setq units (math-read-expr new-units))
 541        (when (eq (car-safe units) 'error)
 542          (error "Bad format in units expression: %s" (nth 2 units)))
 543        (math-check-unit-consistency old-units units)
 544        (let ((res
 545               (list '* (math-mul (math-remove-units expr)
 546                                  (math-simplify-units
 547                                   (math-to-standard-units (list '/ old-units units) nil)))
 548                     units)))
 549          (calc-enter-result 1 "cvxu" res))))))
 550
 551 (defun calc-autorange-units (arg)
 552   (interactive "P")
 553   (calc-wrapper
 554    (calc-change-mode 'calc-autorange-units arg nil t)
 555    (message (if calc-autorange-units
 556                 "Adjusting target unit prefix automatically"
 557               "Using target units exactly"))))
 558
 559 (defun calc-convert-temperature (&optional old-units new-units)
 560   (interactive)
 561   (calc-slow-wrapper
 562    (let ((expr (calc-top-n 1))
 563          (uold nil)
 564          (uoldname nil)
 565          unew
 566          defunits)
 567      (setq uold (or old-units
 568                     (let ((units (math-single-units-in-expr-p expr)))
 569                       (if units
 570                           (if (consp units)
 571                               (list 'var (car units)
 572                                     (intern (concat "var-"
 573                                                     (symbol-name
 574                                                      (car units)))))
 575                             (error "Not a pure temperature expression"))
 576                         (math-read-expr
 577                          (setq uoldname (read-string
 578                                          "Old temperature units: ")))))))
 579      (when (eq (car-safe uold) 'error)
 580        (error "Bad format in units expression: %s" (nth 2 uold)))
 581      (or (math-units-in-expr-p expr nil)
 582          (setq expr (math-mul expr uold)))
 583      (setq defunits (math-get-default-units expr))
 584      (setq unew (or new-units
 585                     (read-string
 586                      (concat
 587                       (if uoldname
 588                           (concat "Old temperature units: "
 589                                   uoldname
 590                                   ", new units")
 591                         "New temperature units")
 592                       (if defunits
 593                           (concat " (default "
 594                                   defunits
 595                                   "): ")
 596                         ": ")))))
 597      (setq unew (math-read-expr (if (string= unew "") defunits unew)))
 598      (when (eq (car-safe unew) 'error)
 599        (error "Bad format in units expression: %s" (nth 2 unew)))
 600      (math-put-default-units unew)
 601      (let ((ntemp (calc-normalize
 602                    (math-simplify-units
 603                     (math-convert-temperature expr uold unew
 604                                               uoldname)))))
 605        (if (Math-zerop ntemp)
 606            (setq ntemp (list '* ntemp unew)))
 607        (let ((calc-simplify-mode 'none))
 608          (calc-enter-result 1 "cvtm" ntemp))))))
 609
 610 (defun calc-remove-units ()
 611   (interactive)
 612   (calc-slow-wrapper
 613    (calc-enter-result 1 "rmun" (math-simplify-units
 614                                 (math-remove-units (calc-top-n 1))))))
 615
 616 (defun calc-extract-units ()
 617   (interactive)
 618   (calc-slow-wrapper
 619    (calc-enter-result 1 "exun" (math-simplify-units
 620                                 (math-extract-units (calc-top-n 1))))))
 621
 622 ;; The variables calc-num-units and calc-den-units are local to
 623 ;; calc-explain-units, but are used by calc-explain-units-rec,
 624 ;; which is called by calc-explain-units.
 625 (defvar calc-num-units)
 626 (defvar calc-den-units)
 627
 628 (defun calc-explain-units ()
 629   (interactive)
 630   (calc-wrapper
 631    (let ((calc-num-units nil)
 632          (calc-den-units nil))
 633      (calc-explain-units-rec (calc-top-n 1) 1)
 634      (and calc-den-units (string-match "^[^(].* .*[^)]$" calc-den-units)
 635           (setq calc-den-units (concat "(" calc-den-units ")")))
 636      (if calc-num-units
 637          (if calc-den-units
 638              (message "%s per %s" calc-num-units calc-den-units)
 639            (message "%s" calc-num-units))
 640        (if calc-den-units
 641            (message "1 per %s" calc-den-units)
 642          (message "No units in expression"))))))
 643
 644 (defun calc-explain-units-rec (expr pow)
 645   (let ((u (math-check-unit-name expr))
 646         pos)
 647     (if (and u (not (math-zerop pow)))
 648         (let ((name (or (nth 2 u) (symbol-name (car u)))))
 649           (if (eq (aref name 0) ?\*)
 650               (setq name (substring name 1)))
 651           (if (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name)
 652               (if (string-match "^[a-zA-Zα-ωΑ-Ω0-9' ()]*$" name)
 653                   (while (setq pos (string-match "[ ()]" name))
 654                     (setq name (concat (substring name 0 pos)
 655                                        (if (eq (aref name pos) 32) "-" "")
 656                                        (substring name (1+ pos)))))
 657                 (setq name (concat "(" name ")"))))
 658           (or (eq (nth 1 expr) (car u))
 659               (setq name (concat (nth 2 (assq (aref (symbol-name
 660                                                      (nth 1 expr)) 0)
 661                                               math-unit-prefixes))
 662                                  (if (and (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name)
 663                                           (not (memq (car u) '(mHg gf))))
 664                                      (concat "-" name)
 665                                    (downcase name)))))
 666           (cond ((or (math-equal-int pow 1)
 667                      (math-equal-int pow -1)))
 668                 ((or (math-equal-int pow 2)
 669                      (math-equal-int pow -2))
 670                  (if (equal (nth 4 u) '((m . 1)))
 671                      (setq name (concat "Square-" name))
 672                    (setq name (concat name "-squared"))))
 673                 ((or (math-equal-int pow 3)
 674                      (math-equal-int pow -3))
 675                  (if (equal (nth 4 u) '((m . 1)))
 676                      (setq name (concat "Cubic-" name))
 677                    (setq name (concat name "-cubed"))))
 678                 (t
 679                  (setq name (concat name "^"
 680                                     (math-format-number (math-abs pow))))))
 681           (if (math-posp pow)
 682               (setq calc-num-units (if calc-num-units
 683                                   (concat calc-num-units " " name)
 684                                 name))
 685             (setq calc-den-units (if calc-den-units
 686                                 (concat calc-den-units " " name)
 687                               name))))
 688       (cond ((eq (car-safe expr) '*)
 689              (calc-explain-units-rec (nth 1 expr) pow)
 690              (calc-explain-units-rec (nth 2 expr) pow))
 691             ((eq (car-safe expr) '/)
 692              (calc-explain-units-rec (nth 1 expr) pow)
 693              (calc-explain-units-rec (nth 2 expr) (- pow)))
 694             ((memq (car-safe expr) '(neg + -))
 695              (calc-explain-units-rec (nth 1 expr) pow))
 696             ((and (eq (car-safe expr) '^)
 697                   (math-realp (nth 2 expr)))
 698              (calc-explain-units-rec (nth 1 expr)
 699                                      (math-mul pow (nth 2 expr))))))))
 700
 701 (defun calc-simplify-units ()
 702   (interactive)
 703   (calc-slow-wrapper
 704    (calc-with-default-simplification
 705     (calc-enter-result 1 "smun" (math-simplify-units (calc-top-n 1))))))
 706
 707 (defun calc-view-units-table (n)
 708   (interactive "P")
 709   (and n (setq math-units-table-buffer-valid nil))
 710   (let ((win (get-buffer-window "*Units Table*")))
 711     (if (and win
 712              math-units-table
 713              math-units-table-buffer-valid)
 714         (progn
 715           (bury-buffer (window-buffer win))
 716           (let ((curwin (selected-window)))
 717             (select-window win)
 718             (switch-to-buffer nil)
 719             (select-window curwin)))
 720       (math-build-units-table-buffer nil))))
 721
 722 (defun calc-enter-units-table (n)
 723   (interactive "P")
 724   (and n (setq math-units-table-buffer-valid nil))
 725   (math-build-units-table-buffer t)
 726   (message "%s" (substitute-command-keys "Type \\[calc] to return to the Calculator")))
 727
 728 (defun calc-define-unit (uname desc &optional disp)
 729   (interactive "SDefine unit name: \nsDescription: \nP")
 730   (if disp (setq disp (read-string "Display definition: ")))
 731   (calc-wrapper
 732    (let ((form (calc-top-n 1))
 733          (unit (assq uname math-additional-units)))
 734      (or unit
 735          (setq math-additional-units
 736                (cons (setq unit (list uname nil nil nil nil))
 737                      math-additional-units)
 738                math-units-table nil))
 739      (setcar (cdr unit) (and (not (and (eq (car-safe form) 'var)
 740                                        (eq (nth 1 form) uname)))
 741                              (not (math-equal-int form 1))
 742                              (math-format-flat-expr form 0)))
 743      (setcar (cdr (cdr unit)) (and (not (equal desc ""))
 744                                    desc))
 745      (if disp
 746          (setcar (cdr (cdr (cdr (cdr unit)))) disp))))
 747   (calc-invalidate-units-table))
 748
 749 (defun calc-undefine-unit (uname)
 750   (interactive "SUndefine unit name: ")
 751   (calc-wrapper
 752    (let ((unit (assq uname math-additional-units)))
 753      (or unit
 754          (if (assq uname math-standard-units)
 755              (error "\"%s\" is a predefined unit name" uname)
 756            (error "Unit name \"%s\" not found" uname)))
 757      (setq math-additional-units (delq unit math-additional-units)
 758            math-units-table nil)))
 759   (calc-invalidate-units-table))
 760
 761 (defun calc-invalidate-units-table ()
 762   (setq math-units-table nil)
 763   (let ((buf (get-buffer "*Units Table*")))
 764     (and buf
 765          (with-current-buffer buf
 766            (save-excursion
 767              (goto-char (point-min))
 768              (if (looking-at "Calculator Units Table")
 769                  (let ((inhibit-read-only t))
 770                    (insert "(Obsolete) "))))))))
 771
 772 (defun calc-get-unit-definition (uname)
 773   (interactive "SGet definition for unit: ")
 774   (calc-wrapper
 775    (math-build-units-table)
 776    (let ((unit (assq uname math-units-table)))
 777      (or unit
 778          (error "Unit name \"%s\" not found" uname))
 779      (let ((msg (nth 2 unit)))
 780        (if (stringp msg)
 781            (if (string-match "^\\*" msg)
 782                (setq msg (substring msg 1)))
 783          (setq msg (symbol-name uname)))
 784        (if (nth 1 unit)
 785            (progn
 786              (calc-enter-result 0 "ugdf" (nth 1 unit))
 787              (message "Derived unit: %s" msg))
 788          (calc-enter-result 0 "ugdf" (list 'var uname
 789                                            (intern
 790                                             (concat "var-"
 791                                                     (symbol-name uname)))))
 792          (message "Base unit: %s" msg))))))
 793
 794 (defun calc-permanent-units ()
 795   (interactive)
 796   (calc-wrapper
 797    (let (pos)
 798      (set-buffer (find-file-noselect (substitute-in-file-name
 799                                       calc-settings-file)))
 800      (goto-char (point-min))
 801      (if (and (search-forward ";;; Custom units stored by Calc" nil t)
 802               (progn
 803                 (beginning-of-line)
 804                 (setq pos (point))
 805                 (search-forward "\n;;; End of custom units" nil t)))
 806          (progn
 807            (beginning-of-line)
 808            (forward-line 1)
 809            (delete-region pos (point)))
 810        (goto-char (point-max))
 811        (insert "\n\n")
 812        (forward-char -1))
 813      (insert ";;; Custom units stored by Calc on " (current-time-string) "\n")
 814      (if math-additional-units
 815          (progn
 816            (insert "(setq math-additional-units '(\n")
 817            (let ((list math-additional-units))
 818              (while list
 819                (insert "  (" (symbol-name (car (car list))) " "
 820                        (if (nth 1 (car list))
 821                            (if (stringp (nth 1 (car list)))
 822                                (prin1-to-string (nth 1 (car list)))
 823                              (prin1-to-string (math-format-flat-expr
 824                                                (nth 1 (car list)) 0)))
 825                          "nil")
 826                        " "
 827                        (prin1-to-string (nth 2 (car list)))
 828                        ")\n")
 829                (setq list (cdr list))))
 830            (insert "))\n"))
 831        (insert ";;; (no custom units defined)\n"))
 832      (insert ";;; End of custom units\n")
 833      (save-buffer))))
 834
 835
 836 ;; The variable math-cu-unit-list is local to math-build-units-table,
 837 ;; but is used by math-compare-unit-names, which is called (indirectly)
 838 ;; by math-build-units-table.
 839 ;; math-cu-unit-list is also local to math-convert-units, but is used
 840 ;; by math-convert-units-rec, which is called by math-convert-units.
 841 (defvar math-cu-unit-list)
 842
 843 (defun math-build-units-table ()
 844   (or math-units-table
 845       (let* ((combined-units (append math-additional-units
 846                                      math-standard-units))
 847              (math-cu-unit-list (mapcar 'car combined-units))
 848              tab)
 849         (message "Building units table...")
 850         (setq math-units-table-buffer-valid nil)
 851         (setq tab (mapcar (function
 852                            (lambda (x)
 853                              (list (car x)
 854                                    (and (nth 1 x)
 855                                         (if (stringp (nth 1 x))
 856                                             (let ((exp (math-read-plain-expr
 857                                                         (nth 1 x))))
 858                                               (if (eq (car-safe exp) 'error)
 859                                                   (error "Format error in definition of %s in units table: %s"
 860                                                          (car x) (nth 2 exp))
 861                                                 exp))
 862                                           (nth 1 x)))
 863                                    (nth 2 x)
 864                                    (nth 3 x)
 865                                    (and (not (nth 1 x))
 866                                         (list (cons (car x) 1)))
 867                                    (nth 4 x))))
 868                           combined-units))
 869         (let ((math-units-table tab))
 870           (mapc 'math-find-base-units tab))
 871         (message "Building units table...done")
 872         (setq math-units-table tab))))
 873
 874 ;; The variables math-fbu-base and math-fbu-entry are local to
 875 ;; math-find-base-units, but are used by math-find-base-units-rec,
 876 ;; which is called by math-find-base-units.
 877 (defvar math-fbu-base)
 878 (defvar math-fbu-entry)
 879
 880 (defun math-find-base-units (math-fbu-entry)
 881   (if (eq (nth 4 math-fbu-entry) 'boom)
 882       (error "Circular definition involving unit %s" (car math-fbu-entry)))
 883   (or (nth 4 math-fbu-entry)
 884       (let (math-fbu-base)
 885         (setcar (nthcdr 4 math-fbu-entry) 'boom)
 886         (math-find-base-units-rec (nth 1 math-fbu-entry) 1)
 887         '(or math-fbu-base
 888             (error "Dimensionless definition for unit %s" (car math-fbu-entry)))
 889         (while (eq (cdr (car math-fbu-base)) 0)
 890           (setq math-fbu-base (cdr math-fbu-base)))
 891         (let ((b math-fbu-base))
 892           (while (cdr b)
 893             (if (eq (cdr (car (cdr b))) 0)
 894                 (setcdr b (cdr (cdr b)))
 895               (setq b (cdr b)))))
 896         (setq math-fbu-base (sort math-fbu-base 'math-compare-unit-names))
 897         (setcar (nthcdr 4 math-fbu-entry) math-fbu-base)
 898         math-fbu-base)))
 899
 900 (defun math-compare-unit-names (a b)
 901   (memq (car b) (cdr (memq (car a) math-cu-unit-list))))
 902
 903 (defun math-find-base-units-rec (expr pow)
 904   (let ((u (math-check-unit-name expr)))
 905     (cond (u
 906            (let ((ulist (math-find-base-units u)))
 907              (while ulist
 908                (let ((p (* (cdr (car ulist)) pow))
 909                      (old (assq (car (car ulist)) math-fbu-base)))
 910                  (if old
 911                      (setcdr old (+ (cdr old) p))
 912                    (setq math-fbu-base
 913                          (cons (cons (car (car ulist)) p) math-fbu-base))))
 914                (setq ulist (cdr ulist)))))
 915           ((math-scalarp expr))
 916           ((and (eq (car expr) '^)
 917                 (integerp (nth 2 expr)))
 918            (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr))))
 919           ((eq (car expr) '*)
 920            (math-find-base-units-rec (nth 1 expr) pow)
 921            (math-find-base-units-rec (nth 2 expr) pow))
 922           ((eq (car expr) '/)
 923            (math-find-base-units-rec (nth 1 expr) pow)
 924            (math-find-base-units-rec (nth 2 expr) (- pow)))
 925           ((eq (car expr) 'neg)
 926            (math-find-base-units-rec (nth 1 expr) pow))
 927           ((eq (car expr) '+)
 928            (math-find-base-units-rec (nth 1 expr) pow))
 929           ((eq (car expr) 'var)
 930            (or (eq (nth 1 expr) 'pi)
 931                (error "Unknown name %s in defining expression for unit %s"
 932                       (nth 1 expr) (car math-fbu-entry))))
 933           ((equal expr '(calcFunc-ln 10)))
 934           (t (error "Malformed defining expression for unit %s" (car math-fbu-entry))))))
 935
 936
 937 (defun math-units-in-expr-p (expr sub-exprs)
 938   (and (consp expr)
 939        (if (eq (car expr) 'var)
 940            (math-check-unit-name expr)
 941          (if (eq (car expr) 'neg)
 942              (math-units-in-expr-p (nth 1 expr) sub-exprs)
 943            (and (or sub-exprs
 944                     (memq (car expr) '(* / ^)))
 945                 (or (math-units-in-expr-p (nth 1 expr) sub-exprs)
 946                     (math-units-in-expr-p (nth 2 expr) sub-exprs)))))))
 947
 948 (defun math-only-units-in-expr-p (expr)
 949   (and (consp expr)
 950        (if (eq (car expr) 'var)
 951            (math-check-unit-name expr)
 952          (if (memq (car expr) '(* /))
 953              (and (math-only-units-in-expr-p (nth 1 expr))
 954                   (math-only-units-in-expr-p (nth 2 expr)))
 955            (and (eq (car expr) '^)
 956                 (and (math-only-units-in-expr-p (nth 1 expr))
 957                      (math-realp (nth 2 expr))))))))
 958
 959 (defun math-single-units-in-expr-p (expr)
 960   (cond ((math-scalarp expr) nil)
 961         ((eq (car expr) 'var)
 962          (math-check-unit-name expr))
 963         ((eq (car expr) 'neg)
 964          (math-single-units-in-expr-p (nth 1 expr)))
 965         ((eq (car expr) '*)
 966          (let ((u1 (math-single-units-in-expr-p (nth 1 expr)))
 967                (u2 (math-single-units-in-expr-p (nth 2 expr))))
 968            (or (and u1 u2 'wrong)
 969                u1
 970                u2)))
 971         ((eq (car expr) '/)
 972          (if (math-units-in-expr-p (nth 2 expr) nil)
 973              'wrong
 974            (math-single-units-in-expr-p (nth 1 expr))))
 975         (t 'wrong)))
 976
 977 (defun math-consistent-units-p (expr newunits)
 978   "Non-nil if EXPR and NEWUNITS have consistent units."
 979   (or
 980    (and (eq (car-safe newunits) 'var)
 981         (assq (nth 1 newunits) math-standard-units-systems))
 982    (math-numberp (math-get-units (math-to-standard-units (list '/ expr newunits) nil)))))
 983
 984 (defun math-check-unit-consistency (expr units)
 985   "Give an error if EXPR and UNITS do not have consistent units."
 986   (unless  (math-consistent-units-p expr units)
 987     (error "New units (%s) are inconsistent with current units (%s)"
 988            (math-format-value units)
 989            (math-format-value (math-get-units expr)))))
 990
 991 (defun math-check-unit-name (v)
 992   (and (eq (car-safe v) 'var)
 993        (or (assq (nth 1 v) (or math-units-table (math-build-units-table)))
 994            (let ((name (symbol-name (nth 1 v))))
 995              (and (> (length name) 1)
 996                   (assq (aref name 0) math-unit-prefixes)
 997                   (or (assq (intern (substring name 1)) math-units-table)
 998                       (and (eq (aref name 0) ?M)
 999                            (> (length name) 3)
1000                            (eq (aref name 1) ?e)
1001                            (eq (aref name 2) ?g)
1002                            (assq (intern (substring name 3))
1003                                  math-units-table))))))))
1004
1005 ;; The variable math-which-standard is local to math-to-standard-units,
1006 ;; but is used by math-to-standard-rec, which is called by
1007 ;; math-to-standard-units.
1008 (defvar math-which-standard)
1009
1010 (defun math-to-standard-units (expr math-which-standard)
1011   (math-to-standard-rec expr))
1012
1013 (defun math-to-standard-rec (expr)
1014   (if (eq (car-safe expr) 'var)
1015       (let ((u (math-check-unit-name expr))
1016             (base (nth 1 expr)))
1017         (if u
1018             (progn
1019               (if (nth 1 u)
1020                   (setq expr (math-to-standard-rec (nth 1 u)))
1021                 (let ((st (assq (car u) math-which-standard)))
1022                   (if st
1023                       (setq expr (nth 1 st))
1024                     (setq expr (list 'var (car u)
1025                                      (intern (concat "var-"
1026                                                      (symbol-name
1027                                                       (car u)))))))))
1028               (or (null u)
1029                   (eq base (car u))
1030                   (setq expr (list '*
1031                                    (nth 1 (assq (aref (symbol-name base) 0)
1032                                                 math-unit-prefixes))
1033                                    expr)))
1034               expr)
1035           (if (eq base 'pi)
1036               (math-pi)
1037             expr)))
1038     (if (or
1039          (Math-primp expr)
1040          (and (eq (car-safe expr) 'calcFunc-subscr)
1041               (eq (car-safe (nth 1 expr)) 'var)))
1042         expr
1043       (cons (car expr)
1044             (mapcar 'math-to-standard-rec (cdr expr))))))
1045
1046 (defun math-apply-units (expr units ulist &optional pure)
1047   (setq expr (math-simplify-units expr))
1048   (if ulist
1049       (let ((new 0)
1050             value)
1051         (or (math-numberp expr)
1052             (error "Incompatible units"))
1053         (while (cdr ulist)
1054           (setq value (math-div expr (nth 1 (car ulist)))
1055                 value (math-floor (let ((calc-internal-prec
1056                                          (1- calc-internal-prec)))
1057                                     (math-normalize value)))
1058                 new (math-add new (math-mul value (car (car ulist))))
1059                 expr (math-sub expr (math-mul value (nth 1 (car ulist))))
1060                 ulist (cdr ulist)))
1061         (math-add new (math-mul (math-div expr (nth 1 (car ulist)))
1062                                 (car (car ulist)))))
1063     (if pure
1064         expr
1065       (math-simplify-units (list '* expr units)))))
1066
1067 (defvar math-decompose-units-cache nil)
1068 (defun math-decompose-units (units)
1069   (let ((u (math-check-unit-name units)))
1070     (and u (eq (car-safe (nth 1 u)) '+)
1071          (setq units (nth 1 u))))
1072   (setq units (calcFunc-expand units))
1073   (and (eq (car-safe units) '+)
1074        (let ((entry (list units calc-internal-prec calc-prefer-frac)))
1075          (or (equal entry (car math-decompose-units-cache))
1076              (let ((ulist nil)
1077                    (utemp units)
1078                    qty unit)
1079                (while (eq (car-safe utemp) '+)
1080                  (setq ulist (cons (math-decompose-unit-part (nth 2 utemp))
1081                                    ulist)
1082                        utemp (nth 1 utemp)))
1083                (setq ulist (cons (math-decompose-unit-part utemp) ulist)
1084                      utemp ulist)
1085                (while (setq utemp (cdr utemp))
1086                  (unless (equal (nth 2 (car utemp)) (nth 2 (car ulist)))
1087                    (error "Inconsistent units in sum")))
1088                (setq math-decompose-units-cache
1089                      (cons entry
1090                            (sort ulist
1091                                  (function
1092                                   (lambda (x y)
1093                                     (not (Math-lessp (nth 1 x)
1094                                                      (nth 1 y))))))))))
1095          (cdr math-decompose-units-cache))))
1096
1097 (defun math-decompose-unit-part (unit)
1098   (cons unit
1099         (math-is-multiple (math-simplify-units (math-to-standard-units
1100                                                 unit nil))
1101                           t)))
1102
1103 ;; The variable math-fcu-u is local to math-find-compatible-unit,
1104 ;; but is used by math-find-compatible-rec which is called by
1105 ;; math-find-compatible-unit.
1106 (defvar math-fcu-u)
1107
1108 (defun math-find-compatible-unit (expr unit)
1109   (let ((math-fcu-u (math-check-unit-name unit)))
1110     (if math-fcu-u
1111         (math-find-compatible-unit-rec expr 1))))
1112
1113 (defun math-find-compatible-unit-rec (expr pow)
1114   (cond ((eq (car-safe expr) '*)
1115          (or (math-find-compatible-unit-rec (nth 1 expr) pow)
1116              (math-find-compatible-unit-rec (nth 2 expr) pow)))
1117         ((eq (car-safe expr) '/)
1118          (or (math-find-compatible-unit-rec (nth 1 expr) pow)
1119              (math-find-compatible-unit-rec (nth 2 expr) (- pow))))
1120         ((eq (car-safe expr) 'neg)
1121          (math-find-compatible-unit-rec (nth 1 expr) pow))
1122         ((and (eq (car-safe expr) '^)
1123               (integerp (nth 2 expr)))
1124          (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr))))
1125         (t
1126          (let ((u2 (math-check-unit-name expr)))
1127            (if (equal (nth 4 math-fcu-u) (nth 4 u2))
1128                (cons expr pow))))))
1129
1130 ;; The variables math-cu-new-units and math-cu-pure are local to
1131 ;; math-convert-units, but are used by math-convert-units-rec,
1132 ;; which is called by math-convert-units.
1133 (defvar math-cu-new-units)
1134 (defvar math-cu-pure)
1135
1136 (defun math-convert-units (expr math-cu-new-units &optional math-cu-pure)
1137   (if (eq (car-safe math-cu-new-units) 'var)
1138       (let ((unew (assq (nth 1 math-cu-new-units)
1139                         (math-build-units-table))))
1140         (if (eq (car-safe (nth 1 unew)) '+)
1141             (setq math-cu-new-units (nth 1 unew)))))
1142   (math-with-extra-prec 2
1143     (let ((compat (and (not math-cu-pure)
1144                        (math-find-compatible-unit expr math-cu-new-units)))
1145           (math-cu-unit-list nil)
1146           (math-combining-units nil))
1147       (if compat
1148           (math-simplify-units
1149            (math-mul (math-mul (math-simplify-units
1150                                 (math-div expr (math-pow (car compat)
1151                                                          (cdr compat))))
1152                                (math-pow math-cu-new-units (cdr compat)))
1153                      (math-simplify-units
1154                       (math-to-standard-units
1155                        (math-pow (math-div (car compat) math-cu-new-units)
1156                                  (cdr compat))
1157                        nil))))
1158         (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units))
1159           (setq math-cu-new-units (nth 2 (car math-cu-unit-list))))
1160         (when (eq (car-safe expr) '+)
1161           (setq expr (math-simplify-units expr)))
1162         (if (math-units-in-expr-p expr t)
1163             (math-convert-units-rec expr)
1164           (math-apply-units (math-to-standard-units
1165                              (list '/ expr math-cu-new-units) nil)
1166                             math-cu-new-units math-cu-unit-list math-cu-pure))))))
1167
1168 (defun math-convert-units-rec (expr)
1169   (if (math-units-in-expr-p expr nil)
1170       (math-apply-units (math-to-standard-units
1171                          (list '/ expr math-cu-new-units) nil)
1172                         math-cu-new-units math-cu-unit-list math-cu-pure)
1173     (if (Math-primp expr)
1174         expr
1175       (cons (car expr)
1176             (mapcar 'math-convert-units-rec (cdr expr))))))
1177
1178 (defun math-convert-temperature (expr old new &optional pure)
1179   (let* ((units (math-single-units-in-expr-p expr))
1180          (uold (if old
1181                    (if (or (null units)
1182                            (equal (nth 1 old) (car units)))
1183                        (math-check-unit-name old)
1184                      (error "Inconsistent temperature units"))
1185                  units))
1186          (unew (math-check-unit-name new)))
1187     (unless (and (consp unew) (nth 3 unew))
1188       (error "Not a valid temperature unit"))
1189     (unless (and (consp uold) (nth 3 uold))
1190       (error "Not a pure temperature expression"))
1191     (let ((v (car uold)))
1192       (setq expr (list '/ expr (list 'var v
1193                                      (intern (concat "var-"
1194                                                      (symbol-name v)))))))
1195     (or (eq (nth 3 uold) (nth 3 unew))
1196         (cond ((eq (nth 3 uold) 'K)
1197                (setq expr (list '- expr '(/ 27315 100)))
1198                (if (eq (nth 3 unew) 'F)
1199                    (setq expr (list '+ (list '* expr '(/ 9 5)) 32))))
1200               ((eq (nth 3 uold) 'C)
1201                (if (eq (nth 3 unew) 'F)
1202                    (setq expr (list '+ (list '* expr '(/ 9 5)) 32))
1203                  (setq expr (list '+ expr '(/ 27315 100)))))
1204               (t
1205                (setq expr (list '* (list '- expr 32) '(/ 5 9)))
1206                (if (eq (nth 3 unew) 'K)
1207                    (setq expr (list '+ expr '(/ 27315 100)))))))
1208     (if pure
1209         expr
1210       (list '* expr new))))
1211
1212
1213
1214 (defun math-simplify-units (a)
1215   (let ((math-simplifying-units t)
1216         (calc-matrix-mode 'scalar))
1217     (math-simplify a)))
1218 (defalias 'calcFunc-usimplify 'math-simplify-units)
1219
1220 ;; The function created by math-defsimplify uses the variable
1221 ;; math-simplify-expr, and so is used by functions in math-defsimplify
1222 (defvar math-simplify-expr)
1223
1224 (math-defsimplify (+ -)
1225   (and math-simplifying-units
1226        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1227        (let* ((units (math-extract-units (nth 1 math-simplify-expr)))
1228               (ratio (math-simplify (math-to-standard-units
1229                                      (list '/ (nth 2 math-simplify-expr) units) nil))))
1230          (if (math-units-in-expr-p ratio nil)
1231              (progn
1232                (calc-record-why "*Inconsistent units" math-simplify-expr)
1233                math-simplify-expr)
1234            (list '* (math-add (math-remove-units (nth 1 math-simplify-expr))
1235                               (if (eq (car math-simplify-expr) '-)
1236                                   (math-neg ratio) ratio))
1237                  units)))))
1238
1239 (math-defsimplify *
1240   (math-simplify-units-prod))
1241
1242 (defun math-simplify-units-prod ()
1243   (and math-simplifying-units
1244        calc-autorange-units
1245        (Math-realp (nth 1 math-simplify-expr))
1246        (let* ((num (math-float (nth 1 math-simplify-expr)))
1247               (xpon (calcFunc-xpon num))
1248               (unitp (cdr (cdr math-simplify-expr)))
1249               (unit (car unitp))
1250               (pow (if (eq (car math-simplify-expr) '*) 1 -1))
1251               u)
1252          (and (eq (car-safe unit) '*)
1253               (setq unitp (cdr unit)
1254                     unit (car unitp)))
1255          (and (eq (car-safe unit) '^)
1256               (integerp (nth 2 unit))
1257               (setq pow (* pow (nth 2 unit))
1258                     unitp (cdr unit)
1259                     unit (car unitp)))
1260          (and (setq u (math-check-unit-name unit))
1261               (integerp xpon)
1262               (or (< xpon 0)
1263                   (>= xpon (if (eq (car u) 'm) 1 3)))
1264               (let* ((uxpon 0)
1265                      (pref (if (< pow 0)
1266                                (reverse math-unit-prefixes)
1267                              math-unit-prefixes))
1268                      (p pref)
1269                      pxpon pname)
1270                 (or (eq (car u) (nth 1 unit))
1271                     (setq uxpon (* pow
1272                                    (nth 2 (nth 1 (assq
1273                                                   (aref (symbol-name
1274                                                          (nth 1 unit)) 0)
1275                                                   math-unit-prefixes))))))
1276                 (setq xpon (+ xpon uxpon))
1277                 (while (and p
1278                             (or (memq (car (car p)) '(?d ?D ?h ?H))
1279                                 (and (eq (car (car p)) ?c)
1280                                      (not (eq (car u) 'm)))
1281                                 (< xpon (setq pxpon (* (nth 2 (nth 1 (car p)))
1282                                                        pow)))
1283                                 (progn
1284                                   (setq pname (math-build-var-name
1285                                                (if (eq (car (car p)) 0)
1286                                                    (car u)
1287                                                  (concat (char-to-string
1288                                                           (car (car p)))
1289                                                          (symbol-name
1290                                                           (car u))))))
1291                                   (and (/= (car (car p)) 0)
1292                                        (assq (nth 1 pname)
1293                                              math-units-table)))))
1294                   (setq p (cdr p)))
1295                 (and p
1296                      (/= pxpon uxpon)
1297                      (or (not (eq p pref))
1298                          (< xpon (+ pxpon (* (math-abs pow) 3))))
1299                      (progn
1300                        (setcar (cdr math-simplify-expr)
1301                                (let ((calc-prefer-frac nil))
1302                                  (calcFunc-scf (nth 1 math-simplify-expr)
1303                                                (- uxpon pxpon))))
1304                        (setcar unitp pname)
1305                        math-simplify-expr)))))))
1306
1307 (defvar math-try-cancel-units)
1308
1309 (math-defsimplify /
1310   (and math-simplifying-units
1311        (let ((np (cdr math-simplify-expr))
1312              (math-try-cancel-units 0)
1313              n nn)
1314          (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
1315                      (cdr (nth 2 math-simplify-expr))
1316                    (nthcdr 2 math-simplify-expr)))
1317          (if (math-realp (car n))
1318              (progn
1319                (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr)
1320                                             (let ((calc-prefer-frac nil))
1321                                               (math-div 1 (car n)))))
1322                (setcar n 1)))
1323          (while (eq (car-safe (setq n (car np))) '*)
1324            (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr)))
1325            (setq np (cdr (cdr n))))
1326          (math-simplify-units-divisor np (cdr (cdr math-simplify-expr)))
1327          (if (eq math-try-cancel-units 0)
1328              (let* ((math-simplifying-units nil)
1329                     (base (math-simplify
1330                            (math-to-standard-units math-simplify-expr nil))))
1331                (if (Math-numberp base)
1332                    (setq math-simplify-expr base))))
1333          (if (eq (car-safe math-simplify-expr) '/)
1334              (math-simplify-units-prod))
1335          math-simplify-expr)))
1336
1337 (defun math-simplify-units-divisor (np dp)
1338   (let ((n (car np))
1339         d dd temp)
1340     (while (eq (car-safe (setq d (car dp))) '*)
1341       (when (setq temp (math-simplify-units-quotient n (nth 1 d)))
1342         (setcar np (setq n temp))
1343         (setcar (cdr d) 1))
1344       (setq dp (cdr (cdr d))))
1345     (when (setq temp (math-simplify-units-quotient n d))
1346       (setcar np (setq n temp))
1347       (setcar dp 1))))
1348
1349 ;; Simplify, e.g., "in / cm" to "2.54" in a units expression.
1350 (defun math-simplify-units-quotient (n d)
1351   (let ((pow1 1)
1352         (pow2 1))
1353     (when (and (eq (car-safe n) '^)
1354                (integerp (nth 2 n)))
1355       (setq pow1 (nth 2 n) n (nth 1 n)))
1356     (when (and (eq (car-safe d) '^)
1357                (integerp (nth 2 d)))
1358       (setq pow2 (nth 2 d) d (nth 1 d)))
1359     (let ((un (math-check-unit-name n))
1360           (ud (math-check-unit-name d)))
1361       (and un ud
1362            (if (and (equal (nth 4 un) (nth 4 ud))
1363                     (eq pow1 pow2))
1364                (if (eq pow1 1)
1365                    (math-to-standard-units (list '/ n d) nil)
1366                  (list '^ (math-to-standard-units (list '/ n d) nil) pow1))
1367              (let (ud1)
1368                (setq un (nth 4 un)
1369                      ud (nth 4 ud))
1370                (while un
1371                  (setq ud1 ud)
1372                  (while ud1
1373                    (and (eq (car (car un)) (car (car ud1)))
1374                         (setq math-try-cancel-units
1375                               (+ math-try-cancel-units
1376                                  (- (* (cdr (car un)) pow1)
1377                                     (* (cdr (car ud)) pow2)))))
1378                    (setq ud1 (cdr ud1)))
1379                  (setq un (cdr un)))
1380                nil))))))
1381
1382 (math-defsimplify ^
1383   (and math-simplifying-units
1384        (math-realp (nth 2 math-simplify-expr))
1385        (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1386            (list (car (nth 1 math-simplify-expr))
1387                  (list '^ (nth 1 (nth 1 math-simplify-expr))
1388                        (nth 2 math-simplify-expr))
1389                  (list '^ (nth 2 (nth 1 math-simplify-expr))
1390                        (nth 2 math-simplify-expr)))
1391          (math-simplify-units-pow (nth 1 math-simplify-expr)
1392                                   (nth 2 math-simplify-expr)))))
1393
1394 (math-defsimplify calcFunc-sqrt
1395   (and math-simplifying-units
1396        (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1397            (list (car (nth 1 math-simplify-expr))
1398                  (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1399                  (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr))))
1400          (math-simplify-units-pow (nth 1 math-simplify-expr) '(frac 1 2)))))
1401
1402 (math-defsimplify (calcFunc-floor
1403                    calcFunc-ceil
1404                    calcFunc-round
1405                    calcFunc-rounde
1406                    calcFunc-roundu
1407                    calcFunc-trunc
1408                    calcFunc-float
1409                    calcFunc-frac
1410                    calcFunc-abs
1411                    calcFunc-clean)
1412   (and math-simplifying-units
1413        (= (length math-simplify-expr) 2)
1414        (if (math-only-units-in-expr-p (nth 1 math-simplify-expr))
1415            (nth 1 math-simplify-expr)
1416          (if (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1417                   (or (math-only-units-in-expr-p
1418                        (nth 1 (nth 1 math-simplify-expr)))
1419                       (math-only-units-in-expr-p
1420                        (nth 2 (nth 1 math-simplify-expr)))))
1421              (list (car (nth 1 math-simplify-expr))
1422                    (cons (car math-simplify-expr)
1423                          (cons (nth 1 (nth 1 math-simplify-expr))
1424                                (cdr (cdr math-simplify-expr))))
1425                    (cons (car math-simplify-expr)
1426                          (cons (nth 2 (nth 1 math-simplify-expr))
1427                                (cdr (cdr math-simplify-expr)))))))))
1428
1429 (defun math-simplify-units-pow (a pow)
1430   (if (and (eq (car-safe a) '^)
1431            (math-check-unit-name (nth 1 a))
1432            (math-realp (nth 2 a)))
1433       (list '^ (nth 1 a) (math-mul pow (nth 2 a)))
1434     (let* ((u (math-check-unit-name a))
1435            (pf (math-to-simple-fraction pow))
1436            (d (and (eq (car-safe pf) 'frac) (nth 2 pf))))
1437       (and u d
1438            (math-units-are-multiple u d)
1439            (list '^ (math-to-standard-units a nil) pow)))))
1440
1441
1442 (defun math-units-are-multiple (u n)
1443   (setq u (nth 4 u))
1444   (while (and u (= (% (cdr (car u)) n) 0))
1445     (setq u (cdr u)))
1446   (null u))
1447
1448 (math-defsimplify calcFunc-sin
1449   (and math-simplifying-units
1450        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1451        (let ((rad (math-simplify-units
1452                    (math-evaluate-expr
1453                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1454              (calc-angle-mode 'rad))
1455          (and (eq (car-safe rad) '*)
1456               (math-realp (nth 1 rad))
1457               (eq (car-safe (nth 2 rad)) 'var)
1458               (eq (nth 1 (nth 2 rad)) 'rad)
1459               (list 'calcFunc-sin (nth 1 rad))))))
1460
1461 (math-defsimplify calcFunc-cos
1462   (and math-simplifying-units
1463        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1464        (let ((rad (math-simplify-units
1465                    (math-evaluate-expr
1466                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1467              (calc-angle-mode 'rad))
1468          (and (eq (car-safe rad) '*)
1469               (math-realp (nth 1 rad))
1470               (eq (car-safe (nth 2 rad)) 'var)
1471               (eq (nth 1 (nth 2 rad)) 'rad)
1472               (list 'calcFunc-cos (nth 1 rad))))))
1473
1474 (math-defsimplify calcFunc-tan
1475   (and math-simplifying-units
1476        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1477        (let ((rad (math-simplify-units
1478                    (math-evaluate-expr
1479                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1480              (calc-angle-mode 'rad))
1481          (and (eq (car-safe rad) '*)
1482               (math-realp (nth 1 rad))
1483               (eq (car-safe (nth 2 rad)) 'var)
1484               (eq (nth 1 (nth 2 rad)) 'rad)
1485               (list 'calcFunc-tan (nth 1 rad))))))
1486
1487 (math-defsimplify calcFunc-sec
1488   (and math-simplifying-units
1489        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1490        (let ((rad (math-simplify-units
1491                    (math-evaluate-expr
1492                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1493              (calc-angle-mode 'rad))
1494          (and (eq (car-safe rad) '*)
1495               (math-realp (nth 1 rad))
1496               (eq (car-safe (nth 2 rad)) 'var)
1497               (eq (nth 1 (nth 2 rad)) 'rad)
1498               (list 'calcFunc-sec (nth 1 rad))))))
1499
1500 (math-defsimplify calcFunc-csc
1501   (and math-simplifying-units
1502        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1503        (let ((rad (math-simplify-units
1504                    (math-evaluate-expr
1505                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1506              (calc-angle-mode 'rad))
1507          (and (eq (car-safe rad) '*)
1508               (math-realp (nth 1 rad))
1509               (eq (car-safe (nth 2 rad)) 'var)
1510               (eq (nth 1 (nth 2 rad)) 'rad)
1511               (list 'calcFunc-csc (nth 1 rad))))))
1512
1513 (math-defsimplify calcFunc-cot
1514   (and math-simplifying-units
1515        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1516        (let ((rad (math-simplify-units
1517                    (math-evaluate-expr
1518                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1519              (calc-angle-mode 'rad))
1520          (and (eq (car-safe rad) '*)
1521               (math-realp (nth 1 rad))
1522               (eq (car-safe (nth 2 rad)) 'var)
1523               (eq (nth 1 (nth 2 rad)) 'rad)
1524               (list 'calcFunc-cot (nth 1 rad))))))
1525
1526
1527 (defun math-remove-units (expr)
1528   (if (math-check-unit-name expr)
1529       1
1530     (if (Math-primp expr)
1531         expr
1532       (cons (car expr)
1533             (mapcar 'math-remove-units (cdr expr))))))
1534
1535 (defun math-extract-units (expr)
1536   (cond
1537    ((memq (car-safe expr) '(* /))
1538     (cons (car expr)
1539           (mapcar 'math-extract-units (cdr expr))))
1540    ((eq (car-safe expr) 'neg)
1541     (math-extract-units (nth 1 expr)))
1542    ((eq (car-safe expr) '^)
1543     (list '^ (math-extract-units (nth 1 expr)) (nth 2 expr)))
1544    ((math-check-unit-name expr) expr)
1545    (t 1)))
1546
1547 (defun math-build-units-table-buffer (enter-buffer)
1548   (if (not (and math-units-table math-units-table-buffer-valid
1549                 (get-buffer "*Units Table*")))
1550       (let ((buf (get-buffer-create "*Units Table*"))
1551             (uptr (math-build-units-table))
1552             (calc-language (if (eq calc-language 'big) nil calc-language))
1553             (calc-float-format '(float 0))
1554             (calc-group-digits nil)
1555             (calc-number-radix 10)
1556             (calc-twos-complement-mode nil)
1557             (calc-point-char ".")
1558             (std nil)
1559             u name shadowed)
1560         (save-excursion
1561           (message "Formatting units table...")
1562           (set-buffer buf)
1563           (let ((inhibit-read-only t))
1564             (erase-buffer)
1565             (insert "Calculator Units Table:\n\n")
1566             (insert "(All definitions are exact unless marked with an asterisk (*).)\n\n")
1567             (insert "Unit    Type  Definition                  Description\n\n")
1568             (while uptr
1569               (setq u (car uptr)
1570                     name (nth 2 u))
1571               (when (eq (car u) 'm)
1572                 (setq std t))
1573               (setq shadowed (and std (assq (car u) math-additional-units)))
1574               (when (and name
1575                          (> (length name) 1)
1576                          (eq (aref name 0) ?\*))
1577                 (unless (eq uptr math-units-table)
1578                   (insert "\n"))
1579                 (setq name (substring name 1)))
1580               (insert " ")
1581               (and shadowed (insert "("))
1582               (insert (symbol-name (car u)))
1583               (and shadowed (insert ")"))
1584               (if (nth 3 u)
1585                   (progn
1586                     (indent-to 10)
1587                     (insert (symbol-name (nth 3 u))))
1588                 (or std
1589                     (progn
1590                       (indent-to 10)
1591                       (insert "U"))))
1592               (indent-to 14)
1593               (and shadowed (insert "("))
1594               (if (nth 5 u)
1595                   (insert (nth 5 u))
1596                 (if (nth 1 u)
1597                     (insert (math-format-value (nth 1 u) 80))
1598                   (insert (symbol-name (car u)))))
1599               (and shadowed (insert ")"))
1600               (indent-to 41)
1601               (insert " ")
1602               (when name
1603                 (insert name))
1604               (if shadowed
1605                   (insert " (redefined above)")
1606                 (unless (nth 1 u)
1607                   (insert " (base unit)")))
1608               (insert "\n")
1609               (setq uptr (cdr uptr)))
1610             (insert "\n\nUnit Prefix Table:\n\n")
1611             (setq uptr math-unit-prefixes)
1612             (while uptr
1613               (setq u (car uptr))
1614               (insert " " (char-to-string (car u)))
1615               (if (equal (nth 1 u) (nth 1 (nth 1 uptr)))
1616                   (insert " " (char-to-string (car (car (setq uptr (cdr uptr)))))
1617                           "   ")
1618                 (insert "     "))
1619               (insert "10^" (int-to-string (nth 2 (nth 1 u))))
1620               (indent-to 15)
1621               (insert "   " (nth 2 u) "\n")
1622               (while (eq (car (car (setq uptr (cdr uptr)))) 0)))
1623             (insert "\n\n")
1624             (insert
1625              (format-message
1626               (concat
1627                "(**) When in TeX or LaTeX display mode, the TeX specific unit\n"
1628                "names will not use the ‘tex’ prefix; the unit name for a\n"
1629                "TeX point will be ‘pt’ instead of ‘texpt’, for example.\n"
1630                "To avoid conflicts, the unit names for pint and parsec will\n"
1631                "be ‘pint’ and ‘parsec’ instead of ‘pt’ and ‘pc’."))))
1632           (view-mode)
1633           (message "Formatting units table...done"))
1634         (setq math-units-table-buffer-valid t)
1635         (let ((oldbuf (current-buffer)))
1636           (set-buffer buf)
1637           (goto-char (point-min))
1638           (set-buffer oldbuf))
1639         (if enter-buffer
1640             (pop-to-buffer buf)
1641           (display-buffer buf)))
1642     (if enter-buffer
1643         (pop-to-buffer (get-buffer "*Units Table*"))
1644       (display-buffer (get-buffer "*Units Table*")))))
1645
1646 ;;; Logarithmic units functions
1647
1648 (defvar math-logunits '((var dB var-dB)
1649                         (var Np var-Np)))
1650
1651 (defun math-conditional-apply (fn &rest args)
1652   "Evaluate f(args) unless in symbolic mode.
1653 In symbolic mode, return the list (fn args)."
1654   (if calc-symbolic-mode
1655       (cons fn args)
1656     (apply fn args)))
1657
1658 (defun math-conditional-pow (a b)
1659   "Evaluate a^b unless in symbolic mode.
1660 In symbolic mode, return the list (^ a b)."
1661   (if calc-symbolic-mode
1662       (list '^ a b)
1663     (math-pow a b)))
1664
1665 (defun math-extract-logunits (expr)
1666   (if (memq (car-safe expr) '(* /))
1667       (cons (car expr)
1668             (mapcar 'math-extract-logunits (cdr expr)))
1669     (if (memq (car-safe expr) '(^))
1670         (list '^ (math-extract-logunits (nth 1 expr)) (nth 2 expr))
1671       (if (member expr math-logunits) expr 1))))
1672
1673 (defun math-logunits-add (a b neg power)
1674   (let ((aunit (math-simplify (math-extract-logunits a))))
1675     (if (not (eq (car-safe aunit) 'var))
1676         (calc-record-why "*Improper logarithmic unit" aunit)
1677       (let* ((units (math-extract-units a))
1678             (acoeff (math-simplify (math-remove-units a)))
1679             (bcoeff (math-simplify (math-to-standard-units
1680                                     (list '/ b units) nil))))
1681         (if (math-units-in-expr-p bcoeff nil)
1682             (calc-record-why "*Inconsistent units" nil)
1683           (if (and neg
1684                    (or (math-lessp acoeff bcoeff)
1685                        (math-equal acoeff bcoeff)))
1686               (calc-record-why "*Improper coefficients" nil)
1687             (math-mul
1688              (if (equal aunit '(var dB var-dB))
1689                  (let ((coef (if power 10 20)))
1690                    (math-mul coef
1691                              (math-conditional-apply 'calcFunc-log10
1692                               (if neg
1693                                   (math-sub
1694                                    (math-conditional-pow 10 (math-div acoeff coef))
1695                                    (math-conditional-pow 10 (math-div bcoeff coef)))
1696                                 (math-add
1697                                  (math-conditional-pow 10 (math-div acoeff coef))
1698                                  (math-conditional-pow 10 (math-div bcoeff coef)))))))
1699                (let ((coef (if power 2 1)))
1700                  (math-div
1701                   (math-conditional-apply 'calcFunc-ln
1702                    (if neg
1703                        (math-sub
1704                         (math-conditional-apply 'calcFunc-exp (math-mul coef acoeff))
1705                         (math-conditional-apply 'calcFunc-exp (math-mul coef bcoeff)))
1706                      (math-add
1707                       (math-conditional-apply 'calcFunc-exp (math-mul coef acoeff))
1708                       (math-conditional-apply 'calcFunc-exp (math-mul coef bcoeff)))))
1709                   coef)))
1710              units)))))))
1711
1712 (defun calcFunc-lufadd (a b)
1713   (math-logunits-add a b nil nil))
1714
1715 (defun calcFunc-lupadd (a b)
1716   (math-logunits-add a b nil t))
1717
1718 (defun calcFunc-lufsub (a b)
1719   (math-logunits-add a b t nil))
1720
1721 (defun calcFunc-lupsub (a b)
1722   (math-logunits-add a b t t))
1723
1724 (defun calc-lu-plus (arg)
1725   (interactive "P")
1726   (calc-slow-wrapper
1727    (if (calc-is-inverse)
1728        (if (calc-is-hyperbolic)
1729            (calc-binary-op "lu-" 'calcFunc-lufsub arg)
1730          (calc-binary-op "lu-" 'calcFunc-lupsub arg))
1731      (if (calc-is-hyperbolic)
1732          (calc-binary-op "lu+" 'calcFunc-lufadd arg)
1733        (calc-binary-op "lu+" 'calcFunc-lupadd arg)))))
1734
1735 (defun calc-lu-minus (arg)
1736   (interactive "P")
1737   (calc-slow-wrapper
1738    (if (calc-is-inverse)
1739        (if (calc-is-hyperbolic)
1740            (calc-binary-op "lu+" 'calcFunc-lufadd arg)
1741          (calc-binary-op "lu+" 'calcFunc-lupadd arg))
1742      (if (calc-is-hyperbolic)
1743          (calc-binary-op "lu-" 'calcFunc-lufsub arg)
1744        (calc-binary-op "lu-" 'calcFunc-lupsub arg)))))
1745
1746 (defun math-logunits-mul (a b power)
1747   (let (logunit coef units number)
1748     (cond
1749      ((and
1750        (setq logunit (math-simplify (math-extract-logunits a)))
1751        (eq (car-safe logunit) 'var)
1752        (eq (math-simplify (math-extract-units b)) 1))
1753       (setq coef (math-simplify (math-remove-units a))
1754             units (math-extract-units a)
1755             number b))
1756      ((and
1757        (setq logunit (math-simplify (math-extract-logunits b)))
1758        (eq (car-safe logunit) 'var)
1759        (eq (math-simplify (math-extract-units a)) 1))
1760       (setq coef (math-simplify (math-remove-units b))
1761             units (math-extract-units b)
1762             number a))
1763      (t (setq logunit nil)))
1764     (if logunit
1765         (cond
1766          ((equal logunit '(var dB var-dB))
1767           (math-simplify
1768            (math-mul
1769             (math-add
1770              coef
1771              (math-mul (if power 10 20)
1772                        (math-conditional-apply 'calcFunc-log10 number)))
1773             units)))
1774          (t
1775           (math-simplify
1776            (math-mul
1777             (math-add
1778              coef
1779              (math-div (math-conditional-apply 'calcFunc-ln number) (if power 2 1)))
1780             units))))
1781       (calc-record-why "*Improper units" nil))))
1782
1783 (defun math-logunits-divide (a b power)
1784   (let ((logunit (math-simplify (math-extract-logunits a))))
1785     (if (not (eq (car-safe logunit) 'var))
1786         (calc-record-why "*Improper logarithmic unit" logunit)
1787       (if (math-units-in-expr-p b nil)
1788           (calc-record-why "*Improper units quantity" b)
1789         (let* ((units (math-extract-units a))
1790                (coef (math-simplify (math-remove-units a))))
1791           (cond
1792            ((equal logunit '(var dB var-dB))
1793             (math-simplify
1794              (math-mul
1795               (math-sub
1796                coef
1797                (math-mul (if power 10 20)
1798                          (math-conditional-apply 'calcFunc-log10 b)))
1799               units)))
1800          (t
1801           (math-simplify
1802            (math-mul
1803             (math-sub
1804              coef
1805              (math-div (math-conditional-apply 'calcFunc-ln b) (if power 2 1)))
1806             units)))))))))
1807
1808 (defun calcFunc-lufmul (a b)
1809   (math-logunits-mul a b nil))
1810
1811 (defun calcFunc-lupmul (a b)
1812   (math-logunits-mul a b t))
1813
1814 (defun calc-lu-times (arg)
1815   (interactive "P")
1816   (calc-slow-wrapper
1817    (if (calc-is-inverse)
1818        (if (calc-is-hyperbolic)
1819            (calc-binary-op "lu/" 'calcFunc-lufdiv arg)
1820          (calc-binary-op "lu/" 'calcFunc-lupdiv arg))
1821      (if (calc-is-hyperbolic)
1822          (calc-binary-op "lu*" 'calcFunc-lufmul arg)
1823        (calc-binary-op "lu*" 'calcFunc-lupmul arg)))))
1824
1825 (defun calcFunc-lufdiv (a b)
1826   (math-logunits-divide a b nil))
1827
1828 (defun calcFunc-lupdiv (a b)
1829   (math-logunits-divide a b t))
1830
1831 (defun calc-lu-divide (arg)
1832   (interactive "P")
1833   (calc-slow-wrapper
1834    (if (calc-is-inverse)
1835        (if (calc-is-hyperbolic)
1836            (calc-binary-op "lu*" 'calcFunc-lufmul arg)
1837          (calc-binary-op "lu*" 'calcFunc-lupmul arg))
1838      (if (calc-is-hyperbolic)
1839          (calc-binary-op "lu/" 'calcFunc-lufdiv arg)
1840        (calc-binary-op "lu/" 'calcFunc-lupdiv arg)))))
1841
1842 (defun math-logunits-quant (val ref power)
1843   (let* ((units (math-simplify (math-extract-units val)))
1844          (lunit (math-simplify (math-extract-logunits units))))
1845     (if (not (eq (car-safe lunit) 'var))
1846         (calc-record-why "*Improper logarithmic unit" lunit)
1847       (let ((runits (math-simplify (math-div units lunit)))
1848             (coeff (math-simplify (math-div val units))))
1849         (math-mul
1850          (if (equal lunit '(var dB var-dB))
1851              (math-mul
1852               ref
1853               (math-conditional-pow
1854                10
1855                (math-div
1856                 coeff
1857                 (if power 10 20))))
1858            (math-mul
1859             ref
1860             (math-conditional-apply 'calcFunc-exp
1861              (if power
1862                  (math-mul 2 coeff)
1863                coeff))))
1864          runits)))))
1865
1866 (defvar calc-lu-field-reference)
1867 (defvar calc-lu-power-reference)
1868
1869 (defun calcFunc-lufquant (val &optional ref)
1870   (unless ref
1871     (setq ref (math-read-expr calc-lu-field-reference)))
1872   (math-logunits-quant val ref nil))
1873
1874 (defun calcFunc-lupquant (val &optional ref)
1875   (unless ref
1876     (setq ref (math-read-expr calc-lu-power-reference)))
1877   (math-logunits-quant val ref t))
1878
1879 (defun calc-lu-quant (arg)
1880   (interactive "P")
1881   (calc-slow-wrapper
1882    (if (calc-is-hyperbolic)
1883        (if (calc-is-option)
1884            (calc-binary-op "lupq" 'calcFunc-lufquant arg)
1885          (calc-unary-op "lupq" 'calcFunc-lufquant arg))
1886      (if (calc-is-option)
1887          (calc-binary-op "lufq" 'calcFunc-lupquant arg)
1888        (calc-unary-op "lufq" 'calcFunc-lupquant arg)))))
1889
1890 (defun math-logunits-level (val ref db power)
1891   "Compute the value of VAL in decibels or nepers."
1892       (let* ((ratio (math-simplify-units (math-div val ref)))
1893              (ratiou (math-simplify-units (math-remove-units ratio)))
1894              (units (math-simplify (math-extract-units ratio))))
1895         (math-mul
1896          (if db
1897              (math-mul
1898               (math-mul (if power 10 20)
1899                         (math-conditional-apply 'calcFunc-log10 ratiou))
1900               '(var dB var-dB))
1901            (math-mul
1902             (math-div (math-conditional-apply 'calcFunc-ln ratiou) (if power 2 1))
1903             '(var Np var-Np)))
1904          units)))
1905
1906 (defun calcFunc-dbfield (val &optional ref)
1907   (unless ref
1908     (setq ref (math-read-expr calc-lu-field-reference)))
1909   (math-logunits-level val ref t nil))
1910
1911 (defun calcFunc-dbpower (val &optional ref)
1912   (unless ref
1913     (setq ref (math-read-expr calc-lu-power-reference)))
1914   (math-logunits-level val ref t t))
1915
1916 (defun calcFunc-npfield (val &optional ref)
1917   (unless ref
1918     (setq ref (math-read-expr calc-lu-field-reference)))
1919   (math-logunits-level val ref nil nil))
1920
1921 (defun calcFunc-nppower (val &optional ref)
1922   (unless ref
1923     (setq ref (math-read-expr calc-lu-power-reference)))
1924   (math-logunits-level val ref nil t))
1925
1926 (defun calc-db (arg)
1927   (interactive "P")
1928   (calc-slow-wrapper
1929    (if (calc-is-hyperbolic)
1930        (if (calc-is-option)
1931            (calc-binary-op "ludb" 'calcFunc-dbfield arg)
1932          (calc-unary-op "ludb" 'calcFunc-dbfield arg))
1933      (if (calc-is-option)
1934          (calc-binary-op "ludb" 'calcFunc-dbpower arg)
1935        (calc-unary-op "ludb" 'calcFunc-dbpower arg)))))
1936
1937 (defun calc-np (arg)
1938   (interactive "P")
1939   (calc-slow-wrapper
1940    (if (calc-is-hyperbolic)
1941        (if (calc-is-option)
1942            (calc-binary-op "lunp" 'calcFunc-npfield arg)
1943          (calc-unary-op "lunp" 'calcFunc-npfield arg))
1944      (if (calc-is-option)
1945          (calc-binary-op "lunp" 'calcFunc-nppower arg)
1946        (calc-unary-op "lunp" 'calcFunc-nppower arg)))))
1947
1948 ;;; Musical notes
1949
1950
1951 (defvar calc-note-threshold)
1952
1953 (defun math-midi-round (num)
1954   "Round NUM to an integer N if NUM is within calc-note-threshold cents of N."
1955   (let* ((n (math-round num))
1956          (diff (math-abs
1957                 (math-sub num n))))
1958     (if (< (math-compare diff
1959                          (math-div (math-read-expr calc-note-threshold) 100)) 0)
1960         n
1961       num)))
1962
1963 (defconst math-notes
1964   '(((var C var-C) . 0)
1965     ((var Csharp var-Csharp) . 1)
1966 ;    ((var C♯ var-C♯) . 1)
1967     ((var Dflat var-Dflat) . 1)
1968 ;    ((var D♭ var-D♭) . 1)
1969     ((var D var-D) . 2)
1970     ((var Dsharp var-Dsharp) . 3)
1971 ;    ((var D♯ var-D♯) . 3)
1972     ((var E var-E) . 4)
1973     ((var F var-F) . 5)
1974     ((var Fsharp var-Fsharp) . 6)
1975 ;    ((var F♯ var-F♯) . 6)
1976     ((var Gflat var-Gflat) . 6)
1977 ;    ((var G♭ var-G♭) . 6)
1978     ((var G var-G) . 7)
1979     ((var Gsharp var-Gsharp) . 8)
1980 ;    ((var G♯ var-G♯) . 8)
1981     ((var A var-A) . 9)
1982     ((var Asharp var-Asharp) . 10)
1983 ;    ((var A♯ var-A♯) . 10)
1984     ((var Bflat var-Bflat) . 10)
1985 ;    ((var B♭ var-B♭) . 10)
1986     ((var B var-B) . 11))
1987   "An alist of notes with their number of semitones above C.")
1988
1989 (defun math-freqp (freq)
1990   "Non-nil if FREQ is a positive number times the unit Hz.
1991 If non-nil, return the coefficient of Hz."
1992   (let ((freqcoef (math-simplify-units
1993                    (math-div freq '(var Hz var-Hz)))))
1994     (if (Math-posp freqcoef) freqcoef)))
1995
1996 (defun math-midip (num)
1997   "Non-nil if NUM is a possible MIDI note number.
1998 If non-nil, return NUM."
1999   (if (Math-numberp num) num))
2000
2001 (defun math-spnp (spn)
2002   "Non-nil if NUM is a scientific pitch note (note + cents).
2003 If non-nil, return a list consisting of the note and the cents coefficient."
2004   (let (note cents rnote rcents)
2005     (if (eq (car-safe spn) '+)
2006         (setq note (nth 1 spn)
2007               cents (nth 2 spn))
2008       (setq note spn
2009             cents nil))
2010     (cond
2011      ((and  ;; NOTE is a note, CENTS is nil or cents.
2012        (eq (car-safe note) 'calcFunc-subscr)
2013        (assoc (nth 1 note) math-notes)
2014        (integerp (nth 2 note))
2015        (setq rnote note)
2016        (or
2017         (not cents)
2018         (Math-numberp (setq rcents
2019                             (math-simplify
2020                              (math-div cents '(var cents var-cents)))))))
2021       (list rnote rcents))
2022      ((and  ;; CENTS is a note, NOTE is cents.
2023        (eq (car-safe cents) 'calcFunc-subscr)
2024        (assoc (nth 1 cents) math-notes)
2025        (integerp (nth 2 cents))
2026        (setq rnote cents)
2027        (or
2028         (not note)
2029         (Math-numberp (setq rcents
2030                             (math-simplify
2031                              (math-div note '(var cents var-cents)))))))
2032       (list rnote rcents)))))
2033
2034 (defun math-freq-to-midi (freq)
2035   "Return the midi note number corresponding to FREQ Hz."
2036   (let ((midi (math-add
2037                69
2038                (math-mul
2039                 12
2040                 (calcFunc-log
2041                  (math-div freq 440)
2042                  2)))))
2043     (math-midi-round midi)))
2044
2045 (defun math-spn-to-midi (spn)
2046   "Return the MIDI number corresponding to SPN."
2047   (let* ((note (cdr (assoc (nth 1 (car spn)) math-notes)))
2048          (octave (math-add (nth 2 (car spn)) 1))
2049          (cents (nth 1 spn))
2050          (midi  (math-add
2051                  (math-mul 12 octave)
2052                  note)))
2053     (if cents
2054         (math-add midi (math-div cents 100))
2055       midi)))
2056
2057 (defun math-midi-to-spn (midi)
2058   "Return the scientific pitch notation corresponding to midi number MIDI."
2059   (let (midin cents)
2060     (if (math-integerp midi)
2061         (setq midin midi
2062               cents nil)
2063       (setq midin (math-floor midi)
2064             cents (math-mul 100 (math-sub midi midin))))
2065     (let* ((nr ;; This should be (math-idivmod midin 12), but with
2066                ;; better behavior for negative midin.
2067             (if (Math-negp midin)
2068                 (let ((dm (math-idivmod (math-neg midin) 12)))
2069                   (if (= (cdr dm) 0)
2070                       (cons (math-neg (car dm)) 0)
2071                     (cons
2072                      (math-sub (math-neg (car dm)) 1)
2073                      (math-sub 12 (cdr dm)))))
2074               (math-idivmod midin 12)))
2075            (n (math-sub (car nr) 1))
2076            (note (car (rassoc (cdr nr) math-notes))))
2077       (if cents
2078           (list '+ (list 'calcFunc-subscr note n)
2079                    (list '* cents '(var cents var-cents)))
2080         (list 'calcFunc-subscr note n)))))
2081
2082 (defun math-freq-to-spn (freq)
2083   "Return the scientific pitch notation corresponding to FREQ Hz."
2084   (math-with-extra-prec 3
2085     (math-midi-to-spn (math-freq-to-midi freq))))
2086
2087 (defun math-midi-to-freq (midi)
2088   "Return the frequency of the note with midi number MIDI."
2089   (list '*
2090         (math-mul
2091          440
2092          (math-pow
2093           2
2094           (math-div
2095            (math-sub
2096             midi
2097             69)
2098            12)))
2099         '(var Hz var-Hz)))
2100
2101 (defun math-spn-to-freq (spn)
2102   "Return the frequency of the note with scientific pitch notation SPN."
2103   (math-midi-to-freq (math-spn-to-midi spn)))
2104
2105 (defun calcFunc-spn (expr)
2106   "Return EXPR written as scientific pitch notation + cents."
2107   ;; Get the coefficient of Hz
2108   (let (note)
2109     (cond
2110      ((setq note (math-freqp expr))
2111       (math-freq-to-spn note))
2112      ((setq note (math-midip expr))
2113       (math-midi-to-spn note))
2114      ((math-spnp expr)
2115       expr)
2116      (t
2117       (math-reject-arg expr "*Improper expression")))))
2118
2119 (defun calcFunc-midi (expr)
2120   "Return EXPR written as a MIDI number."
2121   (let (note)
2122     (cond
2123      ((setq note (math-freqp expr))
2124       (math-freq-to-midi note))
2125      ((setq note (math-spnp expr))
2126       (math-spn-to-midi note))
2127      ((math-midip expr)
2128       expr)
2129      (t
2130       (math-reject-arg expr "*Improper expression")))))
2131
2132 (defun calcFunc-freq (expr)
2133   "Return the frequency corresponding to EXPR."
2134   (let (note)
2135     (cond
2136      ((setq note (math-midip expr))
2137       (math-midi-to-freq note))
2138      ((setq note (math-spnp expr))
2139       (math-spn-to-freq note))
2140      ((math-freqp expr)
2141       expr)
2142      (t
2143       (math-reject-arg expr "*Improper expression")))))
2144
2145 (defun calc-freq (arg)
2146   "Return the frequency corresponding to the expression on the stack."
2147   (interactive "P")
2148   (calc-slow-wrapper
2149    (calc-unary-op "freq" 'calcFunc-freq arg)))
2150
2151 (defun calc-midi (arg)
2152   "Return the MIDI number corresponding to the expression on the stack."
2153   (interactive "P")
2154   (calc-slow-wrapper
2155    (calc-unary-op "midi" 'calcFunc-midi arg)))
2156
2157 (defun calc-spn (arg)
2158   "Return the scientific pitch notation corresponding to the expression on the stack."
2159   (interactive "P")
2160   (calc-slow-wrapper
2161    (calc-unary-op "spn" 'calcFunc-spn arg)))
2162
2163
2164 (provide 'calc-units)
2165
2166 ;; Local variables:
2167 ;; coding: utf-8
2168 ;; End:
2169
2170 ;;; calc-units.el ends here