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