Mercurial > emacs
comparison lisp/calc/calc.el @ 58103:5fb84c291168
(math-normalize-a): New variable.
(math-normalize): Use declared variable math-normalize-a.
author | Jay Belanger <jay.p.belanger@gmail.com> |
---|---|
date | Tue, 09 Nov 2004 20:30:10 +0000 |
parents | 3f48c4fde605 |
children | 4a905282edbb cb7f41387eb3 |
comparison
equal
deleted
inserted
replaced
58102:57dc7bb5ee57 | 58103:5fb84c291168 |
---|---|
2230 ;;; [This notation has been neglected in many recent routines.] | 2230 ;;; [This notation has been neglected in many recent routines.] |
2231 | 2231 |
2232 (defvar math-eval-rules-cache) | 2232 (defvar math-eval-rules-cache) |
2233 (defvar math-eval-rules-cache-other) | 2233 (defvar math-eval-rules-cache-other) |
2234 ;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] | 2234 ;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] |
2235 (defun math-normalize (a) | 2235 |
2236 (defvar math-normalize-a) | |
2237 (defun math-normalize (math-normalize-a) | |
2236 (cond | 2238 (cond |
2237 ((not (consp a)) | 2239 ((not (consp math-normalize-a)) |
2238 (if (integerp a) | 2240 (if (integerp math-normalize-a) |
2239 (if (or (>= a 1000000) (<= a -1000000)) | 2241 (if (or (>= math-normalize-a 1000000) (<= math-normalize-a -1000000)) |
2240 (math-bignum a) | 2242 (math-bignum math-normalize-a) |
2241 a) | 2243 math-normalize-a) |
2242 a)) | 2244 math-normalize-a)) |
2243 ((eq (car a) 'bigpos) | 2245 ((eq (car math-normalize-a) 'bigpos) |
2244 (if (eq (nth (1- (length a)) a) 0) | 2246 (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) |
2245 (let* ((last (setq a (copy-sequence a))) (digs a)) | 2247 (let* ((last (setq math-normalize-a |
2248 (copy-sequence math-normalize-a))) (digs math-normalize-a)) | |
2246 (while (setq digs (cdr digs)) | 2249 (while (setq digs (cdr digs)) |
2247 (or (eq (car digs) 0) (setq last digs))) | 2250 (or (eq (car digs) 0) (setq last digs))) |
2248 (setcdr last nil))) | 2251 (setcdr last nil))) |
2249 (if (cdr (cdr (cdr a))) | 2252 (if (cdr (cdr (cdr math-normalize-a))) |
2250 a | 2253 math-normalize-a |
2251 (cond | 2254 (cond |
2252 ((cdr (cdr a)) (+ (nth 1 a) (* (nth 2 a) 1000))) | 2255 ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a) |
2253 ((cdr a) (nth 1 a)) | 2256 (* (nth 2 math-normalize-a) 1000))) |
2257 ((cdr math-normalize-a) (nth 1 math-normalize-a)) | |
2254 (t 0)))) | 2258 (t 0)))) |
2255 ((eq (car a) 'bigneg) | 2259 ((eq (car math-normalize-a) 'bigneg) |
2256 (if (eq (nth (1- (length a)) a) 0) | 2260 (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) |
2257 (let* ((last (setq a (copy-sequence a))) (digs a)) | 2261 (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) |
2262 (digs math-normalize-a)) | |
2258 (while (setq digs (cdr digs)) | 2263 (while (setq digs (cdr digs)) |
2259 (or (eq (car digs) 0) (setq last digs))) | 2264 (or (eq (car digs) 0) (setq last digs))) |
2260 (setcdr last nil))) | 2265 (setcdr last nil))) |
2261 (if (cdr (cdr (cdr a))) | 2266 (if (cdr (cdr (cdr math-normalize-a))) |
2262 a | 2267 math-normalize-a |
2263 (cond | 2268 (cond |
2264 ((cdr (cdr a)) (- (+ (nth 1 a) (* (nth 2 a) 1000)))) | 2269 ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a) |
2265 ((cdr a) (- (nth 1 a))) | 2270 (* (nth 2 math-normalize-a) 1000)))) |
2271 ((cdr math-normalize-a) (- (nth 1 math-normalize-a))) | |
2266 (t 0)))) | 2272 (t 0)))) |
2267 ((eq (car a) 'float) | 2273 ((eq (car math-normalize-a) 'float) |
2268 (math-make-float (math-normalize (nth 1 a)) (nth 2 a))) | 2274 (math-make-float (math-normalize (nth 1 math-normalize-a)) |
2269 ((or (memq (car a) '(frac cplx polar hms date mod sdev intv vec var quote | 2275 (nth 2 math-normalize-a))) |
2270 special-const calcFunc-if calcFunc-lambda | 2276 ((or (memq (car math-normalize-a) |
2271 calcFunc-quote calcFunc-condition | 2277 '(frac cplx polar hms date mod sdev intv vec var quote |
2272 calcFunc-evalto)) | 2278 special-const calcFunc-if calcFunc-lambda |
2273 (integerp (car a)) | 2279 calcFunc-quote calcFunc-condition |
2274 (and (consp (car a)) (not (eq (car (car a)) 'lambda)))) | 2280 calcFunc-evalto)) |
2281 (integerp (car math-normalize-a)) | |
2282 (and (consp (car math-normalize-a)) | |
2283 (not (eq (car (car math-normalize-a)) 'lambda)))) | |
2275 (calc-extensions) | 2284 (calc-extensions) |
2276 (math-normalize-fancy a)) | 2285 (math-normalize-fancy math-normalize-a)) |
2277 (t | 2286 (t |
2278 (or (and calc-simplify-mode | 2287 (or (and calc-simplify-mode |
2279 (calc-extensions) | 2288 (calc-extensions) |
2280 (math-normalize-nonstandard)) | 2289 (math-normalize-nonstandard)) |
2281 (let ((args (mapcar 'math-normalize (cdr a)))) | 2290 (let ((args (mapcar 'math-normalize (cdr math-normalize-a)))) |
2282 (or (condition-case err | 2291 (or (condition-case err |
2283 (let ((func (assq (car a) '( ( + . math-add ) | 2292 (let ((func |
2284 ( - . math-sub ) | 2293 (assq (car math-normalize-a) '( ( + . math-add ) |
2285 ( * . math-mul ) | 2294 ( - . math-sub ) |
2286 ( / . math-div ) | 2295 ( * . math-mul ) |
2287 ( % . math-mod ) | 2296 ( / . math-div ) |
2288 ( ^ . math-pow ) | 2297 ( % . math-mod ) |
2289 ( neg . math-neg ) | 2298 ( ^ . math-pow ) |
2290 ( | . math-concat ) )))) | 2299 ( neg . math-neg ) |
2300 ( | . math-concat ) )))) | |
2291 (or (and var-EvalRules | 2301 (or (and var-EvalRules |
2292 (progn | 2302 (progn |
2293 (or (eq var-EvalRules math-eval-rules-cache-tag) | 2303 (or (eq var-EvalRules math-eval-rules-cache-tag) |
2294 (progn | 2304 (progn |
2295 (calc-extensions) | 2305 (calc-extensions) |
2296 (math-recompile-eval-rules))) | 2306 (math-recompile-eval-rules))) |
2297 (and (or math-eval-rules-cache-other | 2307 (and (or math-eval-rules-cache-other |
2298 (assq (car a) math-eval-rules-cache)) | 2308 (assq (car math-normalize-a) |
2309 math-eval-rules-cache)) | |
2299 (math-apply-rewrites | 2310 (math-apply-rewrites |
2300 (cons (car a) args) | 2311 (cons (car math-normalize-a) args) |
2301 (cdr math-eval-rules-cache) | 2312 (cdr math-eval-rules-cache) |
2302 nil math-eval-rules-cache)))) | 2313 nil math-eval-rules-cache)))) |
2303 (if func | 2314 (if func |
2304 (apply (cdr func) args) | 2315 (apply (cdr func) args) |
2305 (and (or (consp (car a)) | 2316 (and (or (consp (car math-normalize-a)) |
2306 (fboundp (car a)) | 2317 (fboundp (car math-normalize-a)) |
2307 (and (not calc-extensions-loaded) | 2318 (and (not calc-extensions-loaded) |
2308 (calc-extensions) | 2319 (calc-extensions) |
2309 (fboundp (car a)))) | 2320 (fboundp (car math-normalize-a)))) |
2310 (apply (car a) args))))) | 2321 (apply (car math-normalize-a) args))))) |
2311 (wrong-number-of-arguments | 2322 (wrong-number-of-arguments |
2312 (calc-record-why "*Wrong number of arguments" | 2323 (calc-record-why "*Wrong number of arguments" |
2313 (cons (car a) args)) | 2324 (cons (car math-normalize-a) args)) |
2314 nil) | 2325 nil) |
2315 (wrong-type-argument | 2326 (wrong-type-argument |
2316 (or calc-next-why (calc-record-why "Wrong type of argument" | 2327 (or calc-next-why |
2317 (cons (car a) args))) | 2328 (calc-record-why "Wrong type of argument" |
2329 (cons (car math-normalize-a) args))) | |
2318 nil) | 2330 nil) |
2319 (args-out-of-range | 2331 (args-out-of-range |
2320 (calc-record-why "*Argument out of range" (cons (car a) args)) | 2332 (calc-record-why "*Argument out of range" |
2333 (cons (car math-normalize-a) args)) | |
2321 nil) | 2334 nil) |
2322 (inexact-result | 2335 (inexact-result |
2323 (calc-record-why "No exact representation for result" | 2336 (calc-record-why "No exact representation for result" |
2324 (cons (car a) args)) | 2337 (cons (car math-normalize-a) args)) |
2325 nil) | 2338 nil) |
2326 (math-overflow | 2339 (math-overflow |
2327 (calc-record-why "*Floating-point overflow occurred" | 2340 (calc-record-why "*Floating-point overflow occurred" |
2328 (cons (car a) args)) | 2341 (cons (car math-normalize-a) args)) |
2329 nil) | 2342 nil) |
2330 (math-underflow | 2343 (math-underflow |
2331 (calc-record-why "*Floating-point underflow occurred" | 2344 (calc-record-why "*Floating-point underflow occurred" |
2332 (cons (car a) args)) | 2345 (cons (car math-normalize-a) args)) |
2333 nil) | 2346 nil) |
2334 (void-variable | 2347 (void-variable |
2335 (if (eq (nth 1 err) 'var-EvalRules) | 2348 (if (eq (nth 1 err) 'var-EvalRules) |
2336 (progn | 2349 (progn |
2337 (setq var-EvalRules nil) | 2350 (setq var-EvalRules nil) |
2338 (math-normalize (cons (car a) args))) | 2351 (math-normalize (cons (car math-normalize-a) args))) |
2339 (calc-record-why "*Variable is void" (nth 1 err))))) | 2352 (calc-record-why "*Variable is void" (nth 1 err))))) |
2340 (if (consp (car a)) | 2353 (if (consp (car math-normalize-a)) |
2341 (math-dimension-error) | 2354 (math-dimension-error) |
2342 (cons (car a) args)))))))) | 2355 (cons (car math-normalize-a) args)))))))) |
2343 | 2356 |
2344 | 2357 |
2345 | 2358 |
2346 ;;; True if A is a floating-point real or complex number. [P x] [Public] | 2359 ;;; True if A is a floating-point real or complex number. [P x] [Public] |
2347 (defun math-floatp (a) | 2360 (defun math-floatp (a) |