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