Mercurial > emacs
view lisp/calc/calc-units.el @ 110410:f2e111723c3a
Merge changes made in Gnus trunk.
Reimplement nnimap, and do tweaks to the rest of the code to support that.
* gnus-int.el (gnus-finish-retrieve-group-infos)
(gnus-retrieve-group-data-early): New functions.
* gnus-range.el (gnus-range-nconcat): New function.
* gnus-start.el (gnus-get-unread-articles): Support early retrieval of
data.
(gnus-read-active-for-groups): Support finishing the early retrieval of
data.
* gnus-sum.el (gnus-summary-move-article): Pass the move-to group name
if the move is internal, so that nnimap can do fast internal moves.
* gnus.el (gnus-article-special-mark-lists): Add uid/active tuples, for
nnimap usage.
* nnimap.el: Rewritten.
* nnmail.el (nnmail-inhibit-default-split-group): New internal variable
to allow the mail splitting to not return a default group. This is
useful for nnimap, which will leave unmatched mail in the inbox.
* utf7.el (utf7-encode): Autoload.
Implement shell connection.
* nnimap.el (nnimap-open-shell-stream): New function.
(nnimap-open-connection): Use it.
Get the number of lines by using BODYSTRUCTURE.
(nnimap-transform-headers): Get the number of lines in each message.
(nnimap-retrieve-headers): Query for BODYSTRUCTURE so that we get the
number of lines.
Not all servers return UIDNEXT. Work past this problem.
Remove junk from end of file.
Fix typo in "bogus" section.
Make capabilties be case-insensitive.
Require cl when compiling.
Don't bug out if the LIST command doesn't have any parameters.
2010-09-17 Knut Anders Hatlen <kahatlen@gmail.com> (tiny change)
* nnimap.el (nnimap-get-groups): Don't bug out if the LIST command
doesn't have any parameters.
(mm-text-html-renderer): Document gnus-article-html.
2010-09-17 Julien Danjou <julien@danjou.info> (tiny fix)
* mm-decode.el (mm-text-html-renderer): Document gnus-article-html.
* dgnushack.el: Define netrc-credentials.
If the user doesn't have a /etc/services, supply some sensible port defaults.
Have `unseen-or-unread' select an unread unseen article first.
(nntp-open-server): Return whether the open was successful or not.
Throughout all files, replace (save-excursion (set-buffer ...)) with (with-current-buffer ... ).
Save result so that it doesn't say "failed" all the time.
Add ~/.authinfo to the default, since that's probably most useful for users.
Don't use the "finish" method when we're reading from the agent.
Add some more nnimap-relevant agent stuff to nnagent.el.
* nnimap.el (nnimap-with-process-buffer): Removed.
Revert one line that was changed by mistake in the last checkin.
(nnimap-open-connection): Don't error out when we can't make a connection
nnimap-related changes to avoid bugging out if we can't contact a server.
* gnus-start.el (gnus-get-unread-articles): Don't try to scan groups
from methods that are denied.
* nnimap.el (nnimap-possibly-change-group): Return nil if we can't log
in.
(nnimap-finish-retrieve-group-infos): Make sure we're not waiting for
nothing.
* gnus-sum.el (gnus-select-newsgroup): Indent.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Sat, 18 Sep 2010 10:02:19 +0000 |
| parents | d150a25a0eb9 |
| children | 4e76c4e4f20f |
line wrap: on
line source
;;; calc-units.el --- unit conversion functions for Calc ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;;; Code: ;; This file is autoloaded from calc-ext.el. (require 'calc-ext) (require 'calc-macs) (eval-when-compile (require 'calc-alg)) ;;; Units operations. ;;; Units table last updated 9-Jan-91 by Ulrich Mueller (ulm@vsnhd1.cern.ch) ;;; with some additions by Przemek Klosowski (przemek@rrdstrad.nist.gov) ;;; Updated April 2002 by Jochen Küpper ;;; Updated August 2007, using ;;; CODATA (http://physics.nist.gov/cuu/Constants/index.html) ;;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html) ;;; ESUWM (Encyclopaedia of Scientific Units, Weights and ;;; Measures, by François Cardarelli) ;;; All conversions are exact unless otherwise noted. (defvar math-standard-units '( ;; Length ( m nil "*Meter" ) ( in "254*10^(-2) cm" "Inch" nil "2.54 cm") ( ft "12 in" "Foot") ( yd "3 ft" "Yard" ) ( mi "5280 ft" "Mile" ) ( au "149597870691. m" "Astronomical Unit" nil "149597870691 m (*)") ;; (approx) NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html) ( lyr "c yr" "Light Year" ) ( pc "3.0856775854*10^16 m" "Parsec" nil "3.0856775854 10^16 m (*)") ;; (approx) ESUWM ( nmi "1852 m" "Nautical Mile" ) ( fath "6 ft" "Fathom" ) ( fur "660 ft" "Furlong") ( mu "1 um" "Micron" ) ( mil "(1/1000) in" "Mil" ) ( point "(1/72) in" "Point (1/72 inch)" ) ( Ang "10^(-10) m" "Angstrom" ) ( mfi "mi+ft+in" "Miles + feet + inches" ) ;; TeX lengths ( texpt "(100/7227) in" "Point (TeX conventions)" ) ( texpc "12 texpt" "Pica" ) ( texbp "point" "Big point (TeX conventions)" ) ( texdd "(1238/1157) texpt" "Didot point" ) ( texcc "12 texdd" "Cicero" ) ( texsp "(1/65536) texpt" "Scaled TeX point" ) ;; Area ( hect "10000 m^2" "*Hectare" ) ( a "100 m^2" "Are") ( acre "(1/640) mi^2" "Acre" ) ( b "10^(-28) m^2" "Barn" ) ;; Volume ( L "10^(-3) m^3" "*Liter" ) ( l "L" "Liter" ) ( gal "4 qt" "US Gallon" ) ( qt "2 pt" "Quart" ) ( pt "2 cup" "Pint" ) ( cup "8 ozfl" "Cup" ) ( ozfl "2 tbsp" "Fluid Ounce" ) ( floz "2 tbsp" "Fluid Ounce" ) ( tbsp "3 tsp" "Tablespoon" ) ;; ESUWM defines a US gallon as 231 in^3. ;; That gives the following exact value for tsp. ( tsp "492892159375*10^(-11) ml" "Teaspoon" nil "4.92892159375 ml") ( vol "tsp+tbsp+ozfl+cup+pt+qt+gal" "Gallons + ... + teaspoons" nil "tsp+tbsp+ozfl+cup+pt+qt+gal") ( galC "galUK" "Canadian Gallon" ) ( galUK "454609*10^(-5) L" "UK Gallon" nil "4.54609 L") ;; NIST ;; Time ( s nil "*Second" ) ( sec "s" "Second" ) ( min "60 s" "Minute" ) ( hr "60 min" "Hour" ) ( day "24 hr" "Day" ) ( wk "7 day" "Week" ) ( hms "wk+day+hr+min+s" "Hours, minutes, seconds" ) ( yr "36525*10^(-2) day" "Year (Julian)" nil "365.25 day") ( Hz "1/s" "Hertz" ) ;; Speed ( mph "mi/hr" "*Miles per hour" ) ( kph "km/hr" "Kilometers per hour" ) ( knot "nmi/hr" "Knot" ) ( c "299792458 m/s" "Speed of light" ) ;;; CODATA ;; Acceleration ( ga "980665*10^(-5) m/s^2" "*\"g\" acceleration" nil "9.80665 m / s^2") ;; CODATA ;; Mass ( g nil "*Gram" ) ( lb "16 oz" "Pound (mass)" ) ( oz "28349523125*10^(-9) g" "Ounce (mass)" nil "28.349523125 g") ;; ESUWM ( ton "2000 lb" "Ton" ) ( tpo "ton+lb+oz" "Tons + pounds + ounces (mass)" ) ( t "1000 kg" "Metric ton" ) ( tonUK "10160469088*10^(-7) kg" "UK ton" nil "1016.0469088 kg") ;; ESUWM ( lbt "12 ozt" "Troy pound" ) ( ozt "311034768*10^(-7) g" "Troy ounce" nil "31.10347680 g") ;; ESUWM, 1/12 exact value for lbt ( ct "(2/10) g" "Carat" nil "0.2 g") ;; ESUWM ( u "1.660538782*10^(-27) kg" "Unified atomic mass" nil "1.660538782 10^-27 kg (*)");;(approx) CODATA ;; Force ( N "m kg/s^2" "*Newton" ) ( dyn "10^(-5) N" "Dyne" ) ( gf "ga g" "Gram (force)" ) ( lbf "ga lb" "Pound (force)" ) ( kip "1000 lbf" "Kilopound (force)" ) ( pdl "138254954376*10^(-12) N" "Poundal" nil "0.138254954376 N") ;; ESUWM ;; Energy ( J "N m" "*Joule" ) ( erg "10^(-7) J" "Erg" ) ( cal "41868*10^(-4) J" "International Table Calorie" nil "4.1868 J") ;; NIST ( calth "4184*10^(-3) J" "Thermochemical Calorie" nil "4.184 J") ;; NIST ( Cal "1000 cal" "Large Calorie") ( Btu "105505585262*10^(-8) J" "International Table Btu" nil "1055.05585262 J") ;; ESUWM ( eV "ech V" "Electron volt" ) ( ev "eV" "Electron volt" ) ( therm "105506000 J" "EEC therm" ) ( invcm "h c/cm" "Energy in inverse centimeters" ) ( Kayser "invcm" "Kayser (inverse centimeter energy)" ) ( men "100/invcm" "Inverse energy in meters" ) ( Hzen "h Hz" "Energy in Hertz") ( Ken "k K" "Energy in Kelvins") ( Wh "W hr" "Watt hour") ( Ws "W s" "Watt second") ;; Power ( W "J/s" "*Watt" ) ( hp "550 ft lbf/s" "Horsepower") ;;ESUWM ( hpm "75 m kgf/s" "Metric Horsepower") ;;ESUWM ;; Temperature ( K nil "*Degree Kelvin" K ) ( dK "K" "Degree Kelvin" K ) ( degK "K" "Degree Kelvin" K ) ( dC "K" "Degree Celsius" C ) ( degC "K" "Degree Celsius" C ) ( dF "(5/9) K" "Degree Fahrenheit" F ) ( degF "(5/9) K" "Degree Fahrenheit" F ) ;; Pressure ( Pa "N/m^2" "*Pascal" ) ( bar "10^5 Pa" "Bar" ) ( atm "101325 Pa" "Standard atmosphere" ) ;; CODATA ( Torr "(1/760) atm" "Torr") ( mHg "1000 Torr" "Meter of mercury" ) ( inHg "254*10^(-1) mmHg" "Inch of mercury" nil "25.4 mmHg") ( inH2O "2.490889*10^2 Pa" "Inch of water" nil "2.490889 10^2 Pa (*)") ;;(approx) NIST ( psi "lbf/in^2" "Pounds per square inch" ) ;; Viscosity ( P "(1/10) Pa s" "*Poise" ) ( St "10^(-4) m^2/s" "Stokes" ) ;; Electromagnetism ( A nil "*Ampere" ) ( C "A s" "Coulomb" ) ( Fdy "ech Nav" "Faraday" ) ( e "ech" "Elementary charge" ) ( ech "1.602176487*10^(-19) C" "Elementary charge" nil "1.602176487 10^-19 C (*)") ;;(approx) CODATA ( V "W/A" "Volt" ) ( ohm "V/A" "Ohm" ) ( Ω "ohm" "Ohm" ) ( mho "A/V" "Mho" ) ( S "A/V" "Siemens" ) ( F "C/V" "Farad" ) ( H "Wb/A" "Henry" ) ( T "Wb/m^2" "Tesla" ) ( Gs "10^(-4) T" "Gauss" ) ( Wb "V s" "Weber" ) ;; Luminous intensity ( cd nil "*Candela" ) ( sb "10000 cd/m^2" "Stilb" ) ( lm "cd sr" "Lumen" ) ( lx "lm/m^2" "Lux" ) ( ph "10000 lx" "Phot" ) ( fc "lm/ft^2" "Footcandle") ;; ESUWM ( lam "10000 lm/m^2" "Lambert" ) ( flam "(1/pi) cd/ft^2" "Footlambert") ;; ESUWM ;; Radioactivity ( Bq "1/s" "*Becquerel" ) ( Ci "37*10^9 Bq" "Curie" ) ;; ESUWM ( Gy "J/kg" "Gray" ) ( Sv "Gy" "Sievert" ) ( R "258*10^(-6) C/kg" "Roentgen" ) ;; NIST ( rd "(1/100) Gy" "Rad" ) ( rem "rd" "Rem" ) ;; Amount of substance ( mol nil "*Mole" ) ;; Plane angle ( rad nil "*Radian" ) ( circ "2 pi rad" "Full circle" ) ( rev "circ" "Full revolution" ) ( deg "circ/360" "Degree" ) ( arcmin "deg/60" "Arc minute" ) ( arcsec "arcmin/60" "Arc second" ) ( grad "circ/400" "Grade" ) ( rpm "rev/min" "Revolutions per minute" ) ;; Solid angle ( sr nil "*Steradian" ) ;; Other physical quantities ;; The values are from CODATA, and are approximate. ( h "6.62606896*10^(-34) J s" "*Planck's constant" nil "6.62606896 10^-34 J s (*)") ( hbar "h / (2 pi)" "Planck's constant" ) ;; Exact ( mu0 "4 pi 10^(-7) H/m" "Permeability of vacuum") ;; Exact ( μ0 "mu0" "Permeability of vacuum") ;; Exact ( eps0 "1 / (mu0 c^2)" "Permittivity of vacuum" ) ( ε0 "eps0" "Permittivity of vacuum" ) ( G "6.67428*10^(-11) m^3/(kg s^2)" "Gravitational constant" nil "6.67428 10^-11 m^3/(kg s^2) (*)") ( Nav "6.02214179*10^(23) / mol" "Avogadro's constant" nil "6.02214179 10^23 / mol (*)") ( me "9.10938215*10^(-31) kg" "Electron rest mass" nil "9.10938215 10^-31 kg (*)") ( mp "1.672621637*10^(-27) kg" "Proton rest mass" nil "1.672621637 10^-27 kg (*)") ( mn "1.674927211*10^(-27) kg" "Neutron rest mass" nil "1.674927211 10^-27 kg (*)") ( mmu "1.88353130*10^(-28) kg" "Muon rest mass" nil "1.88353130 10^-28 kg (*)") ( mμ "mmu" "Muon rest mass" nil "1.88353130 10^-28 kg (*)") ( Ryd "10973731.568527 /m" "Rydberg's constant" nil "10973731.568527 /m (*)") ( k "1.3806504*10^(-23) J/K" "Boltzmann's constant" nil "1.3806504 10^-23 J/K (*)") ( alpha "7.2973525376*10^(-3)" "Fine structure constant" nil "7.2973525376 10^-3 (*)") ( α "alpha" "Fine structure constant" nil "7.2973525376 10^-3 (*)") ( muB "927.400915*10^(-26) J/T" "Bohr magneton" nil "927.400915 10^-26 J/T (*)") ( muN "5.05078324*10^(-27) J/T" "Nuclear magneton" nil "5.05078324 10^-27 J/T (*)") ( mue "-928.476377*10^(-26) J/T" "Electron magnetic moment" nil "-928.476377 10^-26 J/T (*)") ( mup "1.410606662*10^(-26) J/T" "Proton magnetic moment" nil "1.410606662 10^-26 J/T (*)") ( R0 "8.314472 J/(mol K)" "Molar gas constant" nil "8.314472 J/(mol K) (*)") ( V0 "22.710981*10^(-3) m^3/mol" "Standard volume of ideal gas" nil "22.710981 10^-3 m^3/mol (*)"))) (defvar math-additional-units nil "*Additional units table for user-defined units. Must be formatted like `math-standard-units'. If you change this, be sure to set `math-units-table' to nil to ensure that the combined units table will be rebuilt.") (defvar math-unit-prefixes '( ( ?Y (^ 10 24) "Yotta" ) ( ?Z (^ 10 21) "Zetta" ) ( ?E (^ 10 18) "Exa" ) ( ?P (^ 10 15) "Peta" ) ( ?T (^ 10 12) "Tera" ) ( ?G (^ 10 9) "Giga" ) ( ?M (^ 10 6) "Mega" ) ( ?k (^ 10 3) "Kilo" ) ( ?K (^ 10 3) "Kilo" ) ( ?h (^ 10 2) "Hecto" ) ( ?H (^ 10 2) "Hecto" ) ( ?D (^ 10 1) "Deka" ) ( 0 (^ 10 0) nil ) ( ?d (^ 10 -1) "Deci" ) ( ?c (^ 10 -2) "Centi" ) ( ?m (^ 10 -3) "Milli" ) ( ?u (^ 10 -6) "Micro" ) ( ?μ (^ 10 -6) "Micro" ) ( ?n (^ 10 -9) "Nano" ) ( ?p (^ 10 -12) "Pico" ) ( ?f (^ 10 -15) "Femto" ) ( ?a (^ 10 -18) "Atto" ) ( ?z (^ 10 -21) "zepto" ) ( ?y (^ 10 -24) "yocto" ))) (defvar math-standard-units-systems '( ( base nil ) ( si ( ( g '(/ (var kg var-kg) 1000) ) ) ) ( mks ( ( g '(/ (var kg var-kg) 1000) ) ) ) ( cgs ( ( m '(* (var cm var-cm) 100 ) ) ) ))) (defvar math-units-table nil "Internal units table. Derived from `math-standard-units' and `math-additional-units'. Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (defvar math-units-table-buffer-valid nil) ;;; Units commands. (defun calc-base-units () (interactive) (calc-slow-wrapper (let ((calc-autorange-units nil)) (calc-enter-result 1 "bsun" (math-simplify-units (math-to-standard-units (calc-top-n 1) nil)))))) (defun calc-quick-units () (interactive) (calc-slow-wrapper (let* ((num (- last-command-event ?0)) (pos (if (= num 0) 10 num)) (units (calc-var-value 'var-Units)) (expr (calc-top-n 1))) (unless (and (>= num 0) (<= num 9)) (error "Bad unit number")) (unless (math-vectorp units) (error "No \"quick units\" are defined")) (unless (< pos (length units)) (error "Unit number %d not defined" pos)) (if (math-units-in-expr-p expr nil) (calc-enter-result 1 (format "cun%d" num) (math-convert-units expr (nth pos units))) (calc-enter-result 1 (format "*un%d" num) (math-simplify-units (math-mul expr (nth pos units)))))))) (defun math-get-standard-units (expr) "Return the standard units in EXPR." (math-simplify-units (math-extract-units (math-to-standard-units expr nil)))) (defun math-get-units (expr) "Return the units in EXPR." (math-simplify-units (math-extract-units expr))) (defun math-make-unit-string (expr) "Return EXPR in string form. If EXPR is nil, return nil." (if expr (let ((cexpr (math-compose-expr expr 0))) (replace-regexp-in-string " / " "/" (if (stringp cexpr) cexpr (math-composition-to-string cexpr)))))) (defvar math-default-units-table (make-hash-table :test 'equal) "A table storing previously converted units.") (defun math-get-default-units (expr) "Get default units to use when converting the units in EXPR." (let* ((units (math-get-units expr)) (standard-units (math-get-standard-units expr)) (default-units (gethash standard-units math-default-units-table))) (if (equal units (car default-units)) (math-make-unit-string (cadr default-units)) (math-make-unit-string (car default-units))))) (defun math-put-default-units (expr) "Put the units in EXPR in the default units table." (let* ((units (math-get-units expr)) (standard-units (math-get-standard-units expr)) (default-units (gethash standard-units math-default-units-table))) (cond ((not default-units) (puthash standard-units (list units) math-default-units-table)) ((not (equal units (car default-units))) (puthash standard-units (list units (car default-units)) math-default-units-table))))) (defun calc-convert-units (&optional old-units new-units) (interactive) (calc-slow-wrapper (let ((expr (calc-top-n 1)) (uoldname nil) unew units defunits) (unless (math-units-in-expr-p expr t) (let ((uold (or old-units (progn (setq uoldname (read-string "Old units: ")) (if (equal uoldname "") (progn (setq uoldname "1") 1) (if (string-match "\\` */" uoldname) (setq uoldname (concat "1" uoldname))) (math-read-expr uoldname)))))) (when (eq (car-safe uold) 'error) (error "Bad format in units expression: %s" (nth 1 uold))) (setq expr (math-mul expr uold)))) (unless new-units (setq defunits (math-get-default-units expr)) (setq new-units (read-string (concat (if uoldname (concat "Old units: " uoldname ", new units") "New units") (if defunits (concat " (default " defunits "): ") ": ")))) (if (and (string= new-units "") defunits) (setq new-units defunits))) (when (string-match "\\` */" new-units) (setq new-units (concat "1" new-units))) (setq units (math-read-expr new-units)) (when (eq (car-safe units) 'error) (error "Bad format in units expression: %s" (nth 2 units))) (math-put-default-units units) (let ((unew (math-units-in-expr-p units t)) (std (and (eq (car-safe units) 'var) (assq (nth 1 units) math-standard-units-systems)))) (if std (calc-enter-result 1 "cvun" (math-simplify-units (math-to-standard-units expr (nth 1 std)))) (unless unew (error "No units specified")) (calc-enter-result 1 "cvun" (math-convert-units expr units (and uoldname (not (equal uoldname "1")))))))))) (defun calc-autorange-units (arg) (interactive "P") (calc-wrapper (calc-change-mode 'calc-autorange-units arg nil t) (message (if calc-autorange-units "Adjusting target unit prefix automatically" "Using target units exactly")))) (defun calc-convert-temperature (&optional old-units new-units) (interactive) (calc-slow-wrapper (let ((expr (calc-top-n 1)) (uold nil) (uoldname nil) unew defunits) (setq uold (or old-units (let ((units (math-single-units-in-expr-p expr))) (if units (if (consp units) (list 'var (car units) (intern (concat "var-" (symbol-name (car units))))) (error "Not a pure temperature expression")) (math-read-expr (setq uoldname (read-string "Old temperature units: "))))))) (when (eq (car-safe uold) 'error) (error "Bad format in units expression: %s" (nth 2 uold))) (or (math-units-in-expr-p expr nil) (setq expr (math-mul expr uold))) (setq defunits (math-get-default-units expr)) (setq unew (or new-units (read-string (concat (if uoldname (concat "Old temperature units: " uoldname ", new units") "New temperature units") (if defunits (concat " (default " defunits "): ") ": "))))) (setq unew (math-read-expr (if (string= unew "") defunits unew))) (when (eq (car-safe unew) 'error) (error "Bad format in units expression: %s" (nth 2 unew))) (math-put-default-units unew) (let ((ntemp (calc-normalize (math-simplify-units (math-convert-temperature expr uold unew uoldname))))) (if (Math-zerop ntemp) (setq ntemp (list '* ntemp unew))) (let ((calc-simplify-mode 'none)) (calc-enter-result 1 "cvtm" ntemp)))))) (defun calc-remove-units () (interactive) (calc-slow-wrapper (calc-enter-result 1 "rmun" (math-simplify-units (math-remove-units (calc-top-n 1)))))) (defun calc-extract-units () (interactive) (calc-slow-wrapper (calc-enter-result 1 "rmun" (math-simplify-units (math-extract-units (calc-top-n 1)))))) ;; The variables calc-num-units and calc-den-units are local to ;; calc-explain-units, but are used by calc-explain-units-rec, ;; which is called by calc-explain-units. (defvar calc-num-units) (defvar calc-den-units) (defun calc-explain-units () (interactive) (calc-wrapper (let ((calc-num-units nil) (calc-den-units nil)) (calc-explain-units-rec (calc-top-n 1) 1) (and calc-den-units (string-match "^[^(].* .*[^)]$" calc-den-units) (setq calc-den-units (concat "(" calc-den-units ")"))) (if calc-num-units (if calc-den-units (message "%s per %s" calc-num-units calc-den-units) (message "%s" calc-num-units)) (if calc-den-units (message "1 per %s" calc-den-units) (message "No units in expression")))))) (defun calc-explain-units-rec (expr pow) (let ((u (math-check-unit-name expr)) pos) (if (and u (not (math-zerop pow))) (let ((name (or (nth 2 u) (symbol-name (car u))))) (if (eq (aref name 0) ?\*) (setq name (substring name 1))) (if (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name) (if (string-match "^[a-zA-Zα-ωΑ-Ω0-9' ()]*$" name) (while (setq pos (string-match "[ ()]" name)) (setq name (concat (substring name 0 pos) (if (eq (aref name pos) 32) "-" "") (substring name (1+ pos))))) (setq name (concat "(" name ")")))) (or (eq (nth 1 expr) (car u)) (setq name (concat (nth 2 (assq (aref (symbol-name (nth 1 expr)) 0) math-unit-prefixes)) (if (and (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name) (not (memq (car u) '(mHg gf)))) (concat "-" name) (downcase name))))) (cond ((or (math-equal-int pow 1) (math-equal-int pow -1))) ((or (math-equal-int pow 2) (math-equal-int pow -2)) (if (equal (nth 4 u) '((m . 1))) (setq name (concat "Square-" name)) (setq name (concat name "-squared")))) ((or (math-equal-int pow 3) (math-equal-int pow -3)) (if (equal (nth 4 u) '((m . 1))) (setq name (concat "Cubic-" name)) (setq name (concat name "-cubed")))) (t (setq name (concat name "^" (math-format-number (math-abs pow)))))) (if (math-posp pow) (setq calc-num-units (if calc-num-units (concat calc-num-units " " name) name)) (setq calc-den-units (if calc-den-units (concat calc-den-units " " name) name)))) (cond ((eq (car-safe expr) '*) (calc-explain-units-rec (nth 1 expr) pow) (calc-explain-units-rec (nth 2 expr) pow)) ((eq (car-safe expr) '/) (calc-explain-units-rec (nth 1 expr) pow) (calc-explain-units-rec (nth 2 expr) (- pow))) ((memq (car-safe expr) '(neg + -)) (calc-explain-units-rec (nth 1 expr) pow)) ((and (eq (car-safe expr) '^) (math-realp (nth 2 expr))) (calc-explain-units-rec (nth 1 expr) (math-mul pow (nth 2 expr)))))))) (defun calc-simplify-units () (interactive) (calc-slow-wrapper (calc-with-default-simplification (calc-enter-result 1 "smun" (math-simplify-units (calc-top-n 1)))))) (defun calc-view-units-table (n) (interactive "P") (and n (setq math-units-table-buffer-valid nil)) (let ((win (get-buffer-window "*Units Table*"))) (if (and win math-units-table math-units-table-buffer-valid) (progn (bury-buffer (window-buffer win)) (let ((curwin (selected-window))) (select-window win) (switch-to-buffer nil) (select-window curwin))) (math-build-units-table-buffer nil)))) (defun calc-enter-units-table (n) (interactive "P") (and n (setq math-units-table-buffer-valid nil)) (math-build-units-table-buffer t) (message "%s" (substitute-command-keys "Type \\[calc] to return to the Calculator"))) (defun calc-define-unit (uname desc &optional disp) (interactive "SDefine unit name: \nsDescription: \nP") (if disp (setq disp (read-string "Display definition: "))) (calc-wrapper (let ((form (calc-top-n 1)) (unit (assq uname math-additional-units))) (or unit (setq math-additional-units (cons (setq unit (list uname nil nil nil nil)) math-additional-units) math-units-table nil)) (setcar (cdr unit) (and (not (and (eq (car-safe form) 'var) (eq (nth 1 form) uname))) (not (math-equal-int form 1)) (math-format-flat-expr form 0))) (setcar (cdr (cdr unit)) (and (not (equal desc "")) desc)) (if disp (setcar (cdr (cdr (cdr (cdr unit)))) disp)))) (calc-invalidate-units-table)) (defun calc-undefine-unit (uname) (interactive "SUndefine unit name: ") (calc-wrapper (let ((unit (assq uname math-additional-units))) (or unit (if (assq uname math-standard-units) (error "\"%s\" is a predefined unit name" uname) (error "Unit name \"%s\" not found" uname))) (setq math-additional-units (delq unit math-additional-units) math-units-table nil))) (calc-invalidate-units-table)) (defun calc-invalidate-units-table () (setq math-units-table nil) (let ((buf (get-buffer "*Units Table*"))) (and buf (with-current-buffer buf (save-excursion (goto-char (point-min)) (if (looking-at "Calculator Units Table") (let ((inhibit-read-only t)) (insert "(Obsolete) ")))))))) (defun calc-get-unit-definition (uname) (interactive "SGet definition for unit: ") (calc-wrapper (math-build-units-table) (let ((unit (assq uname math-units-table))) (or unit (error "Unit name \"%s\" not found" uname)) (let ((msg (nth 2 unit))) (if (stringp msg) (if (string-match "^\\*" msg) (setq msg (substring msg 1))) (setq msg (symbol-name uname))) (if (nth 1 unit) (progn (calc-enter-result 0 "ugdf" (nth 1 unit)) (message "Derived unit: %s" msg)) (calc-enter-result 0 "ugdf" (list 'var uname (intern (concat "var-" (symbol-name uname))))) (message "Base unit: %s" msg)))))) (defun calc-permanent-units () (interactive) (calc-wrapper (let (pos) (set-buffer (find-file-noselect (substitute-in-file-name calc-settings-file))) (goto-char (point-min)) (if (and (search-forward ";;; Custom units stored by Calc" nil t) (progn (beginning-of-line) (setq pos (point)) (search-forward "\n;;; End of custom units" nil t))) (progn (beginning-of-line) (forward-line 1) (delete-region pos (point))) (goto-char (point-max)) (insert "\n\n") (forward-char -1)) (insert ";;; Custom units stored by Calc on " (current-time-string) "\n") (if math-additional-units (progn (insert "(setq math-additional-units '(\n") (let ((list math-additional-units)) (while list (insert " (" (symbol-name (car (car list))) " " (if (nth 1 (car list)) (if (stringp (nth 1 (car list))) (prin1-to-string (nth 1 (car list))) (prin1-to-string (math-format-flat-expr (nth 1 (car list)) 0))) "nil") " " (prin1-to-string (nth 2 (car list))) ")\n") (setq list (cdr list)))) (insert "))\n")) (insert ";;; (no custom units defined)\n")) (insert ";;; End of custom units\n") (save-buffer)))) ;; The variable math-cu-unit-list is local to math-build-units-table, ;; but is used by math-compare-unit-names, which is called (indirectly) ;; by math-build-units-table. ;; math-cu-unit-list is also local to math-convert-units, but is used ;; by math-convert-units-rec, which is called by math-convert-units. (defvar math-cu-unit-list) (defun math-build-units-table () (or math-units-table (let* ((combined-units (append math-additional-units math-standard-units)) (math-cu-unit-list (mapcar 'car combined-units)) tab) (message "Building units table...") (setq math-units-table-buffer-valid nil) (setq tab (mapcar (function (lambda (x) (list (car x) (and (nth 1 x) (if (stringp (nth 1 x)) (let ((exp (math-read-plain-expr (nth 1 x)))) (if (eq (car-safe exp) 'error) (error "Format error in definition of %s in units table: %s" (car x) (nth 2 exp)) exp)) (nth 1 x))) (nth 2 x) (nth 3 x) (and (not (nth 1 x)) (list (cons (car x) 1))) (nth 4 x)))) combined-units)) (let ((math-units-table tab)) (mapc 'math-find-base-units tab)) (message "Building units table...done") (setq math-units-table tab)))) ;; The variables math-fbu-base and math-fbu-entry are local to ;; math-find-base-units, but are used by math-find-base-units-rec, ;; which is called by math-find-base-units. (defvar math-fbu-base) (defvar math-fbu-entry) (defun math-find-base-units (math-fbu-entry) (if (eq (nth 4 math-fbu-entry) 'boom) (error "Circular definition involving unit %s" (car math-fbu-entry))) (or (nth 4 math-fbu-entry) (let (math-fbu-base) (setcar (nthcdr 4 math-fbu-entry) 'boom) (math-find-base-units-rec (nth 1 math-fbu-entry) 1) '(or math-fbu-base (error "Dimensionless definition for unit %s" (car math-fbu-entry))) (while (eq (cdr (car math-fbu-base)) 0) (setq math-fbu-base (cdr math-fbu-base))) (let ((b math-fbu-base)) (while (cdr b) (if (eq (cdr (car (cdr b))) 0) (setcdr b (cdr (cdr b))) (setq b (cdr b))))) (setq math-fbu-base (sort math-fbu-base 'math-compare-unit-names)) (setcar (nthcdr 4 math-fbu-entry) math-fbu-base) math-fbu-base))) (defun math-compare-unit-names (a b) (memq (car b) (cdr (memq (car a) math-cu-unit-list)))) (defun math-find-base-units-rec (expr pow) (let ((u (math-check-unit-name expr))) (cond (u (let ((ulist (math-find-base-units u))) (while ulist (let ((p (* (cdr (car ulist)) pow)) (old (assq (car (car ulist)) math-fbu-base))) (if old (setcdr old (+ (cdr old) p)) (setq math-fbu-base (cons (cons (car (car ulist)) p) math-fbu-base)))) (setq ulist (cdr ulist))))) ((math-scalarp expr)) ((and (eq (car expr) '^) (integerp (nth 2 expr))) (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr)))) ((eq (car expr) '*) (math-find-base-units-rec (nth 1 expr) pow) (math-find-base-units-rec (nth 2 expr) pow)) ((eq (car expr) '/) (math-find-base-units-rec (nth 1 expr) pow) (math-find-base-units-rec (nth 2 expr) (- pow))) ((eq (car expr) 'neg) (math-find-base-units-rec (nth 1 expr) pow)) ((eq (car expr) '+) (math-find-base-units-rec (nth 1 expr) pow)) ((eq (car expr) 'var) (or (eq (nth 1 expr) 'pi) (error "Unknown name %s in defining expression for unit %s" (nth 1 expr) (car math-fbu-entry)))) (t (error "Malformed defining expression for unit %s" (car math-fbu-entry)))))) (defun math-units-in-expr-p (expr sub-exprs) (and (consp expr) (if (eq (car expr) 'var) (math-check-unit-name expr) (and (or sub-exprs (memq (car expr) '(* / ^))) (or (math-units-in-expr-p (nth 1 expr) sub-exprs) (math-units-in-expr-p (nth 2 expr) sub-exprs)))))) (defun math-only-units-in-expr-p (expr) (and (consp expr) (if (eq (car expr) 'var) (math-check-unit-name expr) (if (memq (car expr) '(* /)) (and (math-only-units-in-expr-p (nth 1 expr)) (math-only-units-in-expr-p (nth 2 expr))) (and (eq (car expr) '^) (and (math-only-units-in-expr-p (nth 1 expr)) (math-realp (nth 2 expr)))))))) (defun math-single-units-in-expr-p (expr) (cond ((math-scalarp expr) nil) ((eq (car expr) 'var) (math-check-unit-name expr)) ((eq (car expr) '*) (let ((u1 (math-single-units-in-expr-p (nth 1 expr))) (u2 (math-single-units-in-expr-p (nth 2 expr)))) (or (and u1 u2 'wrong) u1 u2))) ((eq (car expr) '/) (if (math-units-in-expr-p (nth 2 expr) nil) 'wrong (math-single-units-in-expr-p (nth 1 expr)))) (t 'wrong))) (defun math-check-unit-name (v) (and (eq (car-safe v) 'var) (or (assq (nth 1 v) (or math-units-table (math-build-units-table))) (let ((name (symbol-name (nth 1 v)))) (and (> (length name) 1) (assq (aref name 0) math-unit-prefixes) (or (assq (intern (substring name 1)) math-units-table) (and (eq (aref name 0) ?M) (> (length name) 3) (eq (aref name 1) ?e) (eq (aref name 2) ?g) (assq (intern (substring name 3)) math-units-table)))))))) ;; The variable math-which-standard is local to math-to-standard-units, ;; but is used by math-to-standard-rec, which is called by ;; math-to-standard-units. (defvar math-which-standard) (defun math-to-standard-units (expr math-which-standard) (math-to-standard-rec expr)) (defun math-to-standard-rec (expr) (if (eq (car-safe expr) 'var) (let ((u (math-check-unit-name expr)) (base (nth 1 expr))) (if u (progn (if (nth 1 u) (setq expr (math-to-standard-rec (nth 1 u))) (let ((st (assq (car u) math-which-standard))) (if st (setq expr (nth 1 st)) (setq expr (list 'var (car u) (intern (concat "var-" (symbol-name (car u))))))))) (or (null u) (eq base (car u)) (setq expr (list '* (nth 1 (assq (aref (symbol-name base) 0) math-unit-prefixes)) expr))) expr) (if (eq base 'pi) (math-pi) expr))) (if (Math-primp expr) expr (cons (car expr) (mapcar 'math-to-standard-rec (cdr expr)))))) (defun math-apply-units (expr units ulist &optional pure) (setq expr (math-simplify-units expr)) (if ulist (let ((new 0) value) (or (math-numberp expr) (error "Incompatible units")) (while (cdr ulist) (setq value (math-div expr (nth 1 (car ulist))) value (math-floor (let ((calc-internal-prec (1- calc-internal-prec))) (math-normalize value))) new (math-add new (math-mul value (car (car ulist)))) expr (math-sub expr (math-mul value (nth 1 (car ulist)))) ulist (cdr ulist))) (math-add new (math-mul (math-div expr (nth 1 (car ulist))) (car (car ulist))))) (if pure expr (math-simplify-units (list '* expr units))))) (defvar math-decompose-units-cache nil) (defun math-decompose-units (units) (let ((u (math-check-unit-name units))) (and u (eq (car-safe (nth 1 u)) '+) (setq units (nth 1 u)))) (setq units (calcFunc-expand units)) (and (eq (car-safe units) '+) (let ((entry (list units calc-internal-prec calc-prefer-frac))) (or (equal entry (car math-decompose-units-cache)) (let ((ulist nil) (utemp units) qty unit) (while (eq (car-safe utemp) '+) (setq ulist (cons (math-decompose-unit-part (nth 2 utemp)) ulist) utemp (nth 1 utemp))) (setq ulist (cons (math-decompose-unit-part utemp) ulist) utemp ulist) (while (setq utemp (cdr utemp)) (unless (equal (nth 2 (car utemp)) (nth 2 (car ulist))) (error "Inconsistent units in sum"))) (setq math-decompose-units-cache (cons entry (sort ulist (function (lambda (x y) (not (Math-lessp (nth 1 x) (nth 1 y)))))))))) (cdr math-decompose-units-cache)))) (defun math-decompose-unit-part (unit) (cons unit (math-is-multiple (math-simplify-units (math-to-standard-units unit nil)) t))) ;; The variable math-fcu-u is local to math-find-compatible-unit, ;; but is used by math-find-compatible-rec which is called by ;; math-find-compatible-unit. (defvar math-fcu-u) (defun math-find-compatible-unit (expr unit) (let ((math-fcu-u (math-check-unit-name unit))) (if math-fcu-u (math-find-compatible-unit-rec expr 1)))) (defun math-find-compatible-unit-rec (expr pow) (cond ((eq (car-safe expr) '*) (or (math-find-compatible-unit-rec (nth 1 expr) pow) (math-find-compatible-unit-rec (nth 2 expr) pow))) ((eq (car-safe expr) '/) (or (math-find-compatible-unit-rec (nth 1 expr) pow) (math-find-compatible-unit-rec (nth 2 expr) (- pow)))) ((and (eq (car-safe expr) '^) (integerp (nth 2 expr))) (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr)))) (t (let ((u2 (math-check-unit-name expr))) (if (equal (nth 4 math-fcu-u) (nth 4 u2)) (cons expr pow)))))) ;; The variables math-cu-new-units and math-cu-pure are local to ;; math-convert-units, but are used by math-convert-units-rec, ;; which is called by math-convert-units. (defvar math-cu-new-units) (defvar math-cu-pure) (defun math-convert-units (expr math-cu-new-units &optional math-cu-pure) (if (eq (car-safe math-cu-new-units) 'var) (let ((unew (assq (nth 1 math-cu-new-units) (math-build-units-table)))) (if (eq (car-safe (nth 1 unew)) '+) (setq math-cu-new-units (nth 1 unew))))) (math-with-extra-prec 2 (let ((compat (and (not math-cu-pure) (math-find-compatible-unit expr math-cu-new-units))) (math-cu-unit-list nil) (math-combining-units nil)) (if compat (math-simplify-units (math-mul (math-mul (math-simplify-units (math-div expr (math-pow (car compat) (cdr compat)))) (math-pow math-cu-new-units (cdr compat))) (math-simplify-units (math-to-standard-units (math-pow (math-div (car compat) math-cu-new-units) (cdr compat)) nil)))) (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units)) (setq math-cu-new-units (nth 2 (car math-cu-unit-list)))) (when (eq (car-safe expr) '+) (setq expr (math-simplify-units expr))) (if (math-units-in-expr-p expr t) (math-convert-units-rec expr) (math-apply-units (math-to-standard-units (list '/ expr math-cu-new-units) nil) math-cu-new-units math-cu-unit-list math-cu-pure)))))) (defun math-convert-units-rec (expr) (if (math-units-in-expr-p expr nil) (math-apply-units (math-to-standard-units (list '/ expr math-cu-new-units) nil) math-cu-new-units math-cu-unit-list math-cu-pure) (if (Math-primp expr) expr (cons (car expr) (mapcar 'math-convert-units-rec (cdr expr)))))) (defun math-convert-temperature (expr old new &optional pure) (let* ((units (math-single-units-in-expr-p expr)) (uold (if old (if (or (null units) (equal (nth 1 old) (car units))) (math-check-unit-name old) (error "Inconsistent temperature units")) units)) (unew (math-check-unit-name new))) (unless (and (consp unew) (nth 3 unew)) (error "Not a valid temperature unit")) (unless (and (consp uold) (nth 3 uold)) (error "Not a pure temperature expression")) (let ((v (car uold))) (setq expr (list '/ expr (list 'var v (intern (concat "var-" (symbol-name v))))))) (or (eq (nth 3 uold) (nth 3 unew)) (cond ((eq (nth 3 uold) 'K) (setq expr (list '- expr '(/ 27315 100))) (if (eq (nth 3 unew) 'F) (setq expr (list '+ (list '* expr '(/ 9 5)) 32)))) ((eq (nth 3 uold) 'C) (if (eq (nth 3 unew) 'F) (setq expr (list '+ (list '* expr '(/ 9 5)) 32)) (setq expr (list '+ expr '(/ 27315 100))))) (t (setq expr (list '* (list '- expr 32) '(/ 5 9))) (if (eq (nth 3 unew) 'K) (setq expr (list '+ expr '(/ 27315 100))))))) (if pure expr (list '* expr new)))) (defun math-simplify-units (a) (let ((math-simplifying-units t) (calc-matrix-mode 'scalar)) (math-simplify a))) (defalias 'calcFunc-usimplify 'math-simplify-units) ;; The function created by math-defsimplify uses the variable ;; math-simplify-expr, and so is used by functions in math-defsimplify (defvar math-simplify-expr) (math-defsimplify (+ -) (and math-simplifying-units (math-units-in-expr-p (nth 1 math-simplify-expr) nil) (let* ((units (math-extract-units (nth 1 math-simplify-expr))) (ratio (math-simplify (math-to-standard-units (list '/ (nth 2 math-simplify-expr) units) nil)))) (if (math-units-in-expr-p ratio nil) (progn (calc-record-why "*Inconsistent units" math-simplify-expr) math-simplify-expr) (list '* (math-add (math-remove-units (nth 1 math-simplify-expr)) (if (eq (car math-simplify-expr) '-) (math-neg ratio) ratio)) units))))) (math-defsimplify * (math-simplify-units-prod)) (defun math-simplify-units-prod () (and math-simplifying-units calc-autorange-units (Math-realp (nth 1 math-simplify-expr)) (let* ((num (math-float (nth 1 math-simplify-expr))) (xpon (calcFunc-xpon num)) (unitp (cdr (cdr math-simplify-expr))) (unit (car unitp)) (pow (if (eq (car math-simplify-expr) '*) 1 -1)) u) (and (eq (car-safe unit) '*) (setq unitp (cdr unit) unit (car unitp))) (and (eq (car-safe unit) '^) (integerp (nth 2 unit)) (setq pow (* pow (nth 2 unit)) unitp (cdr unit) unit (car unitp))) (and (setq u (math-check-unit-name unit)) (integerp xpon) (or (< xpon 0) (>= xpon (if (eq (car u) 'm) 1 3))) (let* ((uxpon 0) (pref (if (< pow 0) (reverse math-unit-prefixes) math-unit-prefixes)) (p pref) pxpon pname) (or (eq (car u) (nth 1 unit)) (setq uxpon (* pow (nth 2 (nth 1 (assq (aref (symbol-name (nth 1 unit)) 0) math-unit-prefixes)))))) (setq xpon (+ xpon uxpon)) (while (and p (or (memq (car (car p)) '(?d ?D ?h ?H)) (and (eq (car (car p)) ?c) (not (eq (car u) 'm))) (< xpon (setq pxpon (* (nth 2 (nth 1 (car p))) pow))) (progn (setq pname (math-build-var-name (if (eq (car (car p)) 0) (car u) (concat (char-to-string (car (car p))) (symbol-name (car u)))))) (and (/= (car (car p)) 0) (assq (nth 1 pname) math-units-table))))) (setq p (cdr p))) (and p (/= pxpon uxpon) (or (not (eq p pref)) (< xpon (+ pxpon (* (math-abs pow) 3)))) (progn (setcar (cdr math-simplify-expr) (let ((calc-prefer-frac nil)) (calcFunc-scf (nth 1 math-simplify-expr) (- uxpon pxpon)))) (setcar unitp pname) math-simplify-expr))))))) (defvar math-try-cancel-units) (math-defsimplify / (and math-simplifying-units (let ((np (cdr math-simplify-expr)) (math-try-cancel-units 0) n nn) (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*) (cdr (nth 2 math-simplify-expr)) (nthcdr 2 math-simplify-expr))) (if (math-realp (car n)) (progn (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) (let ((calc-prefer-frac nil)) (math-div 1 (car n))))) (setcar n 1))) (while (eq (car-safe (setq n (car np))) '*) (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr))) (setq np (cdr (cdr n)))) (math-simplify-units-divisor np (cdr (cdr math-simplify-expr))) (if (eq math-try-cancel-units 0) (let* ((math-simplifying-units nil) (base (math-simplify (math-to-standard-units math-simplify-expr nil)))) (if (Math-numberp base) (setq math-simplify-expr base)))) (if (eq (car-safe math-simplify-expr) '/) (math-simplify-units-prod)) math-simplify-expr))) (defun math-simplify-units-divisor (np dp) (let ((n (car np)) d dd temp) (while (eq (car-safe (setq d (car dp))) '*) (when (setq temp (math-simplify-units-quotient n (nth 1 d))) (setcar np (setq n temp)) (setcar (cdr d) 1)) (setq dp (cdr (cdr d)))) (when (setq temp (math-simplify-units-quotient n d)) (setcar np (setq n temp)) (setcar dp 1)))) ;; Simplify, e.g., "in / cm" to "2.54" in a units expression. (defun math-simplify-units-quotient (n d) (let ((pow1 1) (pow2 1)) (when (and (eq (car-safe n) '^) (integerp (nth 2 n))) (setq pow1 (nth 2 n) n (nth 1 n))) (when (and (eq (car-safe d) '^) (integerp (nth 2 d))) (setq pow2 (nth 2 d) d (nth 1 d))) (let ((un (math-check-unit-name n)) (ud (math-check-unit-name d))) (and un ud (if (and (equal (nth 4 un) (nth 4 ud)) (eq pow1 pow2)) (if (eq pow1 1) (math-to-standard-units (list '/ n d) nil) (list '^ (math-to-standard-units (list '/ n d) nil) pow1)) (let (ud1) (setq un (nth 4 un) ud (nth 4 ud)) (while un (setq ud1 ud) (while ud1 (and (eq (car (car un)) (car (car ud1))) (setq math-try-cancel-units (+ math-try-cancel-units (- (* (cdr (car un)) pow1) (* (cdr (car ud)) pow2))))) (setq ud1 (cdr ud1))) (setq un (cdr un))) nil)))))) (math-defsimplify ^ (and math-simplifying-units (math-realp (nth 2 math-simplify-expr)) (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) (list (car (nth 1 math-simplify-expr)) (list '^ (nth 1 (nth 1 math-simplify-expr)) (nth 2 math-simplify-expr)) (list '^ (nth 2 (nth 1 math-simplify-expr)) (nth 2 math-simplify-expr))) (math-simplify-units-pow (nth 1 math-simplify-expr) (nth 2 math-simplify-expr))))) (math-defsimplify calcFunc-sqrt (and math-simplifying-units (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) (list (car (nth 1 math-simplify-expr)) (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr))) (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))) (math-simplify-units-pow (nth 1 math-simplify-expr) '(frac 1 2))))) (math-defsimplify (calcFunc-floor calcFunc-ceil calcFunc-round calcFunc-rounde calcFunc-roundu calcFunc-trunc calcFunc-float calcFunc-frac calcFunc-abs calcFunc-clean) (and math-simplifying-units (= (length math-simplify-expr) 2) (if (math-only-units-in-expr-p (nth 1 math-simplify-expr)) (nth 1 math-simplify-expr) (if (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) (or (math-only-units-in-expr-p (nth 1 (nth 1 math-simplify-expr))) (math-only-units-in-expr-p (nth 2 (nth 1 math-simplify-expr))))) (list (car (nth 1 math-simplify-expr)) (cons (car math-simplify-expr) (cons (nth 1 (nth 1 math-simplify-expr)) (cdr (cdr math-simplify-expr)))) (cons (car math-simplify-expr) (cons (nth 2 (nth 1 math-simplify-expr)) (cdr (cdr math-simplify-expr))))))))) (defun math-simplify-units-pow (a pow) (if (and (eq (car-safe a) '^) (math-check-unit-name (nth 1 a)) (math-realp (nth 2 a))) (list '^ (nth 1 a) (math-mul pow (nth 2 a))) (let* ((u (math-check-unit-name a)) (pf (math-to-simple-fraction pow)) (d (and (eq (car-safe pf) 'frac) (nth 2 pf)))) (and u d (math-units-are-multiple u d) (list '^ (math-to-standard-units a nil) pow))))) (defun math-units-are-multiple (u n) (setq u (nth 4 u)) (while (and u (= (% (cdr (car u)) n) 0)) (setq u (cdr u))) (null u)) (math-defsimplify calcFunc-sin (and math-simplifying-units (math-units-in-expr-p (nth 1 math-simplify-expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr (math-to-standard-units (nth 1 math-simplify-expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) (eq (car-safe (nth 2 rad)) 'var) (eq (nth 1 (nth 2 rad)) 'rad) (list 'calcFunc-sin (nth 1 rad)))))) (math-defsimplify calcFunc-cos (and math-simplifying-units (math-units-in-expr-p (nth 1 math-simplify-expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr (math-to-standard-units (nth 1 math-simplify-expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) (eq (car-safe (nth 2 rad)) 'var) (eq (nth 1 (nth 2 rad)) 'rad) (list 'calcFunc-cos (nth 1 rad)))))) (math-defsimplify calcFunc-tan (and math-simplifying-units (math-units-in-expr-p (nth 1 math-simplify-expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr (math-to-standard-units (nth 1 math-simplify-expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) (eq (car-safe (nth 2 rad)) 'var) (eq (nth 1 (nth 2 rad)) 'rad) (list 'calcFunc-tan (nth 1 rad)))))) (math-defsimplify calcFunc-sec (and math-simplifying-units (math-units-in-expr-p (nth 1 math-simplify-expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr (math-to-standard-units (nth 1 math-simplify-expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) (eq (car-safe (nth 2 rad)) 'var) (eq (nth 1 (nth 2 rad)) 'rad) (list 'calcFunc-sec (nth 1 rad)))))) (math-defsimplify calcFunc-csc (and math-simplifying-units (math-units-in-expr-p (nth 1 math-simplify-expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr (math-to-standard-units (nth 1 math-simplify-expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) (eq (car-safe (nth 2 rad)) 'var) (eq (nth 1 (nth 2 rad)) 'rad) (list 'calcFunc-csc (nth 1 rad)))))) (math-defsimplify calcFunc-cot (and math-simplifying-units (math-units-in-expr-p (nth 1 math-simplify-expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr (math-to-standard-units (nth 1 math-simplify-expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) (eq (car-safe (nth 2 rad)) 'var) (eq (nth 1 (nth 2 rad)) 'rad) (list 'calcFunc-cot (nth 1 rad)))))) (defun math-remove-units (expr) (if (math-check-unit-name expr) 1 (if (Math-primp expr) expr (cons (car expr) (mapcar 'math-remove-units (cdr expr)))))) (defun math-extract-units (expr) (if (memq (car-safe expr) '(* /)) (cons (car expr) (mapcar 'math-extract-units (cdr expr))) (if (math-check-unit-name expr) expr 1))) (defun math-build-units-table-buffer (enter-buffer) (if (not (and math-units-table math-units-table-buffer-valid (get-buffer "*Units Table*"))) (let ((buf (get-buffer-create "*Units Table*")) (uptr (math-build-units-table)) (calc-language (if (eq calc-language 'big) nil calc-language)) (calc-float-format '(float 0)) (calc-group-digits nil) (calc-number-radix 10) (calc-twos-complement-mode nil) (calc-point-char ".") (std nil) u name shadowed) (save-excursion (message "Formatting units table...") (set-buffer buf) (let ((inhibit-read-only t)) (erase-buffer) (insert "Calculator Units Table:\n\n") (insert "(All definitions are exact unless marked with an asterisk (*).)\n\n") (insert "Unit Type Definition Description\n\n") (while uptr (setq u (car uptr) name (nth 2 u)) (when (eq (car u) 'm) (setq std t)) (setq shadowed (and std (assq (car u) math-additional-units))) (when (and name (> (length name) 1) (eq (aref name 0) ?\*)) (unless (eq uptr math-units-table) (insert "\n")) (setq name (substring name 1))) (insert " ") (and shadowed (insert "(")) (insert (symbol-name (car u))) (and shadowed (insert ")")) (if (nth 3 u) (progn (indent-to 10) (insert (symbol-name (nth 3 u)))) (or std (progn (indent-to 10) (insert "U")))) (indent-to 14) (and shadowed (insert "(")) (if (nth 5 u) (insert (nth 5 u)) (if (nth 1 u) (insert (math-format-value (nth 1 u) 80)) (insert (symbol-name (car u))))) (and shadowed (insert ")")) (indent-to 41) (insert " ") (when name (insert name)) (if shadowed (insert " (redefined above)") (unless (nth 1 u) (insert " (base unit)"))) (insert "\n") (setq uptr (cdr uptr))) (insert "\n\nUnit Prefix Table:\n\n") (setq uptr math-unit-prefixes) (while uptr (setq u (car uptr)) (insert " " (char-to-string (car u))) (if (equal (nth 1 u) (nth 1 (nth 1 uptr))) (insert " " (char-to-string (car (car (setq uptr (cdr uptr))))) " ") (insert " ")) (insert "10^" (int-to-string (nth 2 (nth 1 u)))) (indent-to 15) (insert " " (nth 2 u) "\n") (while (eq (car (car (setq uptr (cdr uptr)))) 0))) (insert "\n")) (view-mode) (message "Formatting units table...done")) (setq math-units-table-buffer-valid t) (let ((oldbuf (current-buffer))) (set-buffer buf) (goto-char (point-min)) (set-buffer oldbuf)) (if enter-buffer (pop-to-buffer buf) (display-buffer buf))) (if enter-buffer (pop-to-buffer (get-buffer "*Units Table*")) (display-buffer (get-buffer "*Units Table*"))))) (provide 'calc-units) ;; Local variables: ;; coding: utf-8 ;; End: ;; arch-tag: e993314f-3adc-4191-be61-4ef8874881c4 ;;; calc-units.el ends here