home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / calc-2.02d-bin.lha / lib / emacs / site-lisp / calc-units.el < prev    next >
Encoding:
Text File  |  1996-10-12  |  41.8 KB  |  1,353 lines
  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.  
  394. (defvar math-standard-units
  395.   '( ;; Length
  396.      ( m       nil             "*Meter" )
  397.      ( in      "2.54 cm"             "Inch" )
  398.      ( ft      "12 in"             "Foot" )
  399.      ( yd      "3 ft"             "Yard" )
  400.      ( mi      "5280 ft"         "Mile" )
  401.      ( au      "1.495979e11 m"       "Astronomical Unit" )
  402.      ( lyr     "9460536207068016 m"  "Light Year" )
  403.      ( pc      "206264.80625 au"     "Parsec" )
  404.      ( nmi     "1852 m"             "Nautical Mile" )
  405.      ( fath    "6 ft"             "Fathom" )
  406.      ( u       "1 um"             "Micron" )
  407.      ( mil     "in/1000"         "Mil" )
  408.      ( point   "in/72"             "Point (1/72 inch)" )
  409.      ( tpt     "in/72.27"         "Point (TeX conventions)" )
  410.      ( Ang     "1e-10 m"         "Angstrom" )
  411.      ( mfi     "mi+ft+in"         "Miles + feet + inches" )
  412.      
  413.      ;; Area
  414.      ( hect    "10000 m^2"         "*Hectare" )
  415.      ( acre    "mi^2 / 640"         "Acre" )
  416.      ( b       "1e-28 m^2"         "Barn" )
  417.      
  418.      ;; Volume
  419.      ( l       "1e-3 m^3"         "*Liter" )
  420.      ( L       "1e-3 m^3"         "Liter" )
  421.      ( gal     "4 qt"             "US Gallon" )
  422.      ( qt      "2 pt"             "Quart" )
  423.      ( pt      "2 cup"             "Pint" )
  424.      ( cup     "8 ozfl"             "Cup" )
  425.      ( ozfl    "2 tbsp"             "Fluid Ounce" )
  426.      ( floz    "2 tbsp"             "Fluid Ounce" )
  427.      ( tbsp    "3 tsp"             "Tablespoon" )
  428.      ( tsp     "4.92892159375 ml"    "Teaspoon" )
  429.      ( vol     "tsp+tbsp+ozfl+cup+pt+qt+gal" "Gallons + ... + teaspoons" )
  430.      ( galC    "4.54609 l"         "Canadian Gallon" )
  431.      ( galUK   "4.546092 l"         "UK Gallon" )
  432.      
  433.      ;; Time
  434.      ( s       nil             "*Second" )
  435.      ( sec     "s"             "Second" )
  436.      ( min     "60 s"             "Minute" )
  437.      ( hr      "60 min"             "Hour" )
  438.      ( day     "24 hr"             "Day" )
  439.      ( wk      "7 day"             "Week" )
  440.      ( hms     "wk+day+hr+min+s"     "Hours, minutes, seconds" )
  441.      ( yr      "365.25 day"         "Year" )
  442.      ( Hz      "1/s"             "Hertz" )
  443.  
  444.      ;; Speed
  445.      ( mph     "mi/hr"             "*Miles per hour" )
  446.      ( kph     "km/hr"             "Kilometers per hour" )
  447.      ( knot    "nmi/hr"             "Knot" )
  448.      ( c       "2.99792458e8 m/s"    "Speed of light" )     
  449.      
  450.      ;; Acceleration
  451.      ( ga      "9.80665 m/s^2"         "*\"g\" acceleration" )
  452.  
  453.      ;; Mass
  454.      ( g       nil                   "*Gram" )
  455.      ( lb      "16 oz"             "Pound (mass)" )
  456.      ( oz      "28.349523125 g"         "Ounce (mass)" )
  457.      ( ton     "2000 lb"         "Ton" )
  458.      ( tpo     "ton+lb+oz"         "Tons + pounds + ounces (mass)" )
  459.      ( t       "1000 kg"         "Metric ton" )
  460.      ( tonUK   "1016.0469088 kg"     "UK ton" )
  461.      ( lbt     "12 ozt"             "Troy pound" )
  462.      ( ozt     "31.103475 g"         "Troy ounce" )
  463.      ( ct      ".2 g"             "Carat" )
  464.      ( amu     "1.6605402e-24 g"     "Unified atomic mass" )
  465.  
  466.      ;; Force
  467.      ( N       "m kg/s^2"         "*Newton" )
  468.      ( dyn     "1e-5 N"             "Dyne" )
  469.      ( gf      "ga g"             "Gram (force)" )
  470.      ( lbf     "4.44822161526 N"     "Pound (force)" )
  471.      ( kip     "1000 lbf"         "Kilopound (force)" )
  472.      ( pdl     "0.138255 N"         "Poundal" )
  473.  
  474.      ;; Energy
  475.      ( J       "N m"             "*Joule" )
  476.      ( erg     "1e-7 J"             "Erg" )
  477.      ( cal     "4.1868 J"         "International Table Calorie" )
  478.      ( Btu     "1055.05585262 J"     "International Table Btu" )
  479.      ( eV      "ech V"               "Electron volt" )
  480.      ( ev      "eV"                  "Electron volt" )
  481.      ( therm   "105506000 J"         "EEC therm" )
  482.      ( invcm   "h c/cm"               "Energy in inverse centimeters" )
  483.      ( Kayser  "invcm"             "Kayser (inverse centimeter energy)" )
  484.      ( men     "100/invcm"         "Inverse energy in meters" )
  485.      ( Hzen    "h Hz"             "Energy in Hertz")
  486.      ( Ken     "k K"             "Energy in Kelvins")
  487.      ;; ( invcm   "eV / 8065.47835185"    "Energy in inverse centimeters" )
  488.      ;; ( Hzen    "eV / 2.41796958004e14" "Energy in Hertz")
  489.      ;; ( Ken     "eV / 11604.7967327"    "Energy in Kelvins")
  490.  
  491.      ;; Power
  492.      ( W       "J/s"             "*Watt" )
  493.      ( hp      "745.7 W"         "Horsepower" )
  494.  
  495.      ;; Temperature
  496.      ( K       nil                   "*Degree Kelvin"     K )
  497.      ( dK      "K"             "Degree Kelvin"      K )
  498.      ( degK    "K"             "Degree Kelvin"      K )
  499.      ( dC      "K"             "Degree Celsius"      C )
  500.      ( degC    "K"               "Degree Celsius"      C )
  501.      ( dF      "(5/9) K"         "Degree Fahrenheit"  F )
  502.      ( degF    "(5/9) K"         "Degree Fahrenheit"  F )
  503.  
  504.      ;; Pressure
  505.      ( Pa      "N/m^2"             "*Pascal" )
  506.      ( bar     "1e5 Pa"             "Bar" )
  507.      ( atm     "101325 Pa"         "Standard atmosphere" )
  508.      ( torr    "atm/760"         "Torr" )
  509.      ( mHg     "1000 torr"         "Meter of mercury" )
  510.      ( inHg    "25.4 mmHg"         "Inch of mercury" )
  511.      ( inH2O   "248.84 Pa"         "Inch of water" )
  512.      ( psi     "6894.75729317 Pa"    "Pound per square inch" )
  513.  
  514.      ;; Viscosity
  515.      ( P       "0.1 Pa s"         "*Poise" )
  516.      ( St      "1e-4 m^2/s"         "Stokes" )
  517.  
  518.      ;; Electromagnetism
  519.      ( A       nil                   "*Ampere" )
  520.      ( C       "A s"             "Coulomb" )
  521.      ( Fdy     "ech Nav"           "Faraday" )
  522.      ( e       "1.60217733e-19 C"    "Elementary charge" )
  523.      ( ech     "1.60217733e-19 C"    "Elementary charge" )
  524.      ( V       "W/A"             "Volt" )
  525.      ( ohm     "V/A"             "Ohm" )
  526.      ( mho     "A/V"             "Mho" )
  527.      ( S       "A/V"             "Siemens" )
  528.      ( F       "C/V"             "Farad" )
  529.      ( H       "Wb/A"             "Henry" )
  530.      ( T       "Wb/m^2"             "Tesla" )
  531.      ( G       "1e-4 T"             "Gauss" )
  532.      ( Wb      "V s"             "Weber" )
  533.  
  534.      ;; Luminous intensity
  535.      ( cd      nil                   "*Candela" )
  536.      ( sb      "1e4 cd/m^2"         "Stilb" )
  537.      ( lm      "cd sr"             "Lumen" )
  538.      ( lx      "lm/m^2"             "Lux" )
  539.      ( ph      "1e4 lx"             "Phot" )
  540.      ( fc      "10.76 lx"         "Footcandle" )
  541.      ( lam     "1e4 lm/m^2"         "Lambert" )
  542.      ( flam    "1.07639104e-3 lam"   "Footlambert" )
  543.  
  544.      ;; Radioactivity
  545.      ( Bq      "1/s"               "*Becquerel" )
  546.      ( Ci      "3.7e10 Bq"         "Curie" )
  547.      ( Gy      "J/kg"             "Gray" )
  548.      ( Sv      "Gy"             "Sievert" )
  549.      ( R       "2.58e-4 C/kg"         "Roentgen" )
  550.      ( rd      ".01 Gy"             "Rad" )
  551.      ( rem     "rd"             "Rem" )
  552.  
  553.      ;; Amount of substance
  554.      ( mol     nil                   "*Mole" )
  555.  
  556.      ;; Plane angle
  557.      ( rad     nil                   "*Radian" )
  558.      ( circ    "2 pi rad"         "Full circle" )
  559.      ( rev     "circ"             "Full revolution" )
  560.      ( deg     "circ/360"            "Degree" )
  561.      ( arcmin  "deg/60"             "Arc minute" )
  562.      ( arcsec  "arcmin/60"         "Arc second" )
  563.      ( grad    "circ/400"            "Grade" )
  564.      ( rpm     "rev/min"         "Revolutions per minute" )
  565.  
  566.      ;; Solid angle
  567.      ( sr      nil             "*Steradian" )
  568.  
  569.      ;; Other physical quantities (Physics Letters B239, 1 (1990))
  570.      ( h       "6.6260755e-34 J s"   "*Planck's constant" )
  571.      ( hbar    "h / 2 pi"         "Planck's constant" )
  572.      ( mu0     "4 pi 1e-7 H/m"       "Permeability of vacuum" )
  573.      ( Grav    "6.67259e-11 N m^2/kg^2"  "Gravitational constant" )
  574.      ( Nav     "6.0221367e23 / mol"  "Avagadro's constant" )
  575.      ( me      "0.51099906 MeV/c^2"  "Electron rest mass" )
  576.      ( mp      "1.007276470 amu"     "Proton rest mass" )
  577.      ( mn      "1.008664904 amu"     "Neutron rest mass" )
  578.      ( mu      "0.113428913 amu"     "Muon rest mass" )
  579.      ( Ryd     "1.0973731571e5 invcm" "Rydberg's constant" )
  580.      ( k       "1.3806513e-23 J/K"   "Boltzmann's constant" )
  581.      ( fsc     "1 / 137.0359895"     "Fine structure constant" )
  582.      ( muB     "5.78838263e-11 MeV/T"  "Bohr magneton" )
  583.      ( muN     "3.15245166e-14 MeV/T"  "Nuclear magneton" )
  584.      ( mue     "1.001159652193 muB"  "Electron magnetic moment" )
  585.      ( mup     "2.792847386 muN"     "Proton magnetic moment" )
  586.      ( R0      "Nav k"               "Molar gas constant" )
  587.      ( V0      "22.413992 L/mol"     "Standard volume of ideal gas" )
  588. ))
  589.  
  590.  
  591. (defvar math-additional-units nil
  592.   "*Additional units table for user-defined units.
  593. Must be formatted like math-standard-units.
  594. If this is changed, be sure to set math-units-table to nil to ensure
  595. that the combined units table will be rebuilt.")
  596.  
  597. (defvar math-unit-prefixes
  598.   '( ( ?E  (float 1 18)  "Exa"    )
  599.      ( ?P  (float 1 15)  "Peta"   )
  600.      ( ?T  (float 1 12)  "Tera"      )
  601.      ( ?G  (float 1 9)   "Giga"      )
  602.      ( ?M  (float 1 6)   "Mega"      )
  603.      ( ?k  (float 1 3)   "Kilo"      )
  604.      ( ?K  (float 1 3)   "Kilo"      )
  605.      ( ?h  (float 1 2)   "Hecto"  )
  606.      ( ?H  (float 1 2)   "Hecto"  )
  607.      ( ?D  (float 1 1)   "Deka"      )
  608.      ( 0   (float 1 0)   nil      )
  609.      ( ?d  (float 1 -1)  "Deci"      )
  610.      ( ?c  (float 1 -2)  "Centi"  )
  611.      ( ?m  (float 1 -3)  "Milli"  )
  612.      ( ?u  (float 1 -6)  "Micro"  )
  613.      ( ?n  (float 1 -9)  "Nano"      )
  614.      ( ?p  (float 1 -12) "Pico"      )
  615.      ( ?f  (float 1 -15) "Femto"  )
  616.      ( ?a  (float 1 -18) "Atto"   )
  617. ))
  618.  
  619. (defvar math-standard-units-systems
  620.   '( ( base  nil )
  621.      ( si    ( ( g   '(* (var kg var-kg) (float 1 -3)) ) ) )
  622.      ( mks   ( ( g   '(* (var kg var-kg) (float 1 -3)) ) ) )
  623.      ( cgs   ( ( m   '(* (var cm var-cm) 100         ) ) ) )
  624. ))
  625.  
  626. (defvar math-units-table nil
  627.   "Internal units table derived from math-defined-units.
  628. Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).")
  629.  
  630. (defvar math-units-table-buffer-valid nil)
  631.  
  632.  
  633. (defun math-build-units-table ()
  634.   (or math-units-table
  635.       (let* ((combined-units (append math-additional-units
  636.                      math-standard-units))
  637.          (unit-list (mapcar 'car combined-units))
  638.          tab)
  639.     (message "Building units table...")
  640.     (setq math-units-table-buffer-valid nil)
  641.     (setq tab (mapcar (function
  642.                (lambda (x)
  643.                  (list (car x)
  644.                    (and (nth 1 x)
  645.                     (if (stringp (nth 1 x))
  646.                         (let ((exp (math-read-plain-expr
  647.                             (nth 1 x))))
  648.                           (if (eq (car-safe exp) 'error)
  649.                           (error "Format error in definition of %s in units table: %s"
  650.                              (car x) (nth 2 exp))
  651.                         exp))
  652.                       (nth 1 x)))
  653.                    (nth 2 x)
  654.                    (nth 3 x)
  655.                    (and (not (nth 1 x))
  656.                     (list (cons (car x) 1))))))
  657.               combined-units))
  658.     (let ((math-units-table tab))
  659.       (mapcar 'math-find-base-units tab))
  660.     (message "Building units table...done")
  661.     (setq math-units-table tab)))
  662. )
  663.  
  664. (defun math-find-base-units (entry)
  665.   (if (eq (nth 4 entry) 'boom)
  666.       (error "Circular definition involving unit %s" (car entry)))
  667.   (or (nth 4 entry)
  668.       (let (base)
  669.     (setcar (nthcdr 4 entry) 'boom)
  670.     (math-find-base-units-rec (nth 1 entry) 1)
  671.     '(or base
  672.         (error "Dimensionless definition for unit %s" (car entry)))
  673.     (while (eq (cdr (car base)) 0)
  674.       (setq base (cdr base)))
  675.     (let ((b base))
  676.       (while (cdr b)
  677.         (if (eq (cdr (car (cdr b))) 0)
  678.         (setcdr b (cdr (cdr b)))
  679.           (setq b (cdr b)))))
  680.     (setq base (sort base 'math-compare-unit-names))
  681.     (setcar (nthcdr 4 entry) base)
  682.     base))
  683. )
  684.  
  685. (defun math-compare-unit-names (a b)
  686.   (memq (car b) (cdr (memq (car a) unit-list)))
  687. )
  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)) base)))
  696.          (if old
  697.              (setcdr old (+ (cdr old) p))
  698.            (setq base (cons (cons (car (car ulist)) p) base))))
  699.            (setq ulist (cdr ulist)))))
  700.       ((math-scalarp expr))
  701.       ((and (eq (car expr) '^)
  702.         (integerp (nth 2 expr)))
  703.        (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr))))
  704.       ((eq (car expr) '*)
  705.        (math-find-base-units-rec (nth 1 expr) pow)
  706.        (math-find-base-units-rec (nth 2 expr) pow))
  707.       ((eq (car expr) '/)
  708.        (math-find-base-units-rec (nth 1 expr) pow)
  709.        (math-find-base-units-rec (nth 2 expr) (- pow)))
  710.       ((eq (car expr) 'neg)
  711.        (math-find-base-units-rec (nth 1 expr) pow))
  712.       ((eq (car expr) '+)
  713.        (math-find-base-units-rec (nth 1 expr) pow))
  714.       ((eq (car expr) 'var)
  715.        (or (eq (nth 1 expr) 'pi)
  716.            (error "Unknown name %s in defining expression for unit %s"
  717.               (nth 1 expr) (car entry))))
  718.       (t (error "Malformed defining expression for unit %s" (car entry)))))
  719. )
  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.  
  732. (defun math-only-units-in-expr-p (expr)
  733.   (and (consp expr)
  734.        (if (eq (car expr) 'var)
  735.        (math-check-unit-name expr)
  736.      (if (memq (car expr) '(* /))
  737.          (and (math-only-units-in-expr-p (nth 1 expr))
  738.           (math-only-units-in-expr-p (nth 2 expr)))
  739.        (and (eq (car expr) '^)
  740.         (and (math-only-units-in-expr-p (nth 1 expr))
  741.              (math-realp (nth 2 expr)))))))
  742. )
  743.  
  744. (defun math-single-units-in-expr-p (expr)
  745.   (cond ((math-scalarp expr) nil)
  746.     ((eq (car expr) 'var)
  747.      (math-check-unit-name expr))
  748.     ((eq (car expr) '*)
  749.      (let ((u1 (math-single-units-in-expr-p (nth 1 expr)))
  750.            (u2 (math-single-units-in-expr-p (nth 2 expr))))
  751.        (or (and u1 u2 'wrong)
  752.            u1
  753.            u2)))
  754.     ((eq (car expr) '/)
  755.      (if (math-units-in-expr-p (nth 2 expr) nil)
  756.          'wrong
  757.        (math-single-units-in-expr-p (nth 1 expr))))
  758.     (t 'wrong))
  759. )
  760.  
  761. (defun math-check-unit-name (v)
  762.   (and (eq (car-safe v) 'var)
  763.        (or (assq (nth 1 v) (or math-units-table (math-build-units-table)))
  764.        (let ((name (symbol-name (nth 1 v))))
  765.          (and (> (length name) 1)
  766.           (assq (aref name 0) math-unit-prefixes)
  767.           (or (assq (intern (substring name 1)) math-units-table)
  768.               (and (eq (aref name 0) ?M)
  769.                (> (length name) 3)
  770.                (eq (aref name 1) ?e)
  771.                (eq (aref name 2) ?g)
  772.                (assq (intern (substring name 3))
  773.                  math-units-table)))))))
  774. )
  775.  
  776.  
  777. (defun math-to-standard-units (expr which-standard)
  778.   (math-to-standard-rec expr)
  779. )
  780.  
  781. (defun math-to-standard-rec (expr)
  782.   (if (eq (car-safe expr) 'var)
  783.       (let ((u (math-check-unit-name expr))
  784.         (base (nth 1 expr)))
  785.     (if u
  786.         (progn
  787.           (if (nth 1 u)
  788.           (setq expr (math-to-standard-rec (nth 1 u)))
  789.         (let ((st (assq (car u) which-standard)))
  790.           (if st
  791.               (setq expr (nth 1 st))
  792.             (setq expr (list 'var (car u)
  793.                      (intern (concat "var-"
  794.                              (symbol-name
  795.                               (car u)))))))))
  796.           (or (null u)
  797.           (eq base (car u))
  798.           (setq expr (list '*
  799.                    (nth 1 (assq (aref (symbol-name base) 0)
  800.                         math-unit-prefixes))
  801.                    expr)))
  802.           expr)
  803.       (if (eq base 'pi)
  804.           (math-pi)
  805.         expr)))
  806.     (if (Math-primp expr)
  807.     expr
  808.       (cons (car expr)
  809.         (mapcar 'math-to-standard-rec (cdr expr)))))
  810. )
  811.  
  812. (defun math-apply-units (expr units ulist &optional pure)
  813.   (if ulist
  814.       (let ((new 0)
  815.         value)
  816.     (setq expr (math-simplify-units expr))
  817.     (or (math-numberp expr)
  818.         (error "Incompatible units"))
  819.     (while (cdr ulist)
  820.       (setq value (math-div expr (nth 1 (car ulist)))
  821.         value (math-floor (let ((calc-internal-prec
  822.                      (1- calc-internal-prec)))
  823.                     (math-normalize value)))
  824.         new (math-add new (math-mul value (car (car ulist))))
  825.         expr (math-sub expr (math-mul value (nth 1 (car ulist))))
  826.         ulist (cdr ulist)))
  827.     (math-add new (math-mul (math-div expr (nth 1 (car ulist)))
  828.                 (car (car ulist)))))
  829.     (math-simplify-units (if pure
  830.                  expr
  831.                (list '* expr units))))
  832. )
  833.  
  834. (defun math-decompose-units (units)
  835.   (let ((u (math-check-unit-name units)))
  836.     (and u (eq (car-safe (nth 1 u)) '+)
  837.      (setq units (nth 1 u))))
  838.   (setq units (calcFunc-expand units))
  839.   (and (eq (car-safe units) '+)
  840.        (let ((entry (list units calc-internal-prec calc-prefer-frac)))
  841.      (or (equal entry (car math-decompose-units-cache))
  842.          (let ((ulist nil)
  843.            (utemp units)
  844.            qty unit)
  845.            (while (eq (car-safe utemp) '+)
  846.          (setq ulist (cons (math-decompose-unit-part (nth 2 utemp))
  847.                    ulist)
  848.                utemp (nth 1 utemp)))
  849.            (setq ulist (cons (math-decompose-unit-part utemp) ulist)
  850.              utemp ulist)
  851.            (while (setq utemp (cdr utemp))
  852.          (or (equal (nth 2 (car utemp)) (nth 2 (car ulist)))
  853.              (error "Inconsistent units in sum")))
  854.            (setq math-decompose-units-cache
  855.              (cons entry
  856.                (sort ulist
  857.                  (function
  858.                   (lambda (x y)
  859.                     (not (Math-lessp (nth 1 x)
  860.                              (nth 1 y))))))))))
  861.      (cdr math-decompose-units-cache)))
  862. )
  863. (setq math-decompose-units-cache nil)
  864.  
  865. (defun math-decompose-unit-part (unit)
  866.   (cons unit
  867.     (math-is-multiple (math-simplify-units (math-to-standard-units
  868.                         unit nil))
  869.               t))
  870. )
  871.  
  872. (defun math-find-compatible-unit (expr unit)
  873.   (let ((u (math-check-unit-name unit)))
  874.     (if u
  875.     (math-find-compatible-unit-rec expr 1)))
  876. )
  877.  
  878. (defun math-find-compatible-unit-rec (expr pow)
  879.   (cond ((eq (car-safe expr) '*)
  880.      (or (math-find-compatible-unit-rec (nth 1 expr) pow)
  881.          (math-find-compatible-unit-rec (nth 2 expr) pow)))
  882.     ((eq (car-safe expr) '/)
  883.      (or (math-find-compatible-unit-rec (nth 1 expr) pow)
  884.          (math-find-compatible-unit-rec (nth 2 expr) (- pow))))
  885.     ((and (eq (car-safe expr) '^)
  886.           (integerp (nth 2 expr)))
  887.      (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr))))
  888.     (t
  889.      (let ((u2 (math-check-unit-name expr)))
  890.        (if (equal (nth 4 u) (nth 4 u2))
  891.            (cons expr pow)))))
  892. )
  893.  
  894. (defun math-convert-units (expr new-units &optional pure)
  895.   (math-with-extra-prec 2
  896.     (let ((compat (and (not pure) (math-find-compatible-unit expr new-units)))
  897.       (unit-list nil)
  898.       (math-combining-units nil))
  899.       (if compat
  900.       (math-simplify-units
  901.        (math-mul (math-mul (math-simplify-units
  902.                 (math-div expr (math-pow (car compat)
  903.                              (cdr compat))))
  904.                    (math-pow new-units (cdr compat)))
  905.              (math-simplify-units
  906.               (math-to-standard-units
  907.                (math-pow (math-div (car compat) new-units)
  908.                  (cdr compat))
  909.                nil))))
  910.     (if (setq unit-list (math-decompose-units new-units))
  911.         (setq new-units (nth 2 (car unit-list))))
  912.     (if (eq (car-safe expr) '+)
  913.         (setq expr (math-simplify-units expr)))
  914.     (if (math-units-in-expr-p expr t)
  915.         (math-convert-units-rec expr)
  916.       (math-apply-units (math-to-standard-units
  917.                  (list '/ expr new-units) nil)
  918.                 new-units unit-list pure)))))
  919. )
  920.  
  921. (defun math-convert-units-rec (expr)
  922.   (if (math-units-in-expr-p expr nil)
  923.       (math-apply-units (math-to-standard-units (list '/ expr new-units) nil)
  924.             new-units unit-list pure)
  925.     (if (Math-primp expr)
  926.     expr
  927.       (cons (car expr)
  928.         (mapcar 'math-convert-units-rec (cdr expr)))))
  929. )
  930.  
  931. (defun math-convert-temperature (expr old new &optional pure)
  932.   (let* ((units (math-single-units-in-expr-p expr))
  933.      (uold (if old
  934.            (if (or (null units)
  935.                (equal (nth 1 old) (car units)))
  936.                (math-check-unit-name old)
  937.              (error "Inconsistent temperature units"))
  938.          units))
  939.      (unew (math-check-unit-name new)))
  940.     (or (and (consp unew) (nth 3 unew))
  941.     (error "Not a valid temperature unit"))
  942.     (or (and (consp uold) (nth 3 uold))
  943.     (error "Not a pure temperature expression"))
  944.     (let ((v (car uold)))
  945.       (setq expr (list '/ expr (list 'var v
  946.                      (intern (concat "var-"
  947.                              (symbol-name v)))))))
  948.     (or (eq (nth 3 uold) (nth 3 unew))
  949.     (cond ((eq (nth 3 uold) 'K)
  950.            (setq expr (list '- expr '(float 27315 -2)))
  951.            (if (eq (nth 3 unew) 'F)
  952.            (setq expr (list '+ (list '* expr '(frac 9 5)) 32))))
  953.           ((eq (nth 3 uold) 'C)
  954.            (if (eq (nth 3 unew) 'F)
  955.            (setq expr (list '+ (list '* expr '(frac 9 5)) 32))
  956.          (setq expr (list '+ expr '(float 27315 -2)))))
  957.           (t
  958.            (setq expr (list '* (list '- expr 32) '(frac 5 9)))
  959.            (if (eq (nth 3 unew) 'K)
  960.            (setq expr (list '+ expr '(float 27315 -2)))))))
  961.     (if pure
  962.     expr
  963.       (list '* expr new)))
  964. )
  965.  
  966.  
  967.  
  968. (defun math-simplify-units (a)
  969.   (let ((math-simplifying-units t)
  970.     (calc-matrix-mode 'scalar))
  971.     (math-simplify a))
  972. )
  973. (fset 'calcFunc-usimplify (symbol-function 'math-simplify-units))
  974.  
  975. (math-defsimplify (+ -)
  976.   (and math-simplifying-units
  977.        (math-units-in-expr-p (nth 1 expr) nil)
  978.        (let* ((units (math-extract-units (nth 1 expr)))
  979.           (ratio (math-simplify (math-to-standard-units
  980.                      (list '/ (nth 2 expr) units) nil))))
  981.      (if (math-units-in-expr-p ratio nil)
  982.          (progn
  983.            (calc-record-why "*Inconsistent units" expr)
  984.            expr)
  985.        (list '* (math-add (math-remove-units (nth 1 expr))
  986.                   (if (eq (car expr) '-) (math-neg ratio) ratio))
  987.          units))))
  988. )
  989.  
  990. (math-defsimplify *
  991.   (math-simplify-units-prod)
  992. )
  993.  
  994. (defun math-simplify-units-prod ()
  995.   (and math-simplifying-units
  996.        calc-autorange-units
  997.        (Math-realp (nth 1 expr))
  998.        (let* ((num (math-float (nth 1 expr)))
  999.           (xpon (calcFunc-xpon num))
  1000.           (unitp (cdr (cdr expr)))
  1001.           (unit (car unitp))
  1002.           (pow (if (eq (car expr) '*) 1 -1))
  1003.           u)
  1004.      (and (eq (car-safe unit) '*)
  1005.           (setq unitp (cdr unit)
  1006.             unit (car unitp)))
  1007.      (and (eq (car-safe unit) '^)
  1008.           (integerp (nth 2 unit))
  1009.           (setq pow (* pow (nth 2 unit))
  1010.             unitp (cdr unit)
  1011.             unit (car unitp)))
  1012.      (and (setq u (math-check-unit-name unit))
  1013.           (integerp xpon)
  1014.           (or (< xpon 0)
  1015.           (>= xpon (if (eq (car u) 'm) 1 3)))
  1016.           (let* ((uxpon 0)
  1017.              (pref (if (< pow 0)
  1018.                    (reverse math-unit-prefixes)
  1019.                  math-unit-prefixes))
  1020.              (p pref)
  1021.              pxpon pname)
  1022.         (or (eq (car u) (nth 1 unit))
  1023.             (setq uxpon (* pow
  1024.                    (nth 2 (nth 1 (assq
  1025.                           (aref (symbol-name
  1026.                              (nth 1 unit)) 0)
  1027.                           math-unit-prefixes))))))
  1028.         (setq xpon (+ xpon uxpon))
  1029.         (while (and p
  1030.                 (or (memq (car (car p)) '(?d ?D ?h ?H))
  1031.                 (and (eq (car (car p)) ?c)
  1032.                      (not (eq (car u) 'm)))
  1033.                 (< xpon (setq pxpon (* (nth 2 (nth 1 (car p)))
  1034.                                pow)))
  1035.                 (progn
  1036.                   (setq pname (math-build-var-name
  1037.                            (if (eq (car (car p)) 0)
  1038.                            (car u)
  1039.                          (concat (char-to-string
  1040.                               (car (car p)))
  1041.                              (symbol-name
  1042.                               (car u))))))
  1043.                   (and (/= (car (car p)) 0)
  1044.                        (assq (nth 1 pname)
  1045.                          math-units-table)))))
  1046.           (setq p (cdr p)))
  1047.         (and p
  1048.              (/= pxpon uxpon)
  1049.              (or (not (eq p pref))
  1050.              (< xpon (+ pxpon (* (math-abs pow) 3))))
  1051.              (progn
  1052.                (setcar (cdr expr)
  1053.                    (let ((calc-prefer-frac nil))
  1054.                  (calcFunc-scf (nth 1 expr)
  1055.                            (- uxpon pxpon))))
  1056.                (setcar unitp pname)
  1057.                expr))))))
  1058. )
  1059.  
  1060. (math-defsimplify /
  1061.   (and math-simplifying-units
  1062.        (let ((np (cdr expr))
  1063.          (try-cancel-units 0)
  1064.          n nn)
  1065.      (setq n (if (eq (car-safe (nth 2 expr)) '*)
  1066.              (cdr (nth 2 expr))
  1067.            (nthcdr 2 expr)))
  1068.      (if (math-realp (car n))
  1069.          (progn
  1070.            (setcar (cdr expr) (math-mul (nth 1 expr)
  1071.                         (let ((calc-prefer-frac nil))
  1072.                           (math-div 1 (car n)))))
  1073.            (setcar n 1)))
  1074.      (while (eq (car-safe (setq n (car np))) '*)
  1075.        (math-simplify-units-divisor (cdr n) (cdr (cdr expr)))
  1076.        (setq np (cdr (cdr n))))
  1077.      (math-simplify-units-divisor np (cdr (cdr expr)))
  1078.      (if (eq try-cancel-units 0)
  1079.          (let* ((math-simplifying-units nil)
  1080.             (base (math-simplify (math-to-standard-units expr nil))))
  1081.            (if (Math-numberp base)
  1082.            (setq expr base))))
  1083.      (if (eq (car-safe expr) '/)
  1084.          (math-simplify-units-prod))
  1085.      expr))
  1086. )
  1087.  
  1088. (defun math-simplify-units-divisor (np dp)
  1089.   (let ((n (car np))
  1090.     d dd temp)
  1091.     (while (eq (car-safe (setq d (car dp))) '*)
  1092.       (if (setq temp (math-simplify-units-quotient n (nth 1 d)))
  1093.       (progn
  1094.         (setcar np (setq n temp))
  1095.         (setcar (cdr d) 1)))
  1096.       (setq dp (cdr (cdr d))))
  1097.     (if (setq temp (math-simplify-units-quotient n d))
  1098.     (progn
  1099.       (setcar np (setq n temp))
  1100.       (setcar dp 1))))
  1101. )
  1102.  
  1103. ;; Simplify, e.g., "in / cm" to "2.54" in a units expression.
  1104. (defun math-simplify-units-quotient (n d)
  1105.   (let ((pow1 1)
  1106.     (pow2 1))
  1107.     (and (eq (car-safe n) '^)
  1108.      (integerp (nth 2 n))
  1109.      (setq pow1 (nth 2 n) n (nth 1 n)))
  1110.     (and (eq (car-safe d) '^)
  1111.      (integerp (nth 2 d))
  1112.      (setq pow2 (nth 2 d) d (nth 1 d)))
  1113.     (let ((un (math-check-unit-name n))
  1114.       (ud (math-check-unit-name d)))
  1115.       (and un ud
  1116.        (if (and (equal (nth 4 un) (nth 4 ud))
  1117.             (eq pow1 pow2))
  1118.            (math-to-standard-units (list '/ n d) nil)
  1119.          (let (ud1)
  1120.            (setq un (nth 4 un)
  1121.              ud (nth 4 ud))
  1122.            (while un
  1123.          (setq ud1 ud)
  1124.          (while ud1
  1125.            (and (eq (car (car un)) (car (car ud1)))
  1126.             (setq try-cancel-units
  1127.                   (+ try-cancel-units
  1128.                  (- (* (cdr (car un)) pow1)
  1129.                     (* (cdr (car ud)) pow2)))))
  1130.            (setq ud1 (cdr ud1)))
  1131.          (setq un (cdr un)))
  1132.            nil)))))
  1133. )
  1134.  
  1135. (math-defsimplify ^
  1136.   (and math-simplifying-units
  1137.        (math-realp (nth 2 expr))
  1138.        (if (memq (car-safe (nth 1 expr)) '(* /))
  1139.        (list (car (nth 1 expr))
  1140.          (list '^ (nth 1 (nth 1 expr)) (nth 2 expr))
  1141.          (list '^ (nth 2 (nth 1 expr)) (nth 2 expr)))
  1142.      (math-simplify-units-pow (nth 1 expr) (nth 2 expr))))
  1143. )
  1144.  
  1145. (math-defsimplify calcFunc-sqrt
  1146.   (and math-simplifying-units
  1147.        (if (memq (car-safe (nth 1 expr)) '(* /))
  1148.        (list (car (nth 1 expr))
  1149.          (list 'calcFunc-sqrt (nth 1 (nth 1 expr)))
  1150.          (list 'calcFunc-sqrt (nth 2 (nth 1 expr))))
  1151.      (math-simplify-units-pow (nth 1 expr) '(frac 1 2))))
  1152. )
  1153.  
  1154. (math-defsimplify (calcFunc-floor
  1155.            calcFunc-ceil
  1156.            calcFunc-round
  1157.            calcFunc-rounde
  1158.            calcFunc-roundu
  1159.            calcFunc-trunc
  1160.            calcFunc-float
  1161.            calcFunc-frac
  1162.            calcFunc-abs
  1163.            calcFunc-clean)
  1164.   (and math-simplifying-units
  1165.        (= (length expr) 2)
  1166.        (if (math-only-units-in-expr-p (nth 1 expr))
  1167.        (nth 1 expr)
  1168.      (if (and (memq (car-safe (nth 1 expr)) '(* /))
  1169.           (or (math-only-units-in-expr-p
  1170.                (nth 1 (nth 1 expr)))
  1171.               (math-only-units-in-expr-p
  1172.                (nth 2 (nth 1 expr)))))
  1173.          (list (car (nth 1 expr))
  1174.            (cons (car expr)
  1175.              (cons (nth 1 (nth 1 expr))
  1176.                    (cdr (cdr expr))))
  1177.            (cons (car expr)
  1178.              (cons (nth 2 (nth 1 expr))
  1179.                    (cdr (cdr expr)))))))))
  1180.  
  1181. (defun math-simplify-units-pow (a pow)
  1182.   (if (and (eq (car-safe a) '^)
  1183.        (math-check-unit-name (nth 1 a))
  1184.        (math-realp (nth 2 a)))
  1185.       (list '^ (nth 1 a) (math-mul pow (nth 2 a)))
  1186.     (let* ((u (math-check-unit-name a))
  1187.        (pf (math-to-simple-fraction pow))
  1188.        (d (and (eq (car-safe pf) 'frac) (nth 2 pf))))
  1189.       (and u d
  1190.        (math-units-are-multiple u d)
  1191.        (list '^ (math-to-standard-units a nil) pow))))
  1192. )
  1193.  
  1194.  
  1195. (defun math-units-are-multiple (u n)
  1196.   (setq u (nth 4 u))
  1197.   (while (and u (= (% (cdr (car u)) n) 0))
  1198.     (setq u (cdr u)))
  1199.   (null u)
  1200. )
  1201.  
  1202. (math-defsimplify calcFunc-sin
  1203.   (and math-simplifying-units
  1204.        (math-units-in-expr-p (nth 1 expr) nil)
  1205.        (let ((rad (math-simplify-units
  1206.            (math-evaluate-expr
  1207.             (math-to-standard-units (nth 1 expr) nil))))
  1208.          (calc-angle-mode 'rad))
  1209.      (and (eq (car-safe rad) '*)
  1210.           (math-realp (nth 1 rad))
  1211.           (eq (car-safe (nth 2 rad)) 'var)
  1212.           (eq (nth 1 (nth 2 rad)) 'rad)
  1213.           (list 'calcFunc-sin (nth 1 rad)))))
  1214. )
  1215.  
  1216. (math-defsimplify calcFunc-cos
  1217.   (and math-simplifying-units
  1218.        (math-units-in-expr-p (nth 1 expr) nil)
  1219.        (let ((rad (math-simplify-units
  1220.            (math-evaluate-expr
  1221.             (math-to-standard-units (nth 1 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.  
  1230. (math-defsimplify calcFunc-tan
  1231.   (and math-simplifying-units
  1232.        (math-units-in-expr-p (nth 1 expr) nil)
  1233.        (let ((rad (math-simplify-units
  1234.            (math-evaluate-expr
  1235.             (math-to-standard-units (nth 1 expr) nil))))
  1236.          (calc-angle-mode 'rad))
  1237.      (and (eq (car-safe rad) '*)
  1238.           (math-realp (nth 1 rad))
  1239.           (eq (car-safe (nth 2 rad)) 'var)
  1240.           (eq (nth 1 (nth 2 rad)) 'rad)
  1241.           (list 'calcFunc-tan (nth 1 rad)))))
  1242. )
  1243.  
  1244.  
  1245. (defun math-remove-units (expr)
  1246.   (if (math-check-unit-name expr)
  1247.       1
  1248.     (if (Math-primp expr)
  1249.     expr
  1250.       (cons (car expr)
  1251.         (mapcar 'math-remove-units (cdr expr)))))
  1252. )
  1253.  
  1254. (defun math-extract-units (expr)
  1255.   (if (memq (car-safe expr) '(* /))
  1256.       (cons (car expr)
  1257.         (mapcar 'math-extract-units (cdr expr)))
  1258.     (if (math-check-unit-name expr) expr 1))
  1259. )
  1260.  
  1261. (defun math-build-units-table-buffer (enter-buffer)
  1262.   (if (not (and math-units-table math-units-table-buffer-valid
  1263.         (get-buffer "*Units Table*")))
  1264.       (let ((buf (get-buffer-create "*Units Table*"))
  1265.         (uptr (math-build-units-table))
  1266.         (calc-language (if (eq calc-language 'big) nil calc-language))
  1267.         (calc-float-format '(float 0))
  1268.         (calc-group-digits nil)
  1269.         (calc-number-radix 10)
  1270.         (calc-point-char ".")
  1271.         (std nil)
  1272.         u name shadowed)
  1273.     (save-excursion
  1274.       (message "Formatting units table...")
  1275.       (set-buffer buf)
  1276.       (setq buffer-read-only nil)
  1277.       (erase-buffer)
  1278.       (insert "Calculator Units Table:\n\n")
  1279.       (insert "Unit    Type  Definition                  Description\n\n")
  1280.       (while uptr
  1281.         (setq u (car uptr)
  1282.           name (nth 2 u))
  1283.         (if (eq (car u) 'm)
  1284.         (setq std t))
  1285.         (setq shadowed (and std (assq (car u) math-additional-units)))
  1286.         (if (and name
  1287.              (> (length name) 1)
  1288.              (eq (aref name 0) ?\*))
  1289.         (progn
  1290.           (or (eq uptr math-units-table)
  1291.               (insert "\n"))
  1292.           (setq name (substring name 1))))
  1293.         (insert " ")
  1294.         (and shadowed (insert "("))
  1295.         (insert (symbol-name (car u)))
  1296.         (and shadowed (insert ")"))
  1297.         (if (nth 3 u)
  1298.         (progn
  1299.           (indent-to 10)
  1300.           (insert (symbol-name (nth 3 u))))
  1301.           (or std
  1302.           (progn
  1303.             (indent-to 10)
  1304.             (insert "U"))))
  1305.         (indent-to 14)
  1306.         (and shadowed (insert "("))
  1307.         (if (nth 1 u)
  1308.         (insert (math-format-value (nth 1 u) 80))
  1309.           (insert (symbol-name (car u))))
  1310.         (and shadowed (insert ")"))
  1311.         (indent-to 41)
  1312.         (insert " ")
  1313.         (if name
  1314.         (insert name))
  1315.         (if shadowed
  1316.         (insert " (redefined above)")
  1317.           (or (nth 1 u)
  1318.           (insert " (base unit)")))
  1319.         (insert "\n")
  1320.         (setq uptr (cdr uptr)))
  1321.       (insert "\n\nUnit Prefix Table:\n\n")
  1322.       (setq uptr math-unit-prefixes)
  1323.       (while uptr
  1324.         (setq u (car uptr))
  1325.         (insert " " (char-to-string (car u)))
  1326.         (if (equal (nth 1 u) (nth 1 (nth 1 uptr)))
  1327.         (insert " " (char-to-string (car (car (setq uptr (cdr uptr)))))
  1328.             "   ")
  1329.           (insert "     "))
  1330.         (insert "10^" (int-to-string (nth 2 (nth 1 u))))
  1331.         (indent-to 15)
  1332.         (insert "   " (nth 2 u) "\n")
  1333.         (while (eq (car (car (setq uptr (cdr uptr)))) 0)))
  1334.       (insert "\n")
  1335.       (setq buffer-read-only t)
  1336.       (message "Formatting units table...done"))
  1337.     (setq math-units-table-buffer-valid t)
  1338.     (let ((oldbuf (current-buffer)))
  1339.       (set-buffer buf)
  1340.       (goto-char (point-min))
  1341.       (set-buffer oldbuf))
  1342.     (if enter-buffer
  1343.         (pop-to-buffer buf)
  1344.       (display-buffer buf)))
  1345.     (if enter-buffer
  1346.     (pop-to-buffer (get-buffer "*Units Table*"))
  1347.       (display-buffer (get-buffer "*Units Table*"))))
  1348. )
  1349.  
  1350.  
  1351.  
  1352.  
  1353.