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