cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-units.el

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