41269
|
1 ;;; calc-units.el --- unit conversion functions for Calc
|
|
2
|
64325
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
|
|
4 ;; 2005 Free Software Foundation, Inc.
|
41269
|
5
|
|
6 ;; Author: David Gillespie <daveg@synaptics.com>
|
58303
|
7 ;; Maintainer: Jay Belanger <belanger@truman.edu>
|
40785
|
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
|
41269
|
26 ;;; Commentary:
|
40785
|
27
|
41269
|
28 ;;; Code:
|
40785
|
29
|
|
30 ;; This file is autoloaded from calc-ext.el.
|
58677
|
31
|
40785
|
32 (require 'calc-ext)
|
|
33 (require 'calc-macs)
|
59394
18e7205127f0
Make sure the proper macro definitions are available when compiling.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
34 (eval-when-compile
|
18e7205127f0
Make sure the proper macro definitions are available when compiling.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
35 (require 'calc-alg))
|
40785
|
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)
|
45291
|
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
|
40785
|
47
|
|
48 (defvar math-standard-units
|
|
49 '( ;; Length
|
45291
|
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" )
|
49598
|
66
|
45291
|
67 ;; Area
|
|
68 ( hect "10000 m^2" "*Hectare" )
|
|
69 ( acre "mi^2 / 640" "Acre" )
|
|
70 ( b "1e-28 m^2" "Barn" )
|
49598
|
71
|
45291
|
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" )
|
49598
|
86
|
45291
|
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" )
|
40785
|
97
|
45291
|
98 ;; Speed
|
|
99 ( mph "mi/hr" "*Miles per hour" )
|
|
100 ( kph "km/hr" "Kilometers per hour" )
|
|
101 ( knot "nmi/hr" "Knot" )
|
49598
|
102 ( c "2.99792458e8 m/s" "Speed of light" )
|
|
103
|
45291
|
104 ;; Acceleration
|
|
105 ( ga "9.80665 m/s^2" "*\"g\" acceleration" )
|
40785
|
106
|
45291
|
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
|
40785
|
119
|
45291
|
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" )
|
40785
|
127
|
45291
|
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")
|
61412
|
141 ( Wh "W hr" "Watt hour")
|
45291
|
142 ( Ws "W s" "Watt second")
|
40785
|
143
|
45291
|
144 ;; Power
|
|
145 ( W "J/s" "*Watt" )
|
|
146 ( hp "745.7 W" "Horsepower" )
|
40785
|
147
|
45291
|
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 )
|
40785
|
156
|
45291
|
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" )
|
40785
|
166
|
45291
|
167 ;; Viscosity
|
|
168 ( P "0.1 Pa s" "*Poise" )
|
|
169 ( St "1e-4 m^2/s" "Stokes" )
|
40785
|
170
|
45291
|
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" )
|
40785
|
186
|
45291
|
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)
|
40785
|
196
|
45291
|
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" )
|
40785
|
205
|
45291
|
206 ;; Amount of substance
|
|
207 ( mol nil "*Mole" )
|
40785
|
208
|
45291
|
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" )
|
40785
|
218
|
45291
|
219 ;; Solid angle
|
|
220 ( sr nil "*Steradian" )
|
40785
|
221
|
45291
|
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" )))
|
40785
|
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" )
|
41269
|
268 ( ?a (float 1 -18) "Atto" )))
|
40785
|
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)) ) ) )
|
41269
|
274 ( cgs ( ( m '(* (var cm var-cm) 100 ) ) ) )))
|
40785
|
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
|
41269
|
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))
|
57130
|
300 (error "Bad unit number"))
|
41269
|
301 (unless (math-vectorp units)
|
57130
|
302 (error "No \"quick units\" are defined"))
|
41269
|
303 (unless (< pos (length units))
|
57130
|
304 (error "Unit number %d not defined" pos))
|
41269
|
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)
|
58508
|
317 unew
|
|
318 units)
|
41269
|
319 (unless (math-units-in-expr-p expr t)
|
|
320 (let ((uold (or old-units
|
|
321 (progn
|
|
322 (setq uoldname (read-string "Old units: "))
|
|
323 (if (equal uoldname "")
|
|
324 (progn
|
|
325 (setq uoldname "1")
|
|
326 1)
|
|
327 (if (string-match "\\` */" uoldname)
|
|
328 (setq uoldname (concat "1" uoldname)))
|
|
329 (math-read-expr uoldname))))))
|
|
330 (when (eq (car-safe uold) 'error)
|
|
331 (error "Bad format in units expression: %s" (nth 1 uold)))
|
|
332 (setq expr (math-mul expr uold))))
|
|
333 (unless new-units
|
|
334 (setq new-units (read-string (if uoldname
|
|
335 (concat "Old units: "
|
|
336 uoldname
|
|
337 ", new units: ")
|
|
338 "New units: "))))
|
|
339 (when (string-match "\\` */" new-units)
|
|
340 (setq new-units (concat "1" new-units)))
|
|
341 (setq units (math-read-expr new-units))
|
|
342 (when (eq (car-safe units) 'error)
|
|
343 (error "Bad format in units expression: %s" (nth 2 units)))
|
|
344 (let ((unew (math-units-in-expr-p units t))
|
|
345 (std (and (eq (car-safe units) 'var)
|
|
346 (assq (nth 1 units) math-standard-units-systems))))
|
|
347 (if std
|
|
348 (calc-enter-result 1 "cvun" (math-simplify-units
|
|
349 (math-to-standard-units expr
|
|
350 (nth 1 std))))
|
|
351 (unless unew
|
|
352 (error "No units specified"))
|
|
353 (calc-enter-result 1 "cvun"
|
|
354 (math-convert-units
|
|
355 expr units
|
|
356 (and uoldname (not (equal uoldname "1"))))))))))
|
|
357
|
|
358 (defun calc-autorange-units (arg)
|
|
359 (interactive "P")
|
|
360 (calc-wrapper
|
|
361 (calc-change-mode 'calc-autorange-units arg nil t)
|
|
362 (message (if calc-autorange-units
|
|
363 "Adjusting target unit prefix automatically"
|
|
364 "Using target units exactly"))))
|
|
365
|
|
366 (defun calc-convert-temperature (&optional old-units new-units)
|
|
367 (interactive)
|
|
368 (calc-slow-wrapper
|
|
369 (let ((expr (calc-top-n 1))
|
|
370 (uold nil)
|
|
371 (uoldname nil)
|
|
372 unew)
|
|
373 (setq uold (or old-units
|
|
374 (let ((units (math-single-units-in-expr-p expr)))
|
|
375 (if units
|
|
376 (if (consp units)
|
|
377 (list 'var (car units)
|
|
378 (intern (concat "var-"
|
|
379 (symbol-name
|
|
380 (car units)))))
|
|
381 (error "Not a pure temperature expression"))
|
|
382 (math-read-expr
|
|
383 (setq uoldname (read-string
|
|
384 "Old temperature units: ")))))))
|
|
385 (when (eq (car-safe uold) 'error)
|
|
386 (error "Bad format in units expression: %s" (nth 2 uold)))
|
|
387 (or (math-units-in-expr-p expr nil)
|
|
388 (setq expr (math-mul expr uold)))
|
|
389 (setq unew (or new-units
|
|
390 (math-read-expr
|
|
391 (read-string (if uoldname
|
|
392 (concat "Old temperature units: "
|
|
393 uoldname
|
|
394 ", new units: ")
|
|
395 "New temperature units: ")))))
|
|
396 (when (eq (car-safe unew) 'error)
|
|
397 (error "Bad format in units expression: %s" (nth 2 unew)))
|
|
398 (calc-enter-result 1 "cvtm" (math-simplify-units
|
|
399 (math-convert-temperature expr uold unew
|
|
400 uoldname))))))
|
|
401
|
|
402 (defun calc-remove-units ()
|
|
403 (interactive)
|
|
404 (calc-slow-wrapper
|
|
405 (calc-enter-result 1 "rmun" (math-simplify-units
|
|
406 (math-remove-units (calc-top-n 1))))))
|
|
407
|
|
408 (defun calc-extract-units ()
|
|
409 (interactive)
|
|
410 (calc-slow-wrapper
|
|
411 (calc-enter-result 1 "rmun" (math-simplify-units
|
|
412 (math-extract-units (calc-top-n 1))))))
|
|
413
|
58508
|
414 ;; The variables calc-num-units and calc-den-units are local to
|
|
415 ;; calc-explain-units, but are used by calc-explain-units-rec,
|
|
416 ;; which is called by calc-explain-units.
|
|
417 (defvar calc-num-units)
|
|
418 (defvar calc-den-units)
|
|
419
|
41269
|
420 (defun calc-explain-units ()
|
|
421 (interactive)
|
|
422 (calc-wrapper
|
58508
|
423 (let ((calc-num-units nil)
|
|
424 (calc-den-units nil))
|
41269
|
425 (calc-explain-units-rec (calc-top-n 1) 1)
|
58508
|
426 (and calc-den-units (string-match "^[^(].* .*[^)]$" calc-den-units)
|
|
427 (setq calc-den-units (concat "(" calc-den-units ")")))
|
|
428 (if calc-num-units
|
|
429 (if calc-den-units
|
|
430 (message "%s per %s" calc-num-units calc-den-units)
|
|
431 (message "%s" calc-num-units))
|
|
432 (if calc-den-units
|
|
433 (message "1 per %s" calc-den-units)
|
41269
|
434 (message "No units in expression"))))))
|
|
435
|
|
436 (defun calc-explain-units-rec (expr pow)
|
|
437 (let ((u (math-check-unit-name expr))
|
|
438 pos)
|
|
439 (if (and u (not (math-zerop pow)))
|
|
440 (let ((name (or (nth 2 u) (symbol-name (car u)))))
|
|
441 (if (eq (aref name 0) ?\*)
|
|
442 (setq name (substring name 1)))
|
|
443 (if (string-match "[^a-zA-Z0-9']" name)
|
|
444 (if (string-match "^[a-zA-Z0-9' ()]*$" name)
|
|
445 (while (setq pos (string-match "[ ()]" name))
|
|
446 (setq name (concat (substring name 0 pos)
|
|
447 (if (eq (aref name pos) 32) "-" "")
|
|
448 (substring name (1+ pos)))))
|
|
449 (setq name (concat "(" name ")"))))
|
|
450 (or (eq (nth 1 expr) (car u))
|
|
451 (setq name (concat (nth 2 (assq (aref (symbol-name
|
|
452 (nth 1 expr)) 0)
|
|
453 math-unit-prefixes))
|
|
454 (if (and (string-match "[^a-zA-Z0-9']" name)
|
|
455 (not (memq (car u) '(mHg gf))))
|
|
456 (concat "-" name)
|
|
457 (downcase name)))))
|
|
458 (cond ((or (math-equal-int pow 1)
|
|
459 (math-equal-int pow -1)))
|
|
460 ((or (math-equal-int pow 2)
|
|
461 (math-equal-int pow -2))
|
|
462 (if (equal (nth 4 u) '((m . 1)))
|
|
463 (setq name (concat "Square-" name))
|
|
464 (setq name (concat name "-squared"))))
|
|
465 ((or (math-equal-int pow 3)
|
|
466 (math-equal-int pow -3))
|
|
467 (if (equal (nth 4 u) '((m . 1)))
|
|
468 (setq name (concat "Cubic-" name))
|
|
469 (setq name (concat name "-cubed"))))
|
|
470 (t
|
|
471 (setq name (concat name "^"
|
|
472 (math-format-number (math-abs pow))))))
|
|
473 (if (math-posp pow)
|
58508
|
474 (setq calc-num-units (if calc-num-units
|
|
475 (concat calc-num-units " " name)
|
41269
|
476 name))
|
58508
|
477 (setq calc-den-units (if calc-den-units
|
|
478 (concat calc-den-units " " name)
|
41269
|
479 name))))
|
|
480 (cond ((eq (car-safe expr) '*)
|
|
481 (calc-explain-units-rec (nth 1 expr) pow)
|
|
482 (calc-explain-units-rec (nth 2 expr) pow))
|
|
483 ((eq (car-safe expr) '/)
|
|
484 (calc-explain-units-rec (nth 1 expr) pow)
|
|
485 (calc-explain-units-rec (nth 2 expr) (- pow)))
|
|
486 ((memq (car-safe expr) '(neg + -))
|
|
487 (calc-explain-units-rec (nth 1 expr) pow))
|
|
488 ((and (eq (car-safe expr) '^)
|
|
489 (math-realp (nth 2 expr)))
|
|
490 (calc-explain-units-rec (nth 1 expr)
|
|
491 (math-mul pow (nth 2 expr))))))))
|
|
492
|
|
493 (defun calc-simplify-units ()
|
|
494 (interactive)
|
|
495 (calc-slow-wrapper
|
|
496 (calc-with-default-simplification
|
|
497 (calc-enter-result 1 "smun" (math-simplify-units (calc-top-n 1))))))
|
|
498
|
|
499 (defun calc-view-units-table (n)
|
|
500 (interactive "P")
|
|
501 (and n (setq math-units-table-buffer-valid nil))
|
|
502 (let ((win (get-buffer-window "*Units Table*")))
|
|
503 (if (and win
|
|
504 math-units-table
|
|
505 math-units-table-buffer-valid)
|
|
506 (progn
|
|
507 (bury-buffer (window-buffer win))
|
|
508 (let ((curwin (selected-window)))
|
|
509 (select-window win)
|
|
510 (switch-to-buffer nil)
|
|
511 (select-window curwin)))
|
|
512 (math-build-units-table-buffer nil))))
|
|
513
|
|
514 (defun calc-enter-units-table (n)
|
|
515 (interactive "P")
|
|
516 (and n (setq math-units-table-buffer-valid nil))
|
|
517 (math-build-units-table-buffer t)
|
65592
|
518 (message "%s" (substitute-command-keys "Type \\[calc] to return to the Calculator")))
|
41269
|
519
|
|
520 (defun calc-define-unit (uname desc)
|
|
521 (interactive "SDefine unit name: \nsDescription: ")
|
|
522 (calc-wrapper
|
|
523 (let ((form (calc-top-n 1))
|
|
524 (unit (assq uname math-additional-units)))
|
|
525 (or unit
|
|
526 (setq math-additional-units
|
|
527 (cons (setq unit (list uname nil nil))
|
|
528 math-additional-units)
|
|
529 math-units-table nil))
|
|
530 (setcar (cdr unit) (and (not (and (eq (car-safe form) 'var)
|
|
531 (eq (nth 1 form) uname)))
|
|
532 (not (math-equal-int form 1))
|
|
533 (math-format-flat-expr form 0)))
|
|
534 (setcar (cdr (cdr unit)) (and (not (equal desc ""))
|
|
535 desc))))
|
|
536 (calc-invalidate-units-table))
|
|
537
|
|
538 (defun calc-undefine-unit (uname)
|
|
539 (interactive "SUndefine unit name: ")
|
|
540 (calc-wrapper
|
|
541 (let ((unit (assq uname math-additional-units)))
|
|
542 (or unit
|
|
543 (if (assq uname math-standard-units)
|
|
544 (error "\"%s\" is a predefined unit name" uname)
|
|
545 (error "Unit name \"%s\" not found" uname)))
|
|
546 (setq math-additional-units (delq unit math-additional-units)
|
|
547 math-units-table nil)))
|
|
548 (calc-invalidate-units-table))
|
|
549
|
|
550 (defun calc-invalidate-units-table ()
|
|
551 (setq math-units-table nil)
|
|
552 (let ((buf (get-buffer "*Units Table*")))
|
|
553 (and buf
|
|
554 (save-excursion
|
|
555 (set-buffer buf)
|
|
556 (save-excursion
|
|
557 (goto-char (point-min))
|
|
558 (if (looking-at "Calculator Units Table")
|
62565
|
559 (let ((inhibit-read-only t))
|
41269
|
560 (insert "(Obsolete) "))))))))
|
|
561
|
|
562 (defun calc-get-unit-definition (uname)
|
|
563 (interactive "SGet definition for unit: ")
|
|
564 (calc-wrapper
|
|
565 (math-build-units-table)
|
|
566 (let ((unit (assq uname math-units-table)))
|
|
567 (or unit
|
|
568 (error "Unit name \"%s\" not found" uname))
|
|
569 (let ((msg (nth 2 unit)))
|
|
570 (if (stringp msg)
|
|
571 (if (string-match "^\\*" msg)
|
|
572 (setq msg (substring msg 1)))
|
|
573 (setq msg (symbol-name uname)))
|
|
574 (if (nth 1 unit)
|
|
575 (progn
|
|
576 (calc-enter-result 0 "ugdf" (nth 1 unit))
|
|
577 (message "Derived unit: %s" msg))
|
|
578 (calc-enter-result 0 "ugdf" (list 'var uname
|
|
579 (intern
|
|
580 (concat "var-"
|
|
581 (symbol-name uname)))))
|
|
582 (message "Base unit: %s" msg))))))
|
|
583
|
|
584 (defun calc-permanent-units ()
|
|
585 (interactive)
|
|
586 (calc-wrapper
|
|
587 (let (pos)
|
|
588 (set-buffer (find-file-noselect (substitute-in-file-name
|
|
589 calc-settings-file)))
|
|
590 (goto-char (point-min))
|
|
591 (if (and (search-forward ";;; Custom units stored by Calc" nil t)
|
|
592 (progn
|
|
593 (beginning-of-line)
|
|
594 (setq pos (point))
|
|
595 (search-forward "\n;;; End of custom units" nil t)))
|
|
596 (progn
|
|
597 (beginning-of-line)
|
|
598 (forward-line 1)
|
|
599 (delete-region pos (point)))
|
|
600 (goto-char (point-max))
|
|
601 (insert "\n\n")
|
|
602 (forward-char -1))
|
|
603 (insert ";;; Custom units stored by Calc on " (current-time-string) "\n")
|
|
604 (if math-additional-units
|
|
605 (progn
|
|
606 (insert "(setq math-additional-units '(\n")
|
|
607 (let ((list math-additional-units))
|
|
608 (while list
|
|
609 (insert " (" (symbol-name (car (car list))) " "
|
|
610 (if (nth 1 (car list))
|
|
611 (if (stringp (nth 1 (car list)))
|
|
612 (prin1-to-string (nth 1 (car list)))
|
|
613 (prin1-to-string (math-format-flat-expr
|
|
614 (nth 1 (car list)) 0)))
|
|
615 "nil")
|
|
616 " "
|
|
617 (prin1-to-string (nth 2 (car list)))
|
|
618 ")\n")
|
|
619 (setq list (cdr list))))
|
|
620 (insert "))\n"))
|
|
621 (insert ";;; (no custom units defined)\n"))
|
|
622 (insert ";;; End of custom units\n")
|
|
623 (save-buffer))))
|
|
624
|
|
625
|
58508
|
626 ;; The variable math-cu-unit-list is local to math-build-units-table,
|
|
627 ;; but is used by math-compare-unit-names, which is called (indirectly)
|
|
628 ;; by math-build-units-table.
|
|
629 ;; math-cu-unit-list is also local to math-convert-units, but is used
|
|
630 ;; by math-convert-units-rec, which is called by math-convert-units.
|
|
631 (defvar math-cu-unit-list)
|
40785
|
632
|
|
633 (defun math-build-units-table ()
|
|
634 (or math-units-table
|
|
635 (let* ((combined-units (append math-additional-units
|
|
636 math-standard-units))
|
58508
|
637 (math-cu-unit-list (mapcar 'car combined-units))
|
40785
|
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")
|
41046
|
661 (setq math-units-table tab))))
|
40785
|
662
|
58508
|
663 ;; The variables math-fbu-base and math-fbu-entry are local to
|
|
664 ;; math-find-base-units, but are used by math-find-base-units-rec,
|
|
665 ;; which is called by math-find-base-units.
|
|
666 (defvar math-fbu-base)
|
|
667 (defvar math-fbu-entry)
|
|
668
|
58511
|
669 (defun math-find-base-units (math-fbu-entry)
|
|
670 (if (eq (nth 4 math-fbu-entry) 'boom)
|
|
671 (error "Circular definition involving unit %s" (car math-fbu-entry)))
|
|
672 (or (nth 4 math-fbu-entry)
|
|
673 (let (math-fbu-base)
|
|
674 (setcar (nthcdr 4 math-fbu-entry) 'boom)
|
|
675 (math-find-base-units-rec (nth 1 math-fbu-entry) 1)
|
|
676 '(or math-fbu-base
|
|
677 (error "Dimensionless definition for unit %s" (car math-fbu-entry)))
|
|
678 (while (eq (cdr (car math-fbu-base)) 0)
|
|
679 (setq math-fbu-base (cdr math-fbu-base)))
|
|
680 (let ((b math-fbu-base))
|
40785
|
681 (while (cdr b)
|
|
682 (if (eq (cdr (car (cdr b))) 0)
|
|
683 (setcdr b (cdr (cdr b)))
|
|
684 (setq b (cdr b)))))
|
58511
|
685 (setq math-fbu-base (sort math-fbu-base 'math-compare-unit-names))
|
|
686 (setcar (nthcdr 4 math-fbu-entry) math-fbu-base)
|
|
687 math-fbu-base)))
|
40785
|
688
|
|
689 (defun math-compare-unit-names (a b)
|
58508
|
690 (memq (car b) (cdr (memq (car a) math-cu-unit-list))))
|
40785
|
691
|
|
692 (defun math-find-base-units-rec (expr pow)
|
|
693 (let ((u (math-check-unit-name expr)))
|
|
694 (cond (u
|
|
695 (let ((ulist (math-find-base-units u)))
|
|
696 (while ulist
|
|
697 (let ((p (* (cdr (car ulist)) pow))
|
58511
|
698 (old (assq (car (car ulist)) math-fbu-base)))
|
40785
|
699 (if old
|
|
700 (setcdr old (+ (cdr old) p))
|
58511
|
701 (setq math-fbu-base
|
|
702 (cons (cons (car (car ulist)) p) math-fbu-base))))
|
40785
|
703 (setq ulist (cdr ulist)))))
|
|
704 ((math-scalarp expr))
|
|
705 ((and (eq (car expr) '^)
|
|
706 (integerp (nth 2 expr)))
|
|
707 (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr))))
|
|
708 ((eq (car expr) '*)
|
|
709 (math-find-base-units-rec (nth 1 expr) pow)
|
|
710 (math-find-base-units-rec (nth 2 expr) pow))
|
|
711 ((eq (car expr) '/)
|
|
712 (math-find-base-units-rec (nth 1 expr) pow)
|
|
713 (math-find-base-units-rec (nth 2 expr) (- pow)))
|
|
714 ((eq (car expr) 'neg)
|
|
715 (math-find-base-units-rec (nth 1 expr) pow))
|
|
716 ((eq (car expr) '+)
|
|
717 (math-find-base-units-rec (nth 1 expr) pow))
|
|
718 ((eq (car expr) 'var)
|
|
719 (or (eq (nth 1 expr) 'pi)
|
|
720 (error "Unknown name %s in defining expression for unit %s"
|
58511
|
721 (nth 1 expr) (car math-fbu-entry))))
|
|
722 (t (error "Malformed defining expression for unit %s" (car math-fbu-entry))))))
|
40785
|
723
|
|
724
|
|
725 (defun math-units-in-expr-p (expr sub-exprs)
|
|
726 (and (consp expr)
|
|
727 (if (eq (car expr) 'var)
|
|
728 (math-check-unit-name expr)
|
|
729 (and (or sub-exprs
|
|
730 (memq (car expr) '(* / ^)))
|
|
731 (or (math-units-in-expr-p (nth 1 expr) sub-exprs)
|
41046
|
732 (math-units-in-expr-p (nth 2 expr) sub-exprs))))))
|
40785
|
733
|
|
734 (defun math-only-units-in-expr-p (expr)
|
|
735 (and (consp expr)
|
|
736 (if (eq (car expr) 'var)
|
|
737 (math-check-unit-name expr)
|
|
738 (if (memq (car expr) '(* /))
|
|
739 (and (math-only-units-in-expr-p (nth 1 expr))
|
|
740 (math-only-units-in-expr-p (nth 2 expr)))
|
|
741 (and (eq (car expr) '^)
|
|
742 (and (math-only-units-in-expr-p (nth 1 expr))
|
41046
|
743 (math-realp (nth 2 expr))))))))
|
40785
|
744
|
|
745 (defun math-single-units-in-expr-p (expr)
|
|
746 (cond ((math-scalarp expr) nil)
|
|
747 ((eq (car expr) 'var)
|
|
748 (math-check-unit-name expr))
|
|
749 ((eq (car expr) '*)
|
|
750 (let ((u1 (math-single-units-in-expr-p (nth 1 expr)))
|
|
751 (u2 (math-single-units-in-expr-p (nth 2 expr))))
|
|
752 (or (and u1 u2 'wrong)
|
|
753 u1
|
|
754 u2)))
|
|
755 ((eq (car expr) '/)
|
|
756 (if (math-units-in-expr-p (nth 2 expr) nil)
|
|
757 'wrong
|
|
758 (math-single-units-in-expr-p (nth 1 expr))))
|
41046
|
759 (t 'wrong)))
|
40785
|
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))
|
41046
|
773 math-units-table))))))))
|
40785
|
774
|
58508
|
775 ;; The variable math-which-standard is local to math-to-standard-units,
|
|
776 ;; but is used by math-to-standard-rec, which is called by
|
|
777 ;; math-to-standard-units.
|
|
778 (defvar math-which-standard)
|
40785
|
779
|
58508
|
780 (defun math-to-standard-units (expr math-which-standard)
|
41046
|
781 (math-to-standard-rec expr))
|
40785
|
782
|
|
783 (defun math-to-standard-rec (expr)
|
|
784 (if (eq (car-safe expr) 'var)
|
|
785 (let ((u (math-check-unit-name expr))
|
|
786 (base (nth 1 expr)))
|
|
787 (if u
|
|
788 (progn
|
|
789 (if (nth 1 u)
|
|
790 (setq expr (math-to-standard-rec (nth 1 u)))
|
58508
|
791 (let ((st (assq (car u) math-which-standard)))
|
40785
|
792 (if st
|
|
793 (setq expr (nth 1 st))
|
|
794 (setq expr (list 'var (car u)
|
|
795 (intern (concat "var-"
|
|
796 (symbol-name
|
|
797 (car u)))))))))
|
|
798 (or (null u)
|
|
799 (eq base (car u))
|
|
800 (setq expr (list '*
|
|
801 (nth 1 (assq (aref (symbol-name base) 0)
|
|
802 math-unit-prefixes))
|
|
803 expr)))
|
|
804 expr)
|
|
805 (if (eq base 'pi)
|
|
806 (math-pi)
|
|
807 expr)))
|
|
808 (if (Math-primp expr)
|
|
809 expr
|
|
810 (cons (car expr)
|
41046
|
811 (mapcar 'math-to-standard-rec (cdr expr))))))
|
40785
|
812
|
|
813 (defun math-apply-units (expr units ulist &optional pure)
|
64163
f3c30d255a4d
(math-apply-units): Change the places in which units are simplified.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
814 (setq expr (math-simplify-units expr))
|
40785
|
815 (if ulist
|
|
816 (let ((new 0)
|
|
817 value)
|
|
818 (or (math-numberp expr)
|
|
819 (error "Incompatible units"))
|
|
820 (while (cdr ulist)
|
|
821 (setq value (math-div expr (nth 1 (car ulist)))
|
|
822 value (math-floor (let ((calc-internal-prec
|
|
823 (1- calc-internal-prec)))
|
|
824 (math-normalize value)))
|
|
825 new (math-add new (math-mul value (car (car ulist))))
|
|
826 expr (math-sub expr (math-mul value (nth 1 (car ulist))))
|
|
827 ulist (cdr ulist)))
|
|
828 (math-add new (math-mul (math-div expr (nth 1 (car ulist)))
|
|
829 (car (car ulist)))))
|
64163
f3c30d255a4d
(math-apply-units): Change the places in which units are simplified.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
830 (if pure
|
f3c30d255a4d
(math-apply-units): Change the places in which units are simplified.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
831 expr
|
f3c30d255a4d
(math-apply-units): Change the places in which units are simplified.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
832 (math-simplify-units (list '* expr units)))))
|
40785
|
833
|
41269
|
834 (defvar math-decompose-units-cache nil)
|
40785
|
835 (defun math-decompose-units (units)
|
|
836 (let ((u (math-check-unit-name units)))
|
|
837 (and u (eq (car-safe (nth 1 u)) '+)
|
|
838 (setq units (nth 1 u))))
|
|
839 (setq units (calcFunc-expand units))
|
|
840 (and (eq (car-safe units) '+)
|
|
841 (let ((entry (list units calc-internal-prec calc-prefer-frac)))
|
|
842 (or (equal entry (car math-decompose-units-cache))
|
|
843 (let ((ulist nil)
|
|
844 (utemp units)
|
|
845 qty unit)
|
|
846 (while (eq (car-safe utemp) '+)
|
|
847 (setq ulist (cons (math-decompose-unit-part (nth 2 utemp))
|
|
848 ulist)
|
|
849 utemp (nth 1 utemp)))
|
|
850 (setq ulist (cons (math-decompose-unit-part utemp) ulist)
|
|
851 utemp ulist)
|
|
852 (while (setq utemp (cdr utemp))
|
41269
|
853 (unless (equal (nth 2 (car utemp)) (nth 2 (car ulist)))
|
|
854 (error "Inconsistent units in sum")))
|
40785
|
855 (setq math-decompose-units-cache
|
|
856 (cons entry
|
|
857 (sort ulist
|
|
858 (function
|
|
859 (lambda (x y)
|
|
860 (not (Math-lessp (nth 1 x)
|
|
861 (nth 1 y))))))))))
|
41046
|
862 (cdr math-decompose-units-cache))))
|
40785
|
863
|
|
864 (defun math-decompose-unit-part (unit)
|
|
865 (cons unit
|
|
866 (math-is-multiple (math-simplify-units (math-to-standard-units
|
|
867 unit nil))
|
41046
|
868 t)))
|
40785
|
869
|
58508
|
870 ;; The variable math-fcu-u is local to math-find-compatible-unit,
|
|
871 ;; but is used by math-find-compatible-rec which is called by
|
|
872 ;; math-find-compatible-unit.
|
|
873 (defvar math-fcu-u)
|
|
874
|
40785
|
875 (defun math-find-compatible-unit (expr unit)
|
58508
|
876 (let ((math-fcu-u (math-check-unit-name unit)))
|
|
877 (if math-fcu-u
|
41046
|
878 (math-find-compatible-unit-rec expr 1))))
|
40785
|
879
|
|
880 (defun math-find-compatible-unit-rec (expr pow)
|
|
881 (cond ((eq (car-safe expr) '*)
|
|
882 (or (math-find-compatible-unit-rec (nth 1 expr) pow)
|
|
883 (math-find-compatible-unit-rec (nth 2 expr) pow)))
|
|
884 ((eq (car-safe expr) '/)
|
|
885 (or (math-find-compatible-unit-rec (nth 1 expr) pow)
|
|
886 (math-find-compatible-unit-rec (nth 2 expr) (- pow))))
|
|
887 ((and (eq (car-safe expr) '^)
|
|
888 (integerp (nth 2 expr)))
|
|
889 (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr))))
|
|
890 (t
|
|
891 (let ((u2 (math-check-unit-name expr)))
|
58508
|
892 (if (equal (nth 4 math-fcu-u) (nth 4 u2))
|
41046
|
893 (cons expr pow))))))
|
40785
|
894
|
58508
|
895 ;; The variables math-cu-new-units and math-cu-pure are local to
|
|
896 ;; math-convert-units, but are used by math-convert-units-rec,
|
|
897 ;; which is called by math-convert-units.
|
|
898 (defvar math-cu-new-units)
|
|
899 (defvar math-cu-pure)
|
|
900
|
|
901 (defun math-convert-units (expr math-cu-new-units &optional math-cu-pure)
|
40785
|
902 (math-with-extra-prec 2
|
58508
|
903 (let ((compat (and (not math-cu-pure)
|
|
904 (math-find-compatible-unit expr math-cu-new-units)))
|
|
905 (math-cu-unit-list nil)
|
40785
|
906 (math-combining-units nil))
|
|
907 (if compat
|
|
908 (math-simplify-units
|
|
909 (math-mul (math-mul (math-simplify-units
|
|
910 (math-div expr (math-pow (car compat)
|
|
911 (cdr compat))))
|
58508
|
912 (math-pow math-cu-new-units (cdr compat)))
|
40785
|
913 (math-simplify-units
|
|
914 (math-to-standard-units
|
58508
|
915 (math-pow (math-div (car compat) math-cu-new-units)
|
40785
|
916 (cdr compat))
|
|
917 nil))))
|
58508
|
918 (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units))
|
|
919 (setq math-cu-new-units (nth 2 (car math-cu-unit-list))))
|
41269
|
920 (when (eq (car-safe expr) '+)
|
|
921 (setq expr (math-simplify-units expr)))
|
40785
|
922 (if (math-units-in-expr-p expr t)
|
|
923 (math-convert-units-rec expr)
|
|
924 (math-apply-units (math-to-standard-units
|
58508
|
925 (list '/ expr math-cu-new-units) nil)
|
|
926 math-cu-new-units math-cu-unit-list math-cu-pure))))))
|
40785
|
927
|
|
928 (defun math-convert-units-rec (expr)
|
|
929 (if (math-units-in-expr-p expr nil)
|
58508
|
930 (math-apply-units (math-to-standard-units
|
|
931 (list '/ expr math-cu-new-units) nil)
|
|
932 math-cu-new-units math-cu-unit-list math-cu-pure)
|
40785
|
933 (if (Math-primp expr)
|
|
934 expr
|
|
935 (cons (car expr)
|
41046
|
936 (mapcar 'math-convert-units-rec (cdr expr))))))
|
40785
|
937
|
|
938 (defun math-convert-temperature (expr old new &optional pure)
|
|
939 (let* ((units (math-single-units-in-expr-p expr))
|
|
940 (uold (if old
|
|
941 (if (or (null units)
|
|
942 (equal (nth 1 old) (car units)))
|
|
943 (math-check-unit-name old)
|
|
944 (error "Inconsistent temperature units"))
|
|
945 units))
|
|
946 (unew (math-check-unit-name new)))
|
41269
|
947 (unless (and (consp unew) (nth 3 unew))
|
|
948 (error "Not a valid temperature unit"))
|
|
949 (unless (and (consp uold) (nth 3 uold))
|
|
950 (error "Not a pure temperature expression"))
|
40785
|
951 (let ((v (car uold)))
|
|
952 (setq expr (list '/ expr (list 'var v
|
|
953 (intern (concat "var-"
|
|
954 (symbol-name v)))))))
|
|
955 (or (eq (nth 3 uold) (nth 3 unew))
|
|
956 (cond ((eq (nth 3 uold) 'K)
|
|
957 (setq expr (list '- expr '(float 27315 -2)))
|
|
958 (if (eq (nth 3 unew) 'F)
|
|
959 (setq expr (list '+ (list '* expr '(frac 9 5)) 32))))
|
|
960 ((eq (nth 3 uold) 'C)
|
|
961 (if (eq (nth 3 unew) 'F)
|
|
962 (setq expr (list '+ (list '* expr '(frac 9 5)) 32))
|
|
963 (setq expr (list '+ expr '(float 27315 -2)))))
|
|
964 (t
|
|
965 (setq expr (list '* (list '- expr 32) '(frac 5 9)))
|
|
966 (if (eq (nth 3 unew) 'K)
|
|
967 (setq expr (list '+ expr '(float 27315 -2)))))))
|
|
968 (if pure
|
|
969 expr
|
41046
|
970 (list '* expr new))))
|
40785
|
971
|
|
972
|
|
973
|
|
974 (defun math-simplify-units (a)
|
|
975 (let ((math-simplifying-units t)
|
|
976 (calc-matrix-mode 'scalar))
|
41046
|
977 (math-simplify a)))
|
41269
|
978 (defalias 'calcFunc-usimplify 'math-simplify-units)
|
40785
|
979
|
58303
|
980 ;; The function created by math-defsimplify uses the variable
|
|
981 ;; math-simplify-expr, and so is used by functions in math-defsimplify
|
|
982 (defvar math-simplify-expr)
|
|
983
|
40785
|
984 (math-defsimplify (+ -)
|
|
985 (and math-simplifying-units
|
58303
|
986 (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
|
|
987 (let* ((units (math-extract-units (nth 1 math-simplify-expr)))
|
40785
|
988 (ratio (math-simplify (math-to-standard-units
|
58303
|
989 (list '/ (nth 2 math-simplify-expr) units) nil))))
|
40785
|
990 (if (math-units-in-expr-p ratio nil)
|
|
991 (progn
|
58303
|
992 (calc-record-why "*Inconsistent units" math-simplify-expr)
|
|
993 math-simplify-expr)
|
|
994 (list '* (math-add (math-remove-units (nth 1 math-simplify-expr))
|
|
995 (if (eq (car math-simplify-expr) '-)
|
|
996 (math-neg ratio) ratio))
|
41046
|
997 units)))))
|
40785
|
998
|
|
999 (math-defsimplify *
|
41046
|
1000 (math-simplify-units-prod))
|
40785
|
1001
|
|
1002 (defun math-simplify-units-prod ()
|
|
1003 (and math-simplifying-units
|
|
1004 calc-autorange-units
|
58303
|
1005 (Math-realp (nth 1 math-simplify-expr))
|
|
1006 (let* ((num (math-float (nth 1 math-simplify-expr)))
|
40785
|
1007 (xpon (calcFunc-xpon num))
|
58303
|
1008 (unitp (cdr (cdr math-simplify-expr)))
|
40785
|
1009 (unit (car unitp))
|
58303
|
1010 (pow (if (eq (car math-simplify-expr) '*) 1 -1))
|
40785
|
1011 u)
|
|
1012 (and (eq (car-safe unit) '*)
|
|
1013 (setq unitp (cdr unit)
|
|
1014 unit (car unitp)))
|
|
1015 (and (eq (car-safe unit) '^)
|
|
1016 (integerp (nth 2 unit))
|
|
1017 (setq pow (* pow (nth 2 unit))
|
|
1018 unitp (cdr unit)
|
|
1019 unit (car unitp)))
|
|
1020 (and (setq u (math-check-unit-name unit))
|
|
1021 (integerp xpon)
|
|
1022 (or (< xpon 0)
|
|
1023 (>= xpon (if (eq (car u) 'm) 1 3)))
|
|
1024 (let* ((uxpon 0)
|
|
1025 (pref (if (< pow 0)
|
|
1026 (reverse math-unit-prefixes)
|
|
1027 math-unit-prefixes))
|
|
1028 (p pref)
|
|
1029 pxpon pname)
|
|
1030 (or (eq (car u) (nth 1 unit))
|
|
1031 (setq uxpon (* pow
|
|
1032 (nth 2 (nth 1 (assq
|
|
1033 (aref (symbol-name
|
|
1034 (nth 1 unit)) 0)
|
|
1035 math-unit-prefixes))))))
|
|
1036 (setq xpon (+ xpon uxpon))
|
|
1037 (while (and p
|
|
1038 (or (memq (car (car p)) '(?d ?D ?h ?H))
|
|
1039 (and (eq (car (car p)) ?c)
|
|
1040 (not (eq (car u) 'm)))
|
|
1041 (< xpon (setq pxpon (* (nth 2 (nth 1 (car p)))
|
|
1042 pow)))
|
|
1043 (progn
|
|
1044 (setq pname (math-build-var-name
|
|
1045 (if (eq (car (car p)) 0)
|
|
1046 (car u)
|
|
1047 (concat (char-to-string
|
|
1048 (car (car p)))
|
|
1049 (symbol-name
|
|
1050 (car u))))))
|
|
1051 (and (/= (car (car p)) 0)
|
|
1052 (assq (nth 1 pname)
|
|
1053 math-units-table)))))
|
|
1054 (setq p (cdr p)))
|
|
1055 (and p
|
|
1056 (/= pxpon uxpon)
|
|
1057 (or (not (eq p pref))
|
|
1058 (< xpon (+ pxpon (* (math-abs pow) 3))))
|
|
1059 (progn
|
58303
|
1060 (setcar (cdr math-simplify-expr)
|
40785
|
1061 (let ((calc-prefer-frac nil))
|
58303
|
1062 (calcFunc-scf (nth 1 math-simplify-expr)
|
40785
|
1063 (- uxpon pxpon))))
|
|
1064 (setcar unitp pname)
|
58303
|
1065 math-simplify-expr)))))))
|
40785
|
1066
|
58508
|
1067 (defvar math-try-cancel-units)
|
|
1068
|
40785
|
1069 (math-defsimplify /
|
|
1070 (and math-simplifying-units
|
58303
|
1071 (let ((np (cdr math-simplify-expr))
|
58508
|
1072 (math-try-cancel-units 0)
|
40785
|
1073 n nn)
|
58303
|
1074 (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
|
|
1075 (cdr (nth 2 math-simplify-expr))
|
|
1076 (nthcdr 2 math-simplify-expr)))
|
40785
|
1077 (if (math-realp (car n))
|
|
1078 (progn
|
58303
|
1079 (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr)
|
40785
|
1080 (let ((calc-prefer-frac nil))
|
|
1081 (math-div 1 (car n)))))
|
|
1082 (setcar n 1)))
|
|
1083 (while (eq (car-safe (setq n (car np))) '*)
|
58303
|
1084 (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr)))
|
40785
|
1085 (setq np (cdr (cdr n))))
|
58303
|
1086 (math-simplify-units-divisor np (cdr (cdr math-simplify-expr)))
|
58508
|
1087 (if (eq math-try-cancel-units 0)
|
40785
|
1088 (let* ((math-simplifying-units nil)
|
58303
|
1089 (base (math-simplify
|
|
1090 (math-to-standard-units math-simplify-expr nil))))
|
40785
|
1091 (if (Math-numberp base)
|
58303
|
1092 (setq math-simplify-expr base))))
|
|
1093 (if (eq (car-safe math-simplify-expr) '/)
|
40785
|
1094 (math-simplify-units-prod))
|
58303
|
1095 math-simplify-expr)))
|
40785
|
1096
|
|
1097 (defun math-simplify-units-divisor (np dp)
|
|
1098 (let ((n (car np))
|
|
1099 d dd temp)
|
|
1100 (while (eq (car-safe (setq d (car dp))) '*)
|
41269
|
1101 (when (setq temp (math-simplify-units-quotient n (nth 1 d)))
|
|
1102 (setcar np (setq n temp))
|
|
1103 (setcar (cdr d) 1))
|
40785
|
1104 (setq dp (cdr (cdr d))))
|
41269
|
1105 (when (setq temp (math-simplify-units-quotient n d))
|
|
1106 (setcar np (setq n temp))
|
|
1107 (setcar dp 1))))
|
40785
|
1108
|
|
1109 ;; Simplify, e.g., "in / cm" to "2.54" in a units expression.
|
|
1110 (defun math-simplify-units-quotient (n d)
|
|
1111 (let ((pow1 1)
|
|
1112 (pow2 1))
|
41269
|
1113 (when (and (eq (car-safe n) '^)
|
|
1114 (integerp (nth 2 n)))
|
|
1115 (setq pow1 (nth 2 n) n (nth 1 n)))
|
|
1116 (when (and (eq (car-safe d) '^)
|
|
1117 (integerp (nth 2 d)))
|
|
1118 (setq pow2 (nth 2 d) d (nth 1 d)))
|
40785
|
1119 (let ((un (math-check-unit-name n))
|
|
1120 (ud (math-check-unit-name d)))
|
|
1121 (and un ud
|
|
1122 (if (and (equal (nth 4 un) (nth 4 ud))
|
|
1123 (eq pow1 pow2))
|
|
1124 (math-to-standard-units (list '/ n d) nil)
|
|
1125 (let (ud1)
|
|
1126 (setq un (nth 4 un)
|
|
1127 ud (nth 4 ud))
|
|
1128 (while un
|
|
1129 (setq ud1 ud)
|
|
1130 (while ud1
|
|
1131 (and (eq (car (car un)) (car (car ud1)))
|
58508
|
1132 (setq math-try-cancel-units
|
|
1133 (+ math-try-cancel-units
|
40785
|
1134 (- (* (cdr (car un)) pow1)
|
|
1135 (* (cdr (car ud)) pow2)))))
|
|
1136 (setq ud1 (cdr ud1)))
|
|
1137 (setq un (cdr un)))
|
41046
|
1138 nil))))))
|
40785
|
1139
|
|
1140 (math-defsimplify ^
|
|
1141 (and math-simplifying-units
|
58303
|
1142 (math-realp (nth 2 math-simplify-expr))
|
|
1143 (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
|
|
1144 (list (car (nth 1 math-simplify-expr))
|
|
1145 (list '^ (nth 1 (nth 1 math-simplify-expr))
|
|
1146 (nth 2 math-simplify-expr))
|
|
1147 (list '^ (nth 2 (nth 1 math-simplify-expr))
|
|
1148 (nth 2 math-simplify-expr)))
|
|
1149 (math-simplify-units-pow (nth 1 math-simplify-expr)
|
|
1150 (nth 2 math-simplify-expr)))))
|
40785
|
1151
|
|
1152 (math-defsimplify calcFunc-sqrt
|
|
1153 (and math-simplifying-units
|
58303
|
1154 (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
|
|
1155 (list (car (nth 1 math-simplify-expr))
|
|
1156 (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr)))
|
|
1157 (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr))))
|
|
1158 (math-simplify-units-pow (nth 1 math-simplify-expr) '(frac 1 2)))))
|
40785
|
1159
|
|
1160 (math-defsimplify (calcFunc-floor
|
|
1161 calcFunc-ceil
|
|
1162 calcFunc-round
|
|
1163 calcFunc-rounde
|
|
1164 calcFunc-roundu
|
|
1165 calcFunc-trunc
|
|
1166 calcFunc-float
|
|
1167 calcFunc-frac
|
|
1168 calcFunc-abs
|
|
1169 calcFunc-clean)
|
|
1170 (and math-simplifying-units
|
58303
|
1171 (= (length math-simplify-expr) 2)
|
|
1172 (if (math-only-units-in-expr-p (nth 1 math-simplify-expr))
|
|
1173 (nth 1 math-simplify-expr)
|
|
1174 (if (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /))
|
40785
|
1175 (or (math-only-units-in-expr-p
|
58303
|
1176 (nth 1 (nth 1 math-simplify-expr)))
|
40785
|
1177 (math-only-units-in-expr-p
|
58303
|
1178 (nth 2 (nth 1 math-simplify-expr)))))
|
|
1179 (list (car (nth 1 math-simplify-expr))
|
|
1180 (cons (car math-simplify-expr)
|
|
1181 (cons (nth 1 (nth 1 math-simplify-expr))
|
|
1182 (cdr (cdr math-simplify-expr))))
|
|
1183 (cons (car math-simplify-expr)
|
|
1184 (cons (nth 2 (nth 1 math-simplify-expr))
|
|
1185 (cdr (cdr math-simplify-expr)))))))))
|
40785
|
1186
|
|
1187 (defun math-simplify-units-pow (a pow)
|
|
1188 (if (and (eq (car-safe a) '^)
|
|
1189 (math-check-unit-name (nth 1 a))
|
|
1190 (math-realp (nth 2 a)))
|
|
1191 (list '^ (nth 1 a) (math-mul pow (nth 2 a)))
|
|
1192 (let* ((u (math-check-unit-name a))
|
|
1193 (pf (math-to-simple-fraction pow))
|
|
1194 (d (and (eq (car-safe pf) 'frac) (nth 2 pf))))
|
|
1195 (and u d
|
|
1196 (math-units-are-multiple u d)
|
41046
|
1197 (list '^ (math-to-standard-units a nil) pow)))))
|
40785
|
1198
|
|
1199
|
|
1200 (defun math-units-are-multiple (u n)
|
|
1201 (setq u (nth 4 u))
|
|
1202 (while (and u (= (% (cdr (car u)) n) 0))
|
|
1203 (setq u (cdr u)))
|
41046
|
1204 (null u))
|
40785
|
1205
|
|
1206 (math-defsimplify calcFunc-sin
|
|
1207 (and math-simplifying-units
|
58303
|
1208 (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
|
40785
|
1209 (let ((rad (math-simplify-units
|
|
1210 (math-evaluate-expr
|
58303
|
1211 (math-to-standard-units (nth 1 math-simplify-expr) nil))))
|
40785
|
1212 (calc-angle-mode 'rad))
|
|
1213 (and (eq (car-safe rad) '*)
|
|
1214 (math-realp (nth 1 rad))
|
|
1215 (eq (car-safe (nth 2 rad)) 'var)
|
|
1216 (eq (nth 1 (nth 2 rad)) 'rad)
|
41046
|
1217 (list 'calcFunc-sin (nth 1 rad))))))
|
40785
|
1218
|
|
1219 (math-defsimplify calcFunc-cos
|
|
1220 (and math-simplifying-units
|
58303
|
1221 (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
|
40785
|
1222 (let ((rad (math-simplify-units
|
|
1223 (math-evaluate-expr
|
58303
|
1224 (math-to-standard-units (nth 1 math-simplify-expr) nil))))
|
40785
|
1225 (calc-angle-mode 'rad))
|
|
1226 (and (eq (car-safe rad) '*)
|
|
1227 (math-realp (nth 1 rad))
|
|
1228 (eq (car-safe (nth 2 rad)) 'var)
|
|
1229 (eq (nth 1 (nth 2 rad)) 'rad)
|
41046
|
1230 (list 'calcFunc-cos (nth 1 rad))))))
|
40785
|
1231
|
|
1232 (math-defsimplify calcFunc-tan
|
|
1233 (and math-simplifying-units
|
58303
|
1234 (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
|
40785
|
1235 (let ((rad (math-simplify-units
|
|
1236 (math-evaluate-expr
|
58303
|
1237 (math-to-standard-units (nth 1 math-simplify-expr) nil))))
|
40785
|
1238 (calc-angle-mode 'rad))
|
|
1239 (and (eq (car-safe rad) '*)
|
|
1240 (math-realp (nth 1 rad))
|
|
1241 (eq (car-safe (nth 2 rad)) 'var)
|
|
1242 (eq (nth 1 (nth 2 rad)) 'rad)
|
41046
|
1243 (list 'calcFunc-tan (nth 1 rad))))))
|
40785
|
1244
|
60082
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1245 (math-defsimplify calcFunc-sec
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1246 (and math-simplifying-units
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1247 (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1248 (let ((rad (math-simplify-units
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1249 (math-evaluate-expr
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1250 (math-to-standard-units (nth 1 math-simplify-expr) nil))))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1251 (calc-angle-mode 'rad))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1252 (and (eq (car-safe rad) '*)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1253 (math-realp (nth 1 rad))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1254 (eq (car-safe (nth 2 rad)) 'var)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1255 (eq (nth 1 (nth 2 rad)) 'rad)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1256 (list 'calcFunc-sec (nth 1 rad))))))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1257
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1258 (math-defsimplify calcFunc-csc
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1259 (and math-simplifying-units
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1260 (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1261 (let ((rad (math-simplify-units
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1262 (math-evaluate-expr
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1263 (math-to-standard-units (nth 1 math-simplify-expr) nil))))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1264 (calc-angle-mode 'rad))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1265 (and (eq (car-safe rad) '*)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1266 (math-realp (nth 1 rad))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1267 (eq (car-safe (nth 2 rad)) 'var)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1268 (eq (nth 1 (nth 2 rad)) 'rad)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1269 (list 'calcFunc-csc (nth 1 rad))))))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1270
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1271 (math-defsimplify calcFunc-cot
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1272 (and math-simplifying-units
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1273 (math-units-in-expr-p (nth 1 math-simplify-expr) nil)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1274 (let ((rad (math-simplify-units
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1275 (math-evaluate-expr
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1276 (math-to-standard-units (nth 1 math-simplify-expr) nil))))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1277 (calc-angle-mode 'rad))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1278 (and (eq (car-safe rad) '*)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1279 (math-realp (nth 1 rad))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1280 (eq (car-safe (nth 2 rad)) 'var)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1281 (eq (nth 1 (nth 2 rad)) 'rad)
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1282 (list 'calcFunc-cot (nth 1 rad))))))
|
1697c06499c8
Add simplification rules for calcFunc-sec, calcFunc-csc, calcFunc-cot.
Jay Belanger <jay.p.belanger@gmail.com>
diff
changeset
|
1283
|
40785
|
1284
|
|
1285 (defun math-remove-units (expr)
|
|
1286 (if (math-check-unit-name expr)
|
|
1287 1
|
|
1288 (if (Math-primp expr)
|
|
1289 expr
|
|
1290 (cons (car expr)
|
41046
|
1291 (mapcar 'math-remove-units (cdr expr))))))
|
40785
|
1292
|
|
1293 (defun math-extract-units (expr)
|
|
1294 (if (memq (car-safe expr) '(* /))
|
|
1295 (cons (car expr)
|
|
1296 (mapcar 'math-extract-units (cdr expr)))
|
41046
|
1297 (if (math-check-unit-name expr) expr 1)))
|
40785
|
1298
|
|
1299 (defun math-build-units-table-buffer (enter-buffer)
|
|
1300 (if (not (and math-units-table math-units-table-buffer-valid
|
|
1301 (get-buffer "*Units Table*")))
|
|
1302 (let ((buf (get-buffer-create "*Units Table*"))
|
|
1303 (uptr (math-build-units-table))
|
|
1304 (calc-language (if (eq calc-language 'big) nil calc-language))
|
|
1305 (calc-float-format '(float 0))
|
|
1306 (calc-group-digits nil)
|
|
1307 (calc-number-radix 10)
|
|
1308 (calc-point-char ".")
|
|
1309 (std nil)
|
|
1310 u name shadowed)
|
|
1311 (save-excursion
|
|
1312 (message "Formatting units table...")
|
|
1313 (set-buffer buf)
|
62565
|
1314 (let ((inhibit-read-only t))
|
|
1315 (erase-buffer)
|
|
1316 (insert "Calculator Units Table:\n\n")
|
|
1317 (insert "Unit Type Definition Description\n\n")
|
|
1318 (while uptr
|
|
1319 (setq u (car uptr)
|
|
1320 name (nth 2 u))
|
|
1321 (when (eq (car u) 'm)
|
|
1322 (setq std t))
|
|
1323 (setq shadowed (and std (assq (car u) math-additional-units)))
|
|
1324 (when (and name
|
|
1325 (> (length name) 1)
|
|
1326 (eq (aref name 0) ?\*))
|
|
1327 (unless (eq uptr math-units-table)
|
|
1328 (insert "\n"))
|
|
1329 (setq name (substring name 1)))
|
|
1330 (insert " ")
|
|
1331 (and shadowed (insert "("))
|
|
1332 (insert (symbol-name (car u)))
|
|
1333 (and shadowed (insert ")"))
|
|
1334 (if (nth 3 u)
|
|
1335 (progn
|
|
1336 (indent-to 10)
|
|
1337 (insert (symbol-name (nth 3 u))))
|
|
1338 (or std
|
|
1339 (progn
|
|
1340 (indent-to 10)
|
|
1341 (insert "U"))))
|
|
1342 (indent-to 14)
|
|
1343 (and shadowed (insert "("))
|
|
1344 (if (nth 1 u)
|
|
1345 (insert (math-format-value (nth 1 u) 80))
|
|
1346 (insert (symbol-name (car u))))
|
|
1347 (and shadowed (insert ")"))
|
|
1348 (indent-to 41)
|
|
1349 (insert " ")
|
|
1350 (when name
|
|
1351 (insert name))
|
|
1352 (if shadowed
|
|
1353 (insert " (redefined above)")
|
|
1354 (unless (nth 1 u)
|
|
1355 (insert " (base unit)")))
|
|
1356 (insert "\n")
|
|
1357 (setq uptr (cdr uptr)))
|
|
1358 (insert "\n\nUnit Prefix Table:\n\n")
|
|
1359 (setq uptr math-unit-prefixes)
|
|
1360 (while uptr
|
|
1361 (setq u (car uptr))
|
|
1362 (insert " " (char-to-string (car u)))
|
|
1363 (if (equal (nth 1 u) (nth 1 (nth 1 uptr)))
|
|
1364 (insert " " (char-to-string (car (car (setq uptr (cdr uptr)))))
|
|
1365 " ")
|
|
1366 (insert " "))
|
|
1367 (insert "10^" (int-to-string (nth 2 (nth 1 u))))
|
|
1368 (indent-to 15)
|
|
1369 (insert " " (nth 2 u) "\n")
|
|
1370 (while (eq (car (car (setq uptr (cdr uptr)))) 0)))
|
|
1371 (insert "\n"))
|
|
1372 (view-mode)
|
40785
|
1373 (message "Formatting units table...done"))
|
|
1374 (setq math-units-table-buffer-valid t)
|
|
1375 (let ((oldbuf (current-buffer)))
|
|
1376 (set-buffer buf)
|
|
1377 (goto-char (point-min))
|
|
1378 (set-buffer oldbuf))
|
|
1379 (if enter-buffer
|
|
1380 (pop-to-buffer buf)
|
|
1381 (display-buffer buf)))
|
|
1382 (if enter-buffer
|
|
1383 (pop-to-buffer (get-buffer "*Units Table*"))
|
41046
|
1384 (display-buffer (get-buffer "*Units Table*")))))
|
40785
|
1385
|
58677
|
1386 (provide 'calc-units)
|
|
1387
|
45291
|
1388 ;; Local Variables:
|
|
1389 ;; coding: iso-latin-1
|
|
1390 ;; End:
|
|
1391
|
52401
|
1392 ;;; arch-tag: e993314f-3adc-4191-be61-4ef8874881c4
|
41046
|
1393 ;;; calc-units.el ends here
|