code.delx.au - gnu-emacs/blob - lisp/calc/calc-units.el

   1 ;;; calc-units.el --- unit conversion functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
   4
   5 ;; Author: David Gillespie <daveg@synaptics.com>
   6 ;; Maintainer: Jay Belanger <belanger@truman.edu>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY.  No author or distributor
  12 ;; accepts responsibility to anyone for the consequences of using it
  13 ;; or for whether it serves any particular purpose or works at all,
  14 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  15 ;; License for full details.
  16
  17 ;; Everyone is granted permission to copy, modify and redistribute
  18 ;; GNU Emacs, but only under the conditions described in the
  19 ;; GNU Emacs General Public License.   A copy of this license is
  20 ;; supposed to have been given to you along with GNU Emacs so you
  21 ;; can know your rights and responsibilities.  It should be in a
  22 ;; file named COPYING.  Among other things, the copyright notice
  23 ;; and this notice must be preserved on all copies.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 ;; This file is autoloaded from calc-ext.el.
  30
  31 (require 'calc-ext)
  32 (require 'calc-macs)
  33
  34 ;;; Units operations.
  35
  36 ;;; Units table last updated 9-Jan-91 by Ulrich Mueller (ulm@vsnhd1.cern.ch)
  37 ;;; with some additions by Przemek Klosowski (przemek@rrdstrad.nist.gov)
  38 ;;; Updated April 2002 by Jochen Küpper
  39
  40 ;;; for CODATA 1998 see one of
  41 ;;; - Journal of Physical and Chemical Reference Data, 28(6), 1713-1852, 1999.
  42 ;;; - Reviews of Modern Physics, 72(2), 351-495, 2000.
  43 ;;; - http://physics.nist.gov/cuu/Constants/index.html
  44
  45 (defvar math-standard-units
  46   '( ;; Length
  47     ( m       nil                    "*Meter" )
  48     ( in      "2.54 cm"             "Inch" )
  49     ( ft      "12 in"                "Foot" )
  50     ( yd      "3 ft"                 "Yard" )
  51     ( mi      "5280 ft"      "Mile" )
  52     ( au      "149597870691 m"      "Astronomical Unit" ) ;; NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html)
  53     ( lyr     "9460536207068016 m"  "Light Year" )
  54     ( pc      "206264.80625 au"     "Parsec" )
  55     ( nmi     "1852 m"               "Nautical Mile" )
  56     ( fath    "6 ft"                 "Fathom" )
  57     ( u       "1 um"                 "Micron" )
  58     ( mil     "in/1000"      "Mil" )
  59     ( point   "in/72"                "Point (1/72 inch)" )
  60     ( tpt     "in/72.27"             "Point (TeX conventions)" )
  61     ( Ang     "1e-10 m"      "Angstrom" )
  62     ( mfi     "mi+ft+in"             "Miles + feet + inches" )
  63
  64     ;; Area
  65     ( hect    "10000 m^2"            "*Hectare" )
  66     ( acre    "mi^2 / 640"           "Acre" )
  67     ( b       "1e-28 m^2"            "Barn" )
  68
  69     ;; Volume
  70     ( l       "1e-3 m^3"             "*Liter" )
  71     ( L       "1e-3 m^3"             "Liter" )
  72     ( gal     "4 qt"                 "US Gallon" )
  73     ( qt      "2 pt"                 "Quart" )
  74     ( pt      "2 cup"                "Pint" )
  75     ( cup     "8 ozfl"               "Cup" )
  76     ( ozfl    "2 tbsp"               "Fluid Ounce" )
  77     ( floz    "2 tbsp"               "Fluid Ounce" )
  78     ( tbsp    "3 tsp"                "Tablespoon" )
  79     ( tsp     "4.92892159375 ml"    "Teaspoon" )
  80     ( vol     "tsp+tbsp+ozfl+cup+pt+qt+gal" "Gallons + ... + teaspoons" )
  81     ( galC    "4.54609 l"            "Canadian Gallon" )
  82     ( galUK   "4.546092 l"           "UK Gallon" )
  83
  84     ;; Time
  85     ( s       nil                    "*Second" )
  86     ( sec     "s"                    "Second" )
  87     ( min     "60 s"                 "Minute" )
  88     ( hr      "60 min"               "Hour" )
  89     ( day     "24 hr"                "Day" )
  90     ( wk      "7 day"                "Week" )
  91     ( hms     "wk+day+hr+min+s"     "Hours, minutes, seconds" )
  92     ( yr      "365.25 day"           "Year" )
  93     ( Hz      "1/s"                  "Hertz" )
  94
  95     ;; Speed
  96     ( mph     "mi/hr"                "*Miles per hour" )
  97     ( kph     "km/hr"                "Kilometers per hour" )
  98     ( knot    "nmi/hr"               "Knot" )
  99     ( c       "2.99792458e8 m/s"    "Speed of light" )
 100
 101     ;; Acceleration
 102     ( ga      "9.80665 m/s^2"        "*\"g\" acceleration" )
 103
 104     ;; Mass
 105     ( g       nil                   "*Gram" )
 106     ( lb      "16 oz"                "Pound (mass)" )
 107     ( oz      "28.349523125 g"       "Ounce (mass)" )
 108     ( ton     "2000 lb"      "Ton" )
 109     ( tpo     "ton+lb+oz"            "Tons + pounds + ounces (mass)" )
 110     ( t       "1000 kg"      "Metric ton" )
 111     ( tonUK   "1016.0469088 kg"     "UK ton" )
 112     ( lbt     "12 ozt"               "Troy pound" )
 113     ( ozt     "31.103475 g"          "Troy ounce" )
 114     ( ct      ".2 g"                 "Carat" )
 115     ( amu     "1.66053873e-27 kg"   "Unified atomic mass" ) ;; CODATA 1998
 116
 117     ;; Force
 118     ( N       "m kg/s^2"             "*Newton" )
 119     ( dyn     "1e-5 N"               "Dyne" )
 120     ( gf      "ga g"                 "Gram (force)" )
 121     ( lbf     "4.44822161526 N"     "Pound (force)" )
 122     ( kip     "1000 lbf"             "Kilopound (force)" )
 123     ( pdl     "0.138255 N"           "Poundal" )
 124
 125     ;; Energy
 126     ( J       "N m"                  "*Joule" )
 127     ( erg     "1e-7 J"               "Erg" )
 128     ( cal     "4.1868 J"             "International Table Calorie" )
 129     ( Btu     "1055.05585262 J"     "International Table Btu" )
 130     ( eV      "ech V"               "Electron volt" )
 131     ( ev      "eV"                  "Electron volt" )
 132     ( therm   "105506000 J"          "EEC therm" )
 133     ( invcm   "h c/cm"               "Energy in inverse centimeters" )
 134     ( Kayser  "invcm"                "Kayser (inverse centimeter energy)" )
 135     ( men     "100/invcm"            "Inverse energy in meters" )
 136     ( Hzen    "h Hz"                 "Energy in Hertz")
 137     ( Ken     "k K"                  "Energy in Kelvins")
 138     ( Wh      "W h"                 "Watt hour")
 139     ( Ws      "W s"                 "Watt second")
 140
 141     ;; Power
 142     ( W       "J/s"                  "*Watt" )
 143     ( hp      "745.7 W"      "Horsepower" )
 144
 145     ;; Temperature
 146     ( K       nil                   "*Degree Kelvin"     K )
 147     ( dK      "K"                    "Degree Kelvin"      K )
 148     ( degK    "K"                    "Degree Kelvin"      K )
 149     ( dC      "K"                    "Degree Celsius"     C )
 150     ( degC    "K"            "Degree Celsius"     C )
 151     ( dF      "(5/9) K"      "Degree Fahrenheit"  F )
 152     ( degF    "(5/9) K"      "Degree Fahrenheit"  F )
 153
 154     ;; Pressure
 155     ( Pa      "N/m^2"                "*Pascal" )
 156     ( bar     "1e5 Pa"               "Bar" )
 157     ( atm     "101325 Pa"            "Standard atmosphere" )
 158     ( torr    " 1.333224e2 Pa"       "Torr" ) ;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html)
 159     ( mHg     "1000 torr"            "Meter of mercury" )
 160     ( inHg    "25.4 mmHg"            "Inch of mercury" )
 161     ( inH2O   "2.490889e2 Pa"        "Inch of water" ) ;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html)
 162     ( psi     "6894.75729317 Pa"    "Pound per square inch" )
 163
 164     ;; Viscosity
 165     ( P       "0.1 Pa s"             "*Poise" )
 166     ( St      "1e-4 m^2/s"           "Stokes" )
 167
 168     ;; Electromagnetism
 169     ( A       nil                   "*Ampere" )
 170     ( C       "A s"                  "Coulomb" )
 171     ( Fdy     "ech Nav"              "Faraday" )
 172     ( e       "1.602176462e-19 C"   "Elementary charge" ) ;; CODATA 1998
 173     ( ech     "1.602176462e-19 C"   "Elementary charge" ) ;; CODATA 1998
 174     ( V       "W/A"                  "Volt" )
 175     ( ohm     "V/A"                  "Ohm" )
 176     ( mho     "A/V"                  "Mho" )
 177     ( S       "A/V"                  "Siemens" )
 178     ( F       "C/V"                  "Farad" )
 179     ( H       "Wb/A"                 "Henry" )
 180     ( T       "Wb/m^2"               "Tesla" )
 181     ( G       "1e-4 T"               "Gauss" )
 182     ( Wb      "V s"                  "Weber" )
 183
 184     ;; Luminous intensity
 185     ( cd      nil                   "*Candela" )
 186     ( sb      "1e4 cd/m^2"           "Stilb" )
 187     ( lm      "cd sr"                "Lumen" )
 188     ( lx      "lm/m^2"               "Lux" )
 189     ( ph      "1e4 lx"               "Phot" )
 190     ( fc      "10.76391 lx"          "Footcandle" ) ;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html)
 191     ( lam     "1e4 lm/m^2"           "Lambert" )
 192     ( flam    "3.426259 cd/m^2"     "Footlambert" ) ;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html)
 193
 194     ;; Radioactivity
 195     ( Bq      "1/s"                  "*Becquerel" )
 196     ( Ci      "3.7e10 Bq"            "Curie" )
 197     ( Gy      "J/kg"                 "Gray" )
 198     ( Sv      "Gy"                   "Sievert" )
 199     ( R       "2.58e-4 C/kg"         "Roentgen" )
 200     ( rd      ".01 Gy"               "Rad" )
 201     ( rem     "rd"                   "Rem" )
 202
 203     ;; Amount of substance
 204     ( mol     nil                   "*Mole" )
 205
 206     ;; Plane angle
 207     ( rad     nil                   "*Radian" )
 208     ( circ    "2 pi rad"             "Full circle" )
 209     ( rev     "circ"                 "Full revolution" )
 210     ( deg     "circ/360"            "Degree" )
 211     ( arcmin  "deg/60"               "Arc minute" )
 212     ( arcsec  "arcmin/60"            "Arc second" )
 213     ( grad    "circ/400"            "Grade" )
 214     ( rpm     "rev/min"      "Revolutions per minute" )
 215
 216     ;; Solid angle
 217     ( sr      nil                    "*Steradian" )
 218
 219     ;; Other physical quantities (CODATA 1998)
 220     ( h       "6.62606876e-34 J s"     "*Planck's constant" )
 221     ( hbar    "h / 2 pi"               "Planck's constant" )
 222     ( mu0     "4 pi 1e-7 H/m"          "Permeability of vacuum" )
 223     ( Grav    "6.673e-11 m^3/kg^1/s^2" "Gravitational constant" )
 224     ( Nav     "6.02214199e23 / mol"    "Avagadro's constant" )
 225     ( me      "9.10938188e-31 kg"      "Electron rest mass" )
 226     ( mp      "1.67262158e-27 kg"      "Proton rest mass" )
 227     ( mn      "1.67492716e-27 kg"      "Neutron rest mass" )
 228     ( mu      "1.88353109e-28 kg"      "Muon rest mass" )
 229     ( Ryd     "10973731.568549 /m"     "Rydberg's constant" )
 230     ( k       "1.3806503e-23 J/K"      "Boltzmann's constant" )
 231     ( fsc     "7.297352533e-3"         "Fine structure constant" )
 232     ( muB     "927.400899e-26 J/T"     "Bohr magneton" )
 233     ( muN     "5.05078317e-27 J/T"     "Nuclear magneton" )
 234     ( mue     "-928.476362e-26 J/T"    "Electron magnetic moment" )
 235     ( mup     "1.410606633e-26 J/T"    "Proton magnetic moment" )
 236     ( R0      "8.314472 J/mol/K"       "Molar gas constant" )
 237     ( V0      "22.710981e-3 m^3/mol"   "Standard volume of ideal gas" )))
 238
 239
 240 (defvar math-additional-units nil
 241   "*Additional units table for user-defined units.
 242 Must be formatted like math-standard-units.
 243 If this is changed, be sure to set math-units-table to nil to ensure
 244 that the combined units table will be rebuilt.")
 245
 246 (defvar math-unit-prefixes
 247   '( ( ?E  (float 1 18)  "Exa"    )
 248      ( ?P  (float 1 15)  "Peta"   )
 249      ( ?T  (float 1 12)  "Tera"   )
 250      ( ?G  (float 1 9)   "Giga"   )
 251      ( ?M  (float 1 6)   "Mega"   )
 252      ( ?k  (float 1 3)   "Kilo"   )
 253      ( ?K  (float 1 3)   "Kilo"   )
 254      ( ?h  (float 1 2)   "Hecto"  )
 255      ( ?H  (float 1 2)   "Hecto"  )
 256      ( ?D  (float 1 1)   "Deka"   )
 257      ( 0   (float 1 0)   nil      )
 258      ( ?d  (float 1 -1)  "Deci"   )
 259      ( ?c  (float 1 -2)  "Centi"  )
 260      ( ?m  (float 1 -3)  "Milli"  )
 261      ( ?u  (float 1 -6)  "Micro"  )
 262      ( ?n  (float 1 -9)  "Nano"   )
 263      ( ?p  (float 1 -12) "Pico"   )
 264      ( ?f  (float 1 -15) "Femto"  )
 265      ( ?a  (float 1 -18) "Atto"   )))
 266
 267 (defvar math-standard-units-systems
 268   '( ( base  nil )
 269      ( si    ( ( g   '(* (var kg var-kg) (float 1 -3)) ) ) )
 270      ( mks   ( ( g   '(* (var kg var-kg) (float 1 -3)) ) ) )
 271      ( cgs   ( ( m   '(* (var cm var-cm) 100         ) ) ) )))
 272
 273 (defvar math-units-table nil
 274   "Internal units table derived from math-defined-units.
 275 Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).")
 276
 277 (defvar math-units-table-buffer-valid nil)
 278
 279 ;;; Units commands.
 280
 281 (defun calc-base-units ()
 282   (interactive)
 283   (calc-slow-wrapper
 284    (let ((calc-autorange-units nil))
 285      (calc-enter-result 1 "bsun" (math-simplify-units
 286                                   (math-to-standard-units (calc-top-n 1)
 287                                                           nil))))))
 288
 289 (defun calc-quick-units ()
 290   (interactive)
 291   (calc-slow-wrapper
 292    (let* ((num (- last-command-char ?0))
 293           (pos (if (= num 0) 10 num))
 294           (units (calc-var-value 'var-Units))
 295           (expr (calc-top-n 1)))
 296      (unless (and (>= num 0) (<= num 9))
 297        (error "Bad unit number"))
 298      (unless (math-vectorp units)
 299        (error "No \"quick units\" are defined"))
 300      (unless (< pos (length units))
 301        (error "Unit number %d not defined" pos))
 302      (if (math-units-in-expr-p expr nil)
 303          (calc-enter-result 1 (format "cun%d" num)
 304                             (math-convert-units expr (nth pos units)))
 305        (calc-enter-result 1 (format "*un%d" num)
 306                           (math-simplify-units
 307                            (math-mul expr (nth pos units))))))))
 308
 309 (defun calc-convert-units (&optional old-units new-units)
 310   (interactive)
 311   (calc-slow-wrapper
 312    (let ((expr (calc-top-n 1))
 313          (uoldname nil)
 314          unew
 315          units)
 316      (unless (math-units-in-expr-p expr t)
 317        (let ((uold (or old-units
 318                        (progn
 319                          (setq uoldname (read-string "Old units: "))
 320                          (if (equal uoldname "")
 321                              (progn
 322                                (setq uoldname "1")
 323                                1)
 324                            (if (string-match "\\` */" uoldname)
 325                                (setq uoldname (concat "1" uoldname)))
 326                            (math-read-expr uoldname))))))
 327          (when (eq (car-safe uold) 'error)
 328            (error "Bad format in units expression: %s" (nth 1 uold)))
 329          (setq expr (math-mul expr uold))))
 330      (unless new-units
 331        (setq new-units (read-string (if uoldname
 332                                         (concat "Old units: "
 333                                                 uoldname
 334                                                 ", new units: ")
 335                                       "New units: "))))
 336      (when (string-match "\\` */" new-units)
 337        (setq new-units (concat "1" new-units)))
 338      (setq units (math-read-expr new-units))
 339      (when (eq (car-safe units) 'error)
 340        (error "Bad format in units expression: %s" (nth 2 units)))
 341      (let ((unew (math-units-in-expr-p units t))
 342            (std (and (eq (car-safe units) 'var)
 343                      (assq (nth 1 units) math-standard-units-systems))))
 344        (if std
 345            (calc-enter-result 1 "cvun" (math-simplify-units
 346                                         (math-to-standard-units expr
 347                                                                 (nth 1 std))))
 348          (unless unew
 349            (error "No units specified"))
 350          (calc-enter-result 1 "cvun"
 351                             (math-convert-units
 352                              expr units
 353                              (and uoldname (not (equal uoldname "1"))))))))))
 354
 355 (defun calc-autorange-units (arg)
 356   (interactive "P")
 357   (calc-wrapper
 358    (calc-change-mode 'calc-autorange-units arg nil t)
 359    (message (if calc-autorange-units
 360                 "Adjusting target unit prefix automatically"
 361               "Using target units exactly"))))
 362
 363 (defun calc-convert-temperature (&optional old-units new-units)
 364   (interactive)
 365   (calc-slow-wrapper
 366    (let ((expr (calc-top-n 1))
 367          (uold nil)
 368          (uoldname nil)
 369          unew)
 370      (setq uold (or old-units
 371                     (let ((units (math-single-units-in-expr-p expr)))
 372                       (if units
 373                           (if (consp units)
 374                               (list 'var (car units)
 375                                     (intern (concat "var-"
 376                                                     (symbol-name
 377                                                      (car units)))))
 378                             (error "Not a pure temperature expression"))
 379                         (math-read-expr
 380                          (setq uoldname (read-string
 381                                          "Old temperature units: ")))))))
 382      (when (eq (car-safe uold) 'error)
 383        (error "Bad format in units expression: %s" (nth 2 uold)))
 384      (or (math-units-in-expr-p expr nil)
 385          (setq expr (math-mul expr uold)))
 386      (setq unew (or new-units
 387                     (math-read-expr
 388                      (read-string (if uoldname
 389                                       (concat "Old temperature units: "
 390                                               uoldname
 391                                               ", new units: ")
 392                                     "New temperature units: ")))))
 393      (when (eq (car-safe unew) 'error)
 394        (error "Bad format in units expression: %s" (nth 2 unew)))
 395      (calc-enter-result 1 "cvtm" (math-simplify-units
 396                                   (math-convert-temperature expr uold unew
 397                                                             uoldname))))))
 398
 399 (defun calc-remove-units ()
 400   (interactive)
 401   (calc-slow-wrapper
 402    (calc-enter-result 1 "rmun" (math-simplify-units
 403                                 (math-remove-units (calc-top-n 1))))))
 404
 405 (defun calc-extract-units ()
 406   (interactive)
 407   (calc-slow-wrapper
 408    (calc-enter-result 1 "rmun" (math-simplify-units
 409                                 (math-extract-units (calc-top-n 1))))))
 410
 411 ;; The variables calc-num-units and calc-den-units are local to
 412 ;; calc-explain-units, but are used by calc-explain-units-rec,
 413 ;; which is called by calc-explain-units.
 414 (defvar calc-num-units)
 415 (defvar calc-den-units)
 416
 417 (defun calc-explain-units ()
 418   (interactive)
 419   (calc-wrapper
 420    (let ((calc-num-units nil)
 421          (calc-den-units nil))
 422      (calc-explain-units-rec (calc-top-n 1) 1)
 423      (and calc-den-units (string-match "^[^(].* .*[^)]$" calc-den-units)
 424           (setq calc-den-units (concat "(" calc-den-units ")")))
 425      (if calc-num-units
 426          (if calc-den-units
 427              (message "%s per %s" calc-num-units calc-den-units)
 428            (message "%s" calc-num-units))
 429        (if calc-den-units
 430            (message "1 per %s" calc-den-units)
 431          (message "No units in expression"))))))
 432
 433 (defun calc-explain-units-rec (expr pow)
 434   (let ((u (math-check-unit-name expr))
 435         pos)
 436     (if (and u (not (math-zerop pow)))
 437         (let ((name (or (nth 2 u) (symbol-name (car u)))))
 438           (if (eq (aref name 0) ?\*)
 439               (setq name (substring name 1)))
 440           (if (string-match "[^a-zA-Z0-9']" name)
 441               (if (string-match "^[a-zA-Z0-9' ()]*$" name)
 442                   (while (setq pos (string-match "[ ()]" name))
 443                     (setq name (concat (substring name 0 pos)
 444                                        (if (eq (aref name pos) 32) "-" "")
 445                                        (substring name (1+ pos)))))
 446                 (setq name (concat "(" name ")"))))
 447           (or (eq (nth 1 expr) (car u))
 448               (setq name (concat (nth 2 (assq (aref (symbol-name
 449                                                      (nth 1 expr)) 0)
 450                                               math-unit-prefixes))
 451                                  (if (and (string-match "[^a-zA-Z0-9']" name)
 452                                           (not (memq (car u) '(mHg gf))))
 453                                      (concat "-" name)
 454                                    (downcase name)))))
 455           (cond ((or (math-equal-int pow 1)
 456                      (math-equal-int pow -1)))
 457                 ((or (math-equal-int pow 2)
 458                      (math-equal-int pow -2))
 459                  (if (equal (nth 4 u) '((m . 1)))
 460                      (setq name (concat "Square-" name))
 461                    (setq name (concat name "-squared"))))
 462                 ((or (math-equal-int pow 3)
 463                      (math-equal-int pow -3))
 464                  (if (equal (nth 4 u) '((m . 1)))
 465                      (setq name (concat "Cubic-" name))
 466                    (setq name (concat name "-cubed"))))
 467                 (t
 468                  (setq name (concat name "^"
 469                                     (math-format-number (math-abs pow))))))
 470           (if (math-posp pow)
 471               (setq calc-num-units (if calc-num-units
 472                                   (concat calc-num-units " " name)
 473                                 name))
 474             (setq calc-den-units (if calc-den-units
 475                                 (concat calc-den-units " " name)
 476                               name))))
 477       (cond ((eq (car-safe expr) '*)
 478              (calc-explain-units-rec (nth 1 expr) pow)
 479              (calc-explain-units-rec (nth 2 expr) pow))
 480             ((eq (car-safe expr) '/)
 481              (calc-explain-units-rec (nth 1 expr) pow)
 482              (calc-explain-units-rec (nth 2 expr) (- pow)))
 483             ((memq (car-safe expr) '(neg + -))
 484              (calc-explain-units-rec (nth 1 expr) pow))
 485             ((and (eq (car-safe expr) '^)
 486                   (math-realp (nth 2 expr)))
 487              (calc-explain-units-rec (nth 1 expr)
 488                                      (math-mul pow (nth 2 expr))))))))
 489
 490 (defun calc-simplify-units ()
 491   (interactive)
 492   (calc-slow-wrapper
 493    (calc-with-default-simplification
 494     (calc-enter-result 1 "smun" (math-simplify-units (calc-top-n 1))))))
 495
 496 (defun calc-view-units-table (n)
 497   (interactive "P")
 498   (and n (setq math-units-table-buffer-valid nil))
 499   (let ((win (get-buffer-window "*Units Table*")))
 500     (if (and win
 501              math-units-table
 502              math-units-table-buffer-valid)
 503         (progn
 504           (bury-buffer (window-buffer win))
 505           (let ((curwin (selected-window)))
 506             (select-window win)
 507             (switch-to-buffer nil)
 508             (select-window curwin)))
 509       (math-build-units-table-buffer nil))))
 510
 511 (defun calc-enter-units-table (n)
 512   (interactive "P")
 513   (and n (setq math-units-table-buffer-valid nil))
 514   (math-build-units-table-buffer t)
 515   (message (substitute-command-keys "Type \\[calc] to return to the Calculator")))
 516
 517 (defun calc-define-unit (uname desc)
 518   (interactive "SDefine unit name: \nsDescription: ")
 519   (calc-wrapper
 520    (let ((form (calc-top-n 1))
 521          (unit (assq uname math-additional-units)))
 522      (or unit
 523          (setq math-additional-units
 524                (cons (setq unit (list uname nil nil))
 525                      math-additional-units)
 526                math-units-table nil))
 527      (setcar (cdr unit) (and (not (and (eq (car-safe form) 'var)
 528                                        (eq (nth 1 form) uname)))
 529                              (not (math-equal-int form 1))
 530                              (math-format-flat-expr form 0)))
 531      (setcar (cdr (cdr unit)) (and (not (equal desc ""))
 532                                    desc))))
 533   (calc-invalidate-units-table))
 534
 535 (defun calc-undefine-unit (uname)
 536   (interactive "SUndefine unit name: ")
 537   (calc-wrapper
 538    (let ((unit (assq uname math-additional-units)))
 539      (or unit
 540          (if (assq uname math-standard-units)
 541              (error "\"%s\" is a predefined unit name" uname)
 542            (error "Unit name \"%s\" not found" uname)))
 543      (setq math-additional-units (delq unit math-additional-units)
 544            math-units-table nil)))
 545   (calc-invalidate-units-table))
 546
 547 (defun calc-invalidate-units-table ()
 548   (setq math-units-table nil)
 549   (let ((buf (get-buffer "*Units Table*")))
 550     (and buf
 551          (save-excursion
 552            (set-buffer buf)
 553            (save-excursion
 554              (goto-char (point-min))
 555              (if (looking-at "Calculator Units Table")
 556                  (let ((buffer-read-only nil))
 557                    (insert "(Obsolete) "))))))))
 558
 559 (defun calc-get-unit-definition (uname)
 560   (interactive "SGet definition for unit: ")
 561   (calc-wrapper
 562    (math-build-units-table)
 563    (let ((unit (assq uname math-units-table)))
 564      (or unit
 565          (error "Unit name \"%s\" not found" uname))
 566      (let ((msg (nth 2 unit)))
 567        (if (stringp msg)
 568            (if (string-match "^\\*" msg)
 569                (setq msg (substring msg 1)))
 570          (setq msg (symbol-name uname)))
 571        (if (nth 1 unit)
 572            (progn
 573              (calc-enter-result 0 "ugdf" (nth 1 unit))
 574              (message "Derived unit: %s" msg))
 575          (calc-enter-result 0 "ugdf" (list 'var uname
 576                                            (intern
 577                                             (concat "var-"
 578                                                     (symbol-name uname)))))
 579          (message "Base unit: %s" msg))))))
 580
 581 (defun calc-permanent-units ()
 582   (interactive)
 583   (calc-wrapper
 584    (let (pos)
 585      (set-buffer (find-file-noselect (substitute-in-file-name
 586                                       calc-settings-file)))
 587      (goto-char (point-min))
 588      (if (and (search-forward ";;; Custom units stored by Calc" nil t)
 589               (progn
 590                 (beginning-of-line)
 591                 (setq pos (point))
 592                 (search-forward "\n;;; End of custom units" nil t)))
 593          (progn
 594            (beginning-of-line)
 595            (forward-line 1)
 596            (delete-region pos (point)))
 597        (goto-char (point-max))
 598        (insert "\n\n")
 599        (forward-char -1))
 600      (insert ";;; Custom units stored by Calc on " (current-time-string) "\n")
 601      (if math-additional-units
 602          (progn
 603            (insert "(setq math-additional-units '(\n")
 604            (let ((list math-additional-units))
 605              (while list
 606                (insert "  (" (symbol-name (car (car list))) " "
 607                        (if (nth 1 (car list))
 608                            (if (stringp (nth 1 (car list)))
 609                                (prin1-to-string (nth 1 (car list)))
 610                              (prin1-to-string (math-format-flat-expr
 611                                                (nth 1 (car list)) 0)))
 612                          "nil")
 613                        " "
 614                        (prin1-to-string (nth 2 (car list)))
 615                        ")\n")
 616                (setq list (cdr list))))
 617            (insert "))\n"))
 618        (insert ";;; (no custom units defined)\n"))
 619      (insert ";;; End of custom units\n")
 620      (save-buffer))))
 621
 622
 623 ;; The variable math-cu-unit-list is local to math-build-units-table,
 624 ;; but is used by math-compare-unit-names, which is called (indirectly)
 625 ;; by math-build-units-table.
 626 ;; math-cu-unit-list is also local to math-convert-units, but is used
 627 ;; by math-convert-units-rec, which is called by math-convert-units.
 628 (defvar math-cu-unit-list)
 629
 630 (defun math-build-units-table ()
 631   (or math-units-table
 632       (let* ((combined-units (append math-additional-units
 633                                      math-standard-units))
 634              (math-cu-unit-list (mapcar 'car combined-units))
 635              tab)
 636         (message "Building units table...")
 637         (setq math-units-table-buffer-valid nil)
 638         (setq tab (mapcar (function
 639                            (lambda (x)
 640                              (list (car x)
 641                                    (and (nth 1 x)
 642                                         (if (stringp (nth 1 x))
 643                                             (let ((exp (math-read-plain-expr
 644                                                         (nth 1 x))))
 645                                               (if (eq (car-safe exp) 'error)
 646                                                   (error "Format error in definition of %s in units table: %s"
 647                                                          (car x) (nth 2 exp))
 648                                                 exp))
 649                                           (nth 1 x)))
 650                                    (nth 2 x)
 651                                    (nth 3 x)
 652                                    (and (not (nth 1 x))
 653                                         (list (cons (car x) 1))))))
 654                           combined-units))
 655         (let ((math-units-table tab))
 656           (mapcar 'math-find-base-units tab))
 657         (message "Building units table...done")
 658         (setq math-units-table tab))))
 659
 660 ;; The variables math-fbu-base and math-fbu-entry are local to
 661 ;; math-find-base-units, but are used by math-find-base-units-rec,
 662 ;; which is called by math-find-base-units.
 663 (defvar math-fbu-base)
 664 (defvar math-fbu-entry)
 665
 666 (defun math-find-base-units (math-fbu-entry)
 667   (if (eq (nth 4 math-fbu-entry) 'boom)
 668       (error "Circular definition involving unit %s" (car math-fbu-entry)))
 669   (or (nth 4 math-fbu-entry)
 670       (let (math-fbu-base)
 671         (setcar (nthcdr 4 math-fbu-entry) 'boom)
 672         (math-find-base-units-rec (nth 1 math-fbu-entry) 1)
 673         '(or math-fbu-base
 674             (error "Dimensionless definition for unit %s" (car math-fbu-entry)))
 675         (while (eq (cdr (car math-fbu-base)) 0)
 676           (setq math-fbu-base (cdr math-fbu-base)))
 677         (let ((b math-fbu-base))
 678           (while (cdr b)
 679             (if (eq (cdr (car (cdr b))) 0)
 680                 (setcdr b (cdr (cdr b)))
 681               (setq b (cdr b)))))
 682         (setq math-fbu-base (sort math-fbu-base 'math-compare-unit-names))
 683         (setcar (nthcdr 4 math-fbu-entry) math-fbu-base)
 684         math-fbu-base)))
 685
 686 (defun math-compare-unit-names (a b)
 687   (memq (car b) (cdr (memq (car a) math-cu-unit-list))))
 688
 689 (defun math-find-base-units-rec (expr pow)
 690   (let ((u (math-check-unit-name expr)))
 691     (cond (u
 692            (let ((ulist (math-find-base-units u)))
 693              (while ulist
 694                (let ((p (* (cdr (car ulist)) pow))
 695                      (old (assq (car (car ulist)) math-fbu-base)))
 696                  (if old
 697                      (setcdr old (+ (cdr old) p))
 698                    (setq math-fbu-base
 699                          (cons (cons (car (car ulist)) p) math-fbu-base))))
 700                (setq ulist (cdr ulist)))))
 701           ((math-scalarp expr))
 702           ((and (eq (car expr) '^)
 703                 (integerp (nth 2 expr)))
 704            (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr))))
 705           ((eq (car expr) '*)
 706            (math-find-base-units-rec (nth 1 expr) pow)
 707            (math-find-base-units-rec (nth 2 expr) pow))
 708           ((eq (car expr) '/)
 709            (math-find-base-units-rec (nth 1 expr) pow)
 710            (math-find-base-units-rec (nth 2 expr) (- pow)))
 711           ((eq (car expr) 'neg)
 712            (math-find-base-units-rec (nth 1 expr) pow))
 713           ((eq (car expr) '+)
 714            (math-find-base-units-rec (nth 1 expr) pow))
 715           ((eq (car expr) 'var)
 716            (or (eq (nth 1 expr) 'pi)
 717                (error "Unknown name %s in defining expression for unit %s"
 718                       (nth 1 expr) (car math-fbu-entry))))
 719           (t (error "Malformed defining expression for unit %s" (car math-fbu-entry))))))
 720
 721
 722 (defun math-units-in-expr-p (expr sub-exprs)
 723   (and (consp expr)
 724        (if (eq (car expr) 'var)
 725            (math-check-unit-name expr)
 726          (and (or sub-exprs
 727                   (memq (car expr) '(* / ^)))
 728               (or (math-units-in-expr-p (nth 1 expr) sub-exprs)
 729                   (math-units-in-expr-p (nth 2 expr) sub-exprs))))))
 730
 731 (defun math-only-units-in-expr-p (expr)
 732   (and (consp expr)
 733        (if (eq (car expr) 'var)
 734            (math-check-unit-name expr)
 735          (if (memq (car expr) '(* /))
 736              (and (math-only-units-in-expr-p (nth 1 expr))
 737                   (math-only-units-in-expr-p (nth 2 expr)))
 738            (and (eq (car expr) '^)
 739                 (and (math-only-units-in-expr-p (nth 1 expr))
 740                      (math-realp (nth 2 expr))))))))
 741
 742 (defun math-single-units-in-expr-p (expr)
 743   (cond ((math-scalarp expr) nil)
 744         ((eq (car expr) 'var)
 745          (math-check-unit-name expr))
 746         ((eq (car expr) '*)
 747          (let ((u1 (math-single-units-in-expr-p (nth 1 expr)))
 748                (u2 (math-single-units-in-expr-p (nth 2 expr))))
 749            (or (and u1 u2 'wrong)
 750                u1
 751                u2)))
 752         ((eq (car expr) '/)
 753          (if (math-units-in-expr-p (nth 2 expr) nil)
 754              'wrong
 755            (math-single-units-in-expr-p (nth 1 expr))))
 756         (t 'wrong)))
 757
 758 (defun math-check-unit-name (v)
 759   (and (eq (car-safe v) 'var)
 760        (or (assq (nth 1 v) (or math-units-table (math-build-units-table)))
 761            (let ((name (symbol-name (nth 1 v))))
 762              (and (> (length name) 1)
 763                   (assq (aref name 0) math-unit-prefixes)
 764                   (or (assq (intern (substring name 1)) math-units-table)
 765                       (and (eq (aref name 0) ?M)
 766                            (> (length name) 3)
 767                            (eq (aref name 1) ?e)
 768                            (eq (aref name 2) ?g)
 769                            (assq (intern (substring name 3))
 770                                  math-units-table))))))))
 771
 772 ;; The variable math-which-standard is local to math-to-standard-units,
 773 ;; but is used by math-to-standard-rec, which is called by
 774 ;; math-to-standard-units.
 775 (defvar math-which-standard)
 776
 777 (defun math-to-standard-units (expr math-which-standard)
 778   (math-to-standard-rec expr))
 779
 780 (defun math-to-standard-rec (expr)
 781   (if (eq (car-safe expr) 'var)
 782       (let ((u (math-check-unit-name expr))
 783             (base (nth 1 expr)))
 784         (if u
 785             (progn
 786               (if (nth 1 u)
 787                   (setq expr (math-to-standard-rec (nth 1 u)))
 788                 (let ((st (assq (car u) math-which-standard)))
 789                   (if st
 790                       (setq expr (nth 1 st))
 791                     (setq expr (list 'var (car u)
 792                                      (intern (concat "var-"
 793                                                      (symbol-name
 794                                                       (car u)))))))))
 795               (or (null u)
 796                   (eq base (car u))
 797                   (setq expr (list '*
 798                                    (nth 1 (assq (aref (symbol-name base) 0)
 799                                                 math-unit-prefixes))
 800                                    expr)))
 801               expr)
 802           (if (eq base 'pi)
 803               (math-pi)
 804             expr)))
 805     (if (Math-primp expr)
 806         expr
 807       (cons (car expr)
 808             (mapcar 'math-to-standard-rec (cdr expr))))))
 809
 810 (defun math-apply-units (expr units ulist &optional pure)
 811   (if ulist
 812       (let ((new 0)
 813             value)
 814         (setq expr (math-simplify-units expr))
 815         (or (math-numberp expr)
 816             (error "Incompatible units"))
 817         (while (cdr ulist)
 818           (setq value (math-div expr (nth 1 (car ulist)))
 819                 value (math-floor (let ((calc-internal-prec
 820                                          (1- calc-internal-prec)))
 821                                     (math-normalize value)))
 822                 new (math-add new (math-mul value (car (car ulist))))
 823                 expr (math-sub expr (math-mul value (nth 1 (car ulist))))
 824                 ulist (cdr ulist)))
 825         (math-add new (math-mul (math-div expr (nth 1 (car ulist)))
 826                                 (car (car ulist)))))
 827     (math-simplify-units (if pure
 828                              expr
 829                            (list '* expr units)))))
 830
 831 (defvar math-decompose-units-cache nil)
 832 (defun math-decompose-units (units)
 833   (let ((u (math-check-unit-name units)))
 834     (and u (eq (car-safe (nth 1 u)) '+)
 835          (setq units (nth 1 u))))
 836   (setq units (calcFunc-expand units))
 837   (and (eq (car-safe units) '+)
 838        (let ((entry (list units calc-internal-prec calc-prefer-frac)))
 839          (or (equal entry (car math-decompose-units-cache))
 840              (let ((ulist nil)
 841                    (utemp units)
 842                    qty unit)
 843                (while (eq (car-safe utemp) '+)
 844                  (setq ulist (cons (math-decompose-unit-part (nth 2 utemp))
 845                                    ulist)
 846                        utemp (nth 1 utemp)))
 847                (setq ulist (cons (math-decompose-unit-part utemp) ulist)
 848                      utemp ulist)
 849                (while (setq utemp (cdr utemp))
 850                  (unless (equal (nth 2 (car utemp)) (nth 2 (car ulist)))
 851                    (error "Inconsistent units in sum")))
 852                (setq math-decompose-units-cache
 853                      (cons entry
 854                            (sort ulist
 855                                  (function
 856                                   (lambda (x y)
 857                                     (not (Math-lessp (nth 1 x)
 858                                                      (nth 1 y))))))))))
 859          (cdr math-decompose-units-cache))))
 860
 861 (defun math-decompose-unit-part (unit)
 862   (cons unit
 863         (math-is-multiple (math-simplify-units (math-to-standard-units
 864                                                 unit nil))
 865                           t)))
 866
 867 ;; The variable math-fcu-u is local to math-find-compatible-unit,
 868 ;; but is used by math-find-compatible-rec which is called by
 869 ;; math-find-compatible-unit.
 870 (defvar math-fcu-u)
 871
 872 (defun math-find-compatible-unit (expr unit)
 873   (let ((math-fcu-u (math-check-unit-name unit)))
 874     (if math-fcu-u
 875         (math-find-compatible-unit-rec expr 1))))
 876
 877 (defun math-find-compatible-unit-rec (expr pow)
 878   (cond ((eq (car-safe expr) '*)
 879          (or (math-find-compatible-unit-rec (nth 1 expr) pow)
 880              (math-find-compatible-unit-rec (nth 2 expr) pow)))
 881         ((eq (car-safe expr) '/)
 882          (or (math-find-compatible-unit-rec (nth 1 expr) pow)
 883              (math-find-compatible-unit-rec (nth 2 expr) (- pow))))
 884         ((and (eq (car-safe expr) '^)
 885               (integerp (nth 2 expr)))
 886          (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr))))
 887         (t
 888          (let ((u2 (math-check-unit-name expr)))
 889            (if (equal (nth 4 math-fcu-u) (nth 4 u2))
 890                (cons expr pow))))))
 891
 892 ;; The variables math-cu-new-units and math-cu-pure are local to
 893 ;; math-convert-units, but are used by math-convert-units-rec,
 894 ;; which is called by math-convert-units.
 895 (defvar math-cu-new-units)
 896 (defvar math-cu-pure)
 897
 898 (defun math-convert-units (expr math-cu-new-units &optional math-cu-pure)
 899   (math-with-extra-prec 2
 900     (let ((compat (and (not math-cu-pure)
 901                        (math-find-compatible-unit expr math-cu-new-units)))
 902           (math-cu-unit-list nil)
 903           (math-combining-units nil))
 904       (if compat
 905           (math-simplify-units
 906            (math-mul (math-mul (math-simplify-units
 907                                 (math-div expr (math-pow (car compat)
 908                                                          (cdr compat))))
 909                                (math-pow math-cu-new-units (cdr compat)))
 910                      (math-simplify-units
 911                       (math-to-standard-units
 912                        (math-pow (math-div (car compat) math-cu-new-units)
 913                                  (cdr compat))
 914                        nil))))
 915         (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units))
 916           (setq math-cu-new-units (nth 2 (car math-cu-unit-list))))
 917         (when (eq (car-safe expr) '+)
 918           (setq expr (math-simplify-units expr)))
 919         (if (math-units-in-expr-p expr t)
 920             (math-convert-units-rec expr)
 921           (math-apply-units (math-to-standard-units
 922                              (list '/ expr math-cu-new-units) nil)
 923                             math-cu-new-units math-cu-unit-list math-cu-pure))))))
 924
 925 (defun math-convert-units-rec (expr)
 926   (if (math-units-in-expr-p expr nil)
 927       (math-apply-units (math-to-standard-units
 928                          (list '/ expr math-cu-new-units) nil)
 929                         math-cu-new-units math-cu-unit-list math-cu-pure)
 930     (if (Math-primp expr)
 931         expr
 932       (cons (car expr)
 933             (mapcar 'math-convert-units-rec (cdr expr))))))
 934
 935 (defun math-convert-temperature (expr old new &optional pure)
 936   (let* ((units (math-single-units-in-expr-p expr))
 937          (uold (if old
 938                    (if (or (null units)
 939                            (equal (nth 1 old) (car units)))
 940                        (math-check-unit-name old)
 941                      (error "Inconsistent temperature units"))
 942                  units))
 943          (unew (math-check-unit-name new)))
 944     (unless (and (consp unew) (nth 3 unew))
 945       (error "Not a valid temperature unit"))
 946     (unless (and (consp uold) (nth 3 uold))
 947       (error "Not a pure temperature expression"))
 948     (let ((v (car uold)))
 949       (setq expr (list '/ expr (list 'var v
 950                                      (intern (concat "var-"
 951                                                      (symbol-name v)))))))
 952     (or (eq (nth 3 uold) (nth 3 unew))
 953         (cond ((eq (nth 3 uold) 'K)
 954                (setq expr (list '- expr '(float 27315 -2)))
 955                (if (eq (nth 3 unew) 'F)
 956                    (setq expr (list '+ (list '* expr '(frac 9 5)) 32))))
 957               ((eq (nth 3 uold) 'C)
 958                (if (eq (nth 3 unew) 'F)
 959                    (setq expr (list '+ (list '* expr '(frac 9 5)) 32))
 960                  (setq expr (list '+ expr '(float 27315 -2)))))
 961               (t
 962                (setq expr (list '* (list '- expr 32) '(frac 5 9)))
 963                (if (eq (nth 3 unew) 'K)
 964                    (setq expr (list '+ expr '(float 27315 -2)))))))
 965     (if pure
 966         expr
 967       (list '* expr new))))
 968
 969
 970
 971 (defun math-simplify-units (a)
 972   (let ((math-simplifying-units t)
 973         (calc-matrix-mode 'scalar))
 974     (math-simplify a)))
 975 (defalias 'calcFunc-usimplify 'math-simplify-units)
 976
 977 ;; The function created by math-defsimplify uses the variable
 978 ;; math-simplify-expr, and so is used by functions in math-defsimplify
 979 (defvar math-simplify-expr)
 980
 981 (math-defsimplify (+ -)
 982   (and math-simplifying-units
 983        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
 984        (let* ((units (math-extract-units (nth 1 math-simplify-expr)))
 985               (ratio (math-simplify (math-to-standard-units
 986                                      (list '/ (nth 2 math-simplify-expr) units) nil))))
 987          (if (math-units-in-expr-p ratio nil)
 988              (progn
 989                (calc-record-why "*Inconsistent units" math-simplify-expr)
 990                math-simplify-expr)
 991            (list '* (math-add (math-remove-units (nth 1 math-simplify-expr))
 992                               (if (eq (car math-simplify-expr) '-)
 993                                   (math-neg ratio) ratio))
 994                  units)))))
 995
 996 (math-defsimplify *
 997   (math-simplify-units-prod))
 998
 999 (defun math-simplify-units-prod ()
1000   (and math-simplifying-units
1001        calc-autorange-units
1002        (Math-realp (nth 1 math-simplify-expr))
1003        (let* ((num (math-float (nth 1 math-simplify-expr)))
1004               (xpon (calcFunc-xpon num))
1005               (unitp (cdr (cdr math-simplify-expr)))
1006               (unit (car unitp))
1007               (pow (if (eq (car math-simplify-expr) '*) 1 -1))
1008               u)
1009          (and (eq (car-safe unit) '*)
1010               (setq unitp (cdr unit)
1011                     unit (car unitp)))
1012          (and (eq (car-safe unit) '^)
1013               (integerp (nth 2 unit))
1014               (setq pow (* pow (nth 2 unit))
1015                     unitp (cdr unit)
1016                     unit (car unitp)))
1017          (and (setq u (math-check-unit-name unit))
1018               (integerp xpon)
1019               (or (< xpon 0)
1020                   (>= xpon (if (eq (car u) 'm) 1 3)))
1021               (let* ((uxpon 0)
1022                      (pref (if (< pow 0)
1023                                (reverse math-unit-prefixes)
1024                              math-unit-prefixes))
1025                      (p pref)
1026                      pxpon pname)
1027                 (or (eq (car u) (nth 1 unit))
1028                     (setq uxpon (* pow
1029                                    (nth 2 (nth 1 (assq
1030                                                   (aref (symbol-name
1031                                                          (nth 1 unit)) 0)
1032                                                   math-unit-prefixes))))))
1033                 (setq xpon (+ xpon uxpon))
1034                 (while (and p
1035                             (or (memq (car (car p)) '(?d ?D ?h ?H))
1036                                 (and (eq (car (car p)) ?c)
1037                                      (not (eq (car u) 'm)))
1038                                 (< xpon (setq pxpon (* (nth 2 (nth 1 (car p)))
1039                                                        pow)))
1040                                 (progn
1041                                   (setq pname (math-build-var-name
1042                                                (if (eq (car (car p)) 0)
1043                                                    (car u)
1044                                                  (concat (char-to-string
1045                                                           (car (car p)))
1046                                                          (symbol-name
1047                                                           (car u))))))
1048                                   (and (/= (car (car p)) 0)
1049                                        (assq (nth 1 pname)
1050                                              math-units-table)))))
1051                   (setq p (cdr p)))
1052                 (and p
1053                      (/= pxpon uxpon)
1054                      (or (not (eq p pref))
1055                          (< xpon (+ pxpon (* (math-abs pow) 3))))
1056                      (progn
1057                        (setcar (cdr math-simplify-expr)
1058                                (let ((calc-prefer-frac nil))
1059                                  (calcFunc-scf (nth 1 math-simplify-expr)
1060                                                (- uxpon pxpon))))
1061                        (setcar unitp pname)
1062                        math-simplify-expr)))))))
1063
1064 (defvar math-try-cancel-units)
1065
1066 (math-defsimplify /
1067   (and math-simplifying-units
1068        (let ((np (cdr math-simplify-expr))
1069              (math-try-cancel-units 0)
1070              n nn)
1071          (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
1072                      (cdr (nth 2 math-simplify-expr))
1073                    (nthcdr 2 math-simplify-expr)))
1074          (if (math-realp (car n))
1075              (progn
1076                (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr)
1077                                             (let ((calc-prefer-frac nil))
1078                                               (math-div 1 (car n)))))
1079                (setcar n 1)))
1080          (while (eq (car-safe (setq n (car np))) '*)
1081            (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr)))
1082            (setq np (cdr (cdr n))))
1083          (math-simplify-units-divisor np (cdr (cdr math-simplify-expr)))
1084          (if (eq math-try-cancel-units 0)
1085              (let* ((math-simplifying-units nil)
1086                     (base (math-simplify
1087                            (math-to-standard-units math-simplify-expr nil))))
1088                (if (Math-numberp base)
1089                    (setq math-simplify-expr base))))
1090          (if (eq (car-safe math-simplify-expr) '/)
1091              (math-simplify-units-prod))
1092          math-simplify-expr)))
1093
1094 (defun math-simplify-units-divisor (np dp)
1095   (let ((n (car np))
1096         d dd temp)
1097     (while (eq (car-safe (setq d (car dp))) '*)
1098       (when (setq temp (math-simplify-units-quotient n (nth 1 d)))
1099         (setcar np (setq n temp))
1100         (setcar (cdr d) 1))
1101       (setq dp (cdr (cdr d))))
1102     (when (setq temp (math-simplify-units-quotient n d))
1103       (setcar np (setq n temp))
1104       (setcar dp 1))))
1105
1106 ;; Simplify, e.g., "in / cm" to "2.54" in a units expression.
1107 (defun math-simplify-units-quotient (n d)
1108   (let ((pow1 1)
1109         (pow2 1))
1110     (when (and (eq (car-safe n) '^)
1111                (integerp (nth 2 n)))
1112       (setq pow1 (nth 2 n) n (nth 1 n)))
1113     (when (and (eq (car-safe d) '^)
1114                (integerp (nth 2 d)))
1115       (setq pow2 (nth 2 d) d (nth 1 d)))
1116     (let ((un (math-check-unit-name n))
1117           (ud (math-check-unit-name d)))
1118       (and un ud
1119            (if (and (equal (nth 4 un) (nth 4 ud))
1120                     (eq pow1 pow2))
1121                (math-to-standard-units (list '/ n d) nil)
1122              (let (ud1)
1123                (setq un (nth 4 un)
1124                      ud (nth 4 ud))
1125                (while un
1126                  (setq ud1 ud)
1127                  (while ud1
1128                    (and (eq (car (car un)) (car (car ud1)))
1129                         (setq math-try-cancel-units
1130                               (+ math-try-cancel-units
1131                                  (- (* (cdr (car un)) pow1)
1132                                     (* (cdr (car ud)) pow2)))))
1133                    (setq ud1 (cdr ud1)))
1134                  (setq un (cdr un)))
1135                nil))))))
1136
1137 (math-defsimplify ^
1138   (and math-simplifying-units
1139        (math-realp (nth 2 math-simplify-expr))
1140        (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1141            (list (car (nth 1 math-simplify-expr))
1142                  (list '^ (nth 1 (nth 1 math-simplify-expr))
1143                        (nth 2 math-simplify-expr))
1144                  (list '^ (nth 2 (nth 1 math-simplify-expr))
1145                        (nth 2 math-simplify-expr)))
1146          (math-simplify-units-pow (nth 1 math-simplify-expr)
1147                                   (nth 2 math-simplify-expr)))))
1148
1149 (math-defsimplify calcFunc-sqrt
1150   (and math-simplifying-units
1151        (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1152            (list (car (nth 1 math-simplify-expr))
1153                  (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
1154                  (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr))))
1155          (math-simplify-units-pow (nth 1 math-simplify-expr) '(frac 1 2)))))
1156
1157 (math-defsimplify (calcFunc-floor
1158                    calcFunc-ceil
1159                    calcFunc-round
1160                    calcFunc-rounde
1161                    calcFunc-roundu
1162                    calcFunc-trunc
1163                    calcFunc-float
1164                    calcFunc-frac
1165                    calcFunc-abs
1166                    calcFunc-clean)
1167   (and math-simplifying-units
1168        (= (length math-simplify-expr) 2)
1169        (if (math-only-units-in-expr-p (nth 1 math-simplify-expr))
1170            (nth 1 math-simplify-expr)
1171          (if (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
1172                   (or (math-only-units-in-expr-p
1173                        (nth 1 (nth 1 math-simplify-expr)))
1174                       (math-only-units-in-expr-p
1175                        (nth 2 (nth 1 math-simplify-expr)))))
1176              (list (car (nth 1 math-simplify-expr))
1177                    (cons (car math-simplify-expr)
1178                          (cons (nth 1 (nth 1 math-simplify-expr))
1179                                (cdr (cdr math-simplify-expr))))
1180                    (cons (car math-simplify-expr)
1181                          (cons (nth 2 (nth 1 math-simplify-expr))
1182                                (cdr (cdr math-simplify-expr)))))))))
1183
1184 (defun math-simplify-units-pow (a pow)
1185   (if (and (eq (car-safe a) '^)
1186            (math-check-unit-name (nth 1 a))
1187            (math-realp (nth 2 a)))
1188       (list '^ (nth 1 a) (math-mul pow (nth 2 a)))
1189     (let* ((u (math-check-unit-name a))
1190            (pf (math-to-simple-fraction pow))
1191            (d (and (eq (car-safe pf) 'frac) (nth 2 pf))))
1192       (and u d
1193            (math-units-are-multiple u d)
1194            (list '^ (math-to-standard-units a nil) pow)))))
1195
1196
1197 (defun math-units-are-multiple (u n)
1198   (setq u (nth 4 u))
1199   (while (and u (= (% (cdr (car u)) n) 0))
1200     (setq u (cdr u)))
1201   (null u))
1202
1203 (math-defsimplify calcFunc-sin
1204   (and math-simplifying-units
1205        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1206        (let ((rad (math-simplify-units
1207                    (math-evaluate-expr
1208                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1209              (calc-angle-mode 'rad))
1210          (and (eq (car-safe rad) '*)
1211               (math-realp (nth 1 rad))
1212               (eq (car-safe (nth 2 rad)) 'var)
1213               (eq (nth 1 (nth 2 rad)) 'rad)
1214               (list 'calcFunc-sin (nth 1 rad))))))
1215
1216 (math-defsimplify calcFunc-cos
1217   (and math-simplifying-units
1218        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1219        (let ((rad (math-simplify-units
1220                    (math-evaluate-expr
1221                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1222              (calc-angle-mode 'rad))
1223          (and (eq (car-safe rad) '*)
1224               (math-realp (nth 1 rad))
1225               (eq (car-safe (nth 2 rad)) 'var)
1226               (eq (nth 1 (nth 2 rad)) 'rad)
1227               (list 'calcFunc-cos (nth 1 rad))))))
1228
1229 (math-defsimplify calcFunc-tan
1230   (and math-simplifying-units
1231        (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
1232        (let ((rad (math-simplify-units
1233                    (math-evaluate-expr
1234                     (math-to-standard-units (nth 1 math-simplify-expr) nil))))
1235              (calc-angle-mode 'rad))
1236          (and (eq (car-safe rad) '*)
1237               (math-realp (nth 1 rad))
1238               (eq (car-safe (nth 2 rad)) 'var)
1239               (eq (nth 1 (nth 2 rad)) 'rad)
1240               (list 'calcFunc-tan (nth 1 rad))))))
1241
1242
1243 (defun math-remove-units (expr)
1244   (if (math-check-unit-name expr)
1245       1
1246     (if (Math-primp expr)
1247         expr
1248       (cons (car expr)
1249             (mapcar 'math-remove-units (cdr expr))))))
1250
1251 (defun math-extract-units (expr)
1252   (if (memq (car-safe expr) '(* /))
1253       (cons (car expr)
1254             (mapcar 'math-extract-units (cdr expr)))
1255     (if (math-check-unit-name expr) expr 1)))
1256
1257 (defun math-build-units-table-buffer (enter-buffer)
1258   (if (not (and math-units-table math-units-table-buffer-valid
1259                 (get-buffer "*Units Table*")))
1260       (let ((buf (get-buffer-create "*Units Table*"))
1261             (uptr (math-build-units-table))
1262             (calc-language (if (eq calc-language 'big) nil calc-language))
1263             (calc-float-format '(float 0))
1264             (calc-group-digits nil)
1265             (calc-number-radix 10)
1266             (calc-point-char ".")
1267             (std nil)
1268             u name shadowed)
1269         (save-excursion
1270           (message "Formatting units table...")
1271           (set-buffer buf)
1272           (setq buffer-read-only nil)
1273           (erase-buffer)
1274           (insert "Calculator Units Table:\n\n")
1275           (insert "Unit    Type  Definition                  Description\n\n")
1276           (while uptr
1277             (setq u (car uptr)
1278                   name (nth 2 u))
1279             (when (eq (car u) 'm)
1280               (setq std t))
1281             (setq shadowed (and std (assq (car u) math-additional-units)))
1282             (when (and name
1283                        (> (length name) 1)
1284                        (eq (aref name 0) ?\*))
1285               (unless (eq uptr math-units-table)
1286                 (insert "\n"))
1287               (setq name (substring name 1)))
1288             (insert " ")
1289             (and shadowed (insert "("))
1290             (insert (symbol-name (car u)))
1291             (and shadowed (insert ")"))
1292             (if (nth 3 u)
1293                 (progn
1294                   (indent-to 10)
1295                   (insert (symbol-name (nth 3 u))))
1296               (or std
1297                   (progn
1298                     (indent-to 10)
1299                     (insert "U"))))
1300             (indent-to 14)
1301             (and shadowed (insert "("))
1302             (if (nth 1 u)
1303                 (insert (math-format-value (nth 1 u) 80))
1304               (insert (symbol-name (car u))))
1305             (and shadowed (insert ")"))
1306             (indent-to 41)
1307             (insert " ")
1308             (when name
1309               (insert name))
1310             (if shadowed
1311                 (insert " (redefined above)")
1312               (unless (nth 1 u)
1313                 (insert " (base unit)")))
1314             (insert "\n")
1315             (setq uptr (cdr uptr)))
1316           (insert "\n\nUnit Prefix Table:\n\n")
1317           (setq uptr math-unit-prefixes)
1318           (while uptr
1319             (setq u (car uptr))
1320             (insert " " (char-to-string (car u)))
1321             (if (equal (nth 1 u) (nth 1 (nth 1 uptr)))
1322                 (insert " " (char-to-string (car (car (setq uptr (cdr uptr)))))
1323                         "   ")
1324               (insert "     "))
1325             (insert "10^" (int-to-string (nth 2 (nth 1 u))))
1326             (indent-to 15)
1327             (insert "   " (nth 2 u) "\n")
1328             (while (eq (car (car (setq uptr (cdr uptr)))) 0)))
1329           (insert "\n")
1330           (setq buffer-read-only t)
1331           (message "Formatting units table...done"))
1332         (setq math-units-table-buffer-valid t)
1333         (let ((oldbuf (current-buffer)))
1334           (set-buffer buf)
1335           (goto-char (point-min))
1336           (set-buffer oldbuf))
1337         (if enter-buffer
1338             (pop-to-buffer buf)
1339           (display-buffer buf)))
1340     (if enter-buffer
1341         (pop-to-buffer (get-buffer "*Units Table*"))
1342       (display-buffer (get-buffer "*Units Table*")))))
1343
1344 (provide 'calc-units)
1345
1346 ;; Local Variables:
1347 ;; coding: iso-latin-1
1348 ;; End:
1349
1350 ;;; arch-tag: e993314f-3adc-4191-be61-4ef8874881c4
1351 ;;; calc-units.el ends here