Mercurial > emacs

comparison lisp/calc/calc-units.el @ 40785:2fb9d407ae73

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Initial import of Calc 2.02f.
author Eli Zaretskii <eliz@gnu.org>
date Tue, 06 Nov 2001 18:59:06 +0000
parents
children 14b73d89514a
comparison
equal deleted inserted replaced
40784:d57f74c55909 40785:2fb9d407ae73
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