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