Mercurial > emacs
comparison lisp/calc/calc-map.el @ 40785:2fb9d407ae73
Initial import of Calc 2.02f.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Tue, 06 Nov 2001 18:59:06 +0000 |
parents | |
children | 73f364fd8aaa |
comparison
equal
deleted
inserted
replaced
40784:d57f74c55909 | 40785:2fb9d407ae73 |
---|---|
1 ;; Calculator for GNU Emacs, part II [calc-map.el] | |
2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. | |
3 ;; Written by Dave Gillespie, daveg@synaptics.com. | |
4 | |
5 ;; This file is part of GNU Emacs. | |
6 | |
7 ;; GNU Emacs is distributed in the hope that it will be useful, | |
8 ;; but WITHOUT ANY WARRANTY. No author or distributor | |
9 ;; accepts responsibility to anyone for the consequences of using it | |
10 ;; or for whether it serves any particular purpose or works at all, | |
11 ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
12 ;; License for full details. | |
13 | |
14 ;; Everyone is granted permission to copy, modify and redistribute | |
15 ;; GNU Emacs, but only under the conditions described in the | |
16 ;; GNU Emacs General Public License. A copy of this license is | |
17 ;; supposed to have been given to you along with GNU Emacs so you | |
18 ;; can know your rights and responsibilities. It should be in a | |
19 ;; file named COPYING. Among other things, the copyright notice | |
20 ;; and this notice must be preserved on all copies. | |
21 | |
22 | |
23 | |
24 ;; This file is autoloaded from calc-ext.el. | |
25 (require 'calc-ext) | |
26 | |
27 (require 'calc-macs) | |
28 | |
29 (defun calc-Need-calc-map () nil) | |
30 | |
31 | |
32 (defun calc-apply (&optional oper) | |
33 (interactive) | |
34 (calc-wrapper | |
35 (let* ((sel-mode nil) | |
36 (calc-dollar-values (mapcar 'calc-get-stack-element | |
37 (nthcdr calc-stack-top calc-stack))) | |
38 (calc-dollar-used 0) | |
39 (oper (or oper (calc-get-operator "Apply" | |
40 (if (math-vectorp (calc-top 1)) | |
41 (1- (length (calc-top 1))) | |
42 -1)))) | |
43 (expr (calc-top-n (1+ calc-dollar-used)))) | |
44 (message "Working...") | |
45 (calc-set-command-flag 'clear-message) | |
46 (calc-enter-result (1+ calc-dollar-used) | |
47 (concat (substring "apl" 0 (- 4 (length (nth 2 oper)))) | |
48 (nth 2 oper)) | |
49 (list 'calcFunc-apply | |
50 (math-calcFunc-to-var (nth 1 oper)) | |
51 expr)))) | |
52 ) | |
53 | |
54 (defun calc-reduce (&optional oper accum) | |
55 (interactive) | |
56 (calc-wrapper | |
57 (let* ((sel-mode nil) | |
58 (nest (calc-is-hyperbolic)) | |
59 (rev (calc-is-inverse)) | |
60 (nargs (if (and nest (not rev)) 2 1)) | |
61 (calc-dollar-values (mapcar 'calc-get-stack-element | |
62 (nthcdr calc-stack-top calc-stack))) | |
63 (calc-dollar-used 0) | |
64 (calc-mapping-dir (and (not accum) (not nest) "")) | |
65 (oper (or oper (calc-get-operator | |
66 (if nest | |
67 (concat (if accum "Accumulate " "") | |
68 (if rev "Fixed Point" "Nest")) | |
69 (concat (if rev "Inv " "") | |
70 (if accum "Accumulate" "Reduce"))) | |
71 (if nest 1 2))))) | |
72 (message "Working...") | |
73 (calc-set-command-flag 'clear-message) | |
74 (calc-enter-result (+ calc-dollar-used nargs) | |
75 (concat (substring (if nest | |
76 (if rev "fxp" "nst") | |
77 (if accum "acc" "red")) | |
78 0 (- 4 (length (nth 2 oper)))) | |
79 (nth 2 oper)) | |
80 (if nest | |
81 (cons (if rev | |
82 (if accum 'calcFunc-afixp 'calcFunc-fixp) | |
83 (if accum 'calcFunc-anest 'calcFunc-nest)) | |
84 (cons (math-calcFunc-to-var (nth 1 oper)) | |
85 (calc-top-list-n | |
86 nargs (1+ calc-dollar-used)))) | |
87 (list (if accum | |
88 (if rev 'calcFunc-raccum 'calcFunc-accum) | |
89 (intern (concat "calcFunc-" | |
90 (if rev "r" "") | |
91 "reduce" | |
92 calc-mapping-dir))) | |
93 (math-calcFunc-to-var (nth 1 oper)) | |
94 (calc-top-n (1+ calc-dollar-used))))))) | |
95 ) | |
96 | |
97 (defun calc-accumulate (&optional oper) | |
98 (interactive) | |
99 (calc-reduce oper t) | |
100 ) | |
101 | |
102 (defun calc-map (&optional oper) | |
103 (interactive) | |
104 (calc-wrapper | |
105 (let* ((sel-mode nil) | |
106 (calc-dollar-values (mapcar 'calc-get-stack-element | |
107 (nthcdr calc-stack-top calc-stack))) | |
108 (calc-dollar-used 0) | |
109 (calc-mapping-dir "") | |
110 (oper (or oper (calc-get-operator "Map"))) | |
111 (nargs (car oper))) | |
112 (message "Working...") | |
113 (calc-set-command-flag 'clear-message) | |
114 (calc-enter-result (+ nargs calc-dollar-used) | |
115 (concat (substring "map" 0 (- 4 (length (nth 2 oper)))) | |
116 (nth 2 oper)) | |
117 (cons (intern (concat "calcFunc-map" calc-mapping-dir)) | |
118 (cons (math-calcFunc-to-var (nth 1 oper)) | |
119 (calc-top-list-n | |
120 nargs | |
121 (1+ calc-dollar-used))))))) | |
122 ) | |
123 | |
124 (defun calc-map-equation (&optional oper) | |
125 (interactive) | |
126 (calc-wrapper | |
127 (let* ((sel-mode nil) | |
128 (calc-dollar-values (mapcar 'calc-get-stack-element | |
129 (nthcdr calc-stack-top calc-stack))) | |
130 (calc-dollar-used 0) | |
131 (oper (or oper (calc-get-operator "Map-equation"))) | |
132 (nargs (car oper))) | |
133 (message "Working...") | |
134 (calc-set-command-flag 'clear-message) | |
135 (calc-enter-result (+ nargs calc-dollar-used) | |
136 (concat (substring "map" 0 (- 4 (length (nth 2 oper)))) | |
137 (nth 2 oper)) | |
138 (cons (if (calc-is-inverse) | |
139 'calcFunc-mapeqr | |
140 (if (calc-is-hyperbolic) | |
141 'calcFunc-mapeqp 'calcFunc-mapeq)) | |
142 (cons (math-calcFunc-to-var (nth 1 oper)) | |
143 (calc-top-list-n | |
144 nargs | |
145 (1+ calc-dollar-used))))))) | |
146 ) | |
147 | |
148 (defun calc-map-stack () | |
149 "This is meant to be called by calc-keypad mode." | |
150 (interactive) | |
151 (let ((calc-verify-arglist nil)) | |
152 (calc-unread-command ?\$) | |
153 (calc-map)) | |
154 ) | |
155 | |
156 (defun calc-outer-product (&optional oper) | |
157 (interactive) | |
158 (calc-wrapper | |
159 (let* ((sel-mode nil) | |
160 (calc-dollar-values (mapcar 'calc-get-stack-element | |
161 (nthcdr calc-stack-top calc-stack))) | |
162 (calc-dollar-used 0) | |
163 (oper (or oper (calc-get-operator "Outer" 2)))) | |
164 (message "Working...") | |
165 (calc-set-command-flag 'clear-message) | |
166 (calc-enter-result (+ 2 calc-dollar-used) | |
167 (concat (substring "out" 0 (- 4 (length (nth 2 oper)))) | |
168 (nth 2 oper)) | |
169 (cons 'calcFunc-outer | |
170 (cons (math-calcFunc-to-var (nth 1 oper)) | |
171 (calc-top-list-n | |
172 2 (1+ calc-dollar-used))))))) | |
173 ) | |
174 | |
175 (defun calc-inner-product (&optional mul-oper add-oper) | |
176 (interactive) | |
177 (calc-wrapper | |
178 (let* ((sel-mode nil) | |
179 (calc-dollar-values (mapcar 'calc-get-stack-element | |
180 (nthcdr calc-stack-top calc-stack))) | |
181 (calc-dollar-used 0) | |
182 (mul-oper (or mul-oper (calc-get-operator "Inner (Mult)" 2))) | |
183 (mul-used calc-dollar-used) | |
184 (calc-dollar-values (if (> mul-used 0) | |
185 (cdr calc-dollar-values) | |
186 calc-dollar-values)) | |
187 (calc-dollar-used 0) | |
188 (add-oper (or add-oper (calc-get-operator "Inner (Add)" 2)))) | |
189 (message "Working...") | |
190 (calc-set-command-flag 'clear-message) | |
191 (calc-enter-result (+ 2 mul-used calc-dollar-used) | |
192 (concat "in" | |
193 (substring (nth 2 mul-oper) 0 1) | |
194 (substring (nth 2 add-oper) 0 1)) | |
195 (nconc (list 'calcFunc-inner | |
196 (math-calcFunc-to-var (nth 1 mul-oper)) | |
197 (math-calcFunc-to-var (nth 1 add-oper))) | |
198 (calc-top-list-n | |
199 2 (+ 1 mul-used calc-dollar-used)))))) | |
200 ) | |
201 | |
202 ;;; Return a list of the form (nargs func name) | |
203 (defun calc-get-operator (msg &optional nargs) | |
204 (setq calc-aborted-prefix nil) | |
205 (let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil) | |
206 done key oper (which 0) | |
207 (msgs '( "(Press ? for help)" | |
208 "+, -, *, /, ^, %, \\, :, &, !, |, Neg" | |
209 "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt" | |
210 "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB" | |
211 "Algebra + Simp, Esimp, Deriv, Integ, !, =, etc." | |
212 "Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip" | |
213 "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction" | |
214 "Functions + Re, Im; Hypot; Mant, Expon, Scale; etc." | |
215 "Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc." | |
216 "Time/date + newYear, Incmonth, etc." | |
217 "Vectors + Length, Row, Col, Diag, Mask, etc." | |
218 "_ = mapr/reducea, : = mapc/reduced, = = reducer" | |
219 "X or Z = any function by name; ' = alg entry; $ = stack"))) | |
220 (while (not done) | |
221 (message "%s%s: %s: %s%s%s" | |
222 msg | |
223 (cond ((equal calc-mapping-dir "r") " rows") | |
224 ((equal calc-mapping-dir "c") " columns") | |
225 ((equal calc-mapping-dir "a") " across") | |
226 ((equal calc-mapping-dir "d") " down") | |
227 (t "")) | |
228 (if forcenargs | |
229 (format "(%d arg%s)" | |
230 forcenargs (if (= forcenargs 1) "" "s")) | |
231 (nth which msgs)) | |
232 (if inv "Inv " "") (if hyp "Hyp " "") | |
233 (if prefix (concat (char-to-string prefix) "-") "")) | |
234 (setq key (read-char)) | |
235 (if (>= key 128) (setq key (- key 128))) | |
236 (cond ((memq key '(?\C-g ?q)) | |
237 (keyboard-quit)) | |
238 ((memq key '(?\C-u ?\e))) | |
239 ((= key ??) | |
240 (setq which (% (1+ which) (length msgs)))) | |
241 ((and (= key ?I) (null prefix)) | |
242 (setq inv (not inv))) | |
243 ((and (= key ?H) (null prefix)) | |
244 (setq hyp (not hyp))) | |
245 ((and (eq key prefix) (not (eq key ?v))) | |
246 (setq prefix nil)) | |
247 ((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V)) | |
248 (null prefix)) | |
249 (setq prefix (downcase key))) | |
250 ((and (eq key ?\=) (null prefix)) | |
251 (if calc-mapping-dir | |
252 (setq calc-mapping-dir (if (equal calc-mapping-dir "r") | |
253 "" "r")) | |
254 (beep))) | |
255 ((and (eq key ?\_) (null prefix)) | |
256 (if calc-mapping-dir | |
257 (if (string-match "map$" msg) | |
258 (setq calc-mapping-dir (if (equal calc-mapping-dir "r") | |
259 "" "r")) | |
260 (setq calc-mapping-dir (if (equal calc-mapping-dir "a") | |
261 "" "a"))) | |
262 (beep))) | |
263 ((and (eq key ?\:) (null prefix)) | |
264 (if calc-mapping-dir | |
265 (if (string-match "map$" msg) | |
266 (setq calc-mapping-dir (if (equal calc-mapping-dir "c") | |
267 "" "c")) | |
268 (setq calc-mapping-dir (if (equal calc-mapping-dir "d") | |
269 "" "d"))) | |
270 (beep))) | |
271 ((and (>= key ?0) (<= key ?9) (null prefix)) | |
272 (setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0))) | |
273 (and nargs forcenargs (/= nargs forcenargs) (>= nargs 0) | |
274 (error "Must be a %d-argument operator" nargs))) | |
275 ((memq key '(?\$ ?\')) | |
276 (let* ((arglist nil) | |
277 (has-args nil) | |
278 (record-entry nil) | |
279 (expr (if (eq key ?\$) | |
280 (progn | |
281 (setq calc-dollar-used 1) | |
282 (if calc-dollar-values | |
283 (car calc-dollar-values) | |
284 (error "Stack underflow"))) | |
285 (let* ((calc-dollar-values calc-arg-values) | |
286 (calc-dollar-used 0) | |
287 (calc-hashes-used 0) | |
288 (func (calc-do-alg-entry "" "Function: "))) | |
289 (setq record-entry t) | |
290 (or (= (length func) 1) | |
291 (error "Bad format")) | |
292 (if (> calc-dollar-used 0) | |
293 (progn | |
294 (setq has-args calc-dollar-used | |
295 arglist (calc-invent-args has-args)) | |
296 (math-multi-subst (car func) | |
297 (reverse arglist) | |
298 arglist)) | |
299 (if (> calc-hashes-used 0) | |
300 (setq has-args calc-hashes-used | |
301 arglist (calc-invent-args has-args))) | |
302 (car func)))))) | |
303 (if (eq (car-safe expr) 'calcFunc-lambda) | |
304 (setq oper (list "$" (- (length expr) 2) expr) | |
305 done t) | |
306 (or has-args | |
307 (progn | |
308 (calc-default-formula-arglist expr) | |
309 (setq record-entry t | |
310 arglist (sort arglist 'string-lessp)) | |
311 (if calc-verify-arglist | |
312 (setq arglist (read-from-minibuffer | |
313 "Function argument list: " | |
314 (if arglist | |
315 (prin1-to-string arglist) | |
316 "()") | |
317 minibuffer-local-map | |
318 t))) | |
319 (setq arglist (mapcar (function | |
320 (lambda (x) | |
321 (list 'var | |
322 x | |
323 (intern | |
324 (concat | |
325 "var-" | |
326 (symbol-name x)))))) | |
327 arglist)))) | |
328 (setq oper (list "$" | |
329 (length arglist) | |
330 (append '(calcFunc-lambda) arglist | |
331 (list expr))) | |
332 done t)) | |
333 (if record-entry | |
334 (calc-record (nth 2 oper) "oper")))) | |
335 ((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0)) | |
336 (if prefix | |
337 (symbol-value | |
338 (intern (format "calc-%c-oper-keys" | |
339 prefix))) | |
340 calc-oper-keys)))) | |
341 (if (eq (nth 1 oper) 'user) | |
342 (let ((func (intern | |
343 (completing-read "Function name: " | |
344 obarray 'fboundp | |
345 nil "calcFunc-")))) | |
346 (if (or forcenargs nargs) | |
347 (setq oper (list "z" (or forcenargs nargs) func) | |
348 done t) | |
349 (if (fboundp func) | |
350 (let* ((defn (symbol-function func))) | |
351 (and (symbolp defn) | |
352 (setq defn (symbol-function defn))) | |
353 (if (eq (car-safe defn) 'lambda) | |
354 (let ((args (nth 1 defn)) | |
355 (nargs 0)) | |
356 (while (not (memq (car args) '(&optional | |
357 &rest nil))) | |
358 (setq nargs (1+ nargs) | |
359 args (cdr args))) | |
360 (setq oper (list "z" nargs func) | |
361 done t)) | |
362 (error | |
363 "Function is not suitable for this operation"))) | |
364 (message "Number of arguments: ") | |
365 (let ((nargs (read-char))) | |
366 (if (and (>= nargs ?0) (<= nargs ?9)) | |
367 (setq oper (list "z" (- nargs ?0) func) | |
368 done t) | |
369 (beep)))))) | |
370 (if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U))) | |
371 (and (eq prefix ?a) (eq key ?M))) | |
372 (let* ((dir (cond ((and (equal calc-mapping-dir "") | |
373 (string-match "map$" msg)) | |
374 (setq calc-mapping-dir "r") | |
375 " rows") | |
376 ((equal calc-mapping-dir "r") " rows") | |
377 ((equal calc-mapping-dir "c") " columns") | |
378 ((equal calc-mapping-dir "a") " across") | |
379 ((equal calc-mapping-dir "d") " down") | |
380 (t ""))) | |
381 (calc-mapping-dir (and (memq (nth 2 oper) | |
382 '(calcFunc-map | |
383 calcFunc-reduce | |
384 calcFunc-rreduce)) | |
385 "")) | |
386 (oper2 (calc-get-operator | |
387 (format "%s%s, %s%s" msg dir | |
388 (substring (symbol-name (nth 2 oper)) | |
389 9) | |
390 (if (eq key ?I) " (mult)" "")) | |
391 (cdr (assq (nth 2 oper) | |
392 '((calcFunc-reduce . 2) | |
393 (calcFunc-rreduce . 2) | |
394 (calcFunc-accum . 2) | |
395 (calcFunc-raccum . 2) | |
396 (calcFunc-nest . 2) | |
397 (calcFunc-anest . 2) | |
398 (calcFunc-fixp . 2) | |
399 (calcFunc-afixp . 2)))))) | |
400 (oper3 (if (eq (nth 2 oper) 'calcFunc-inner) | |
401 (calc-get-operator | |
402 (format "%s%s, inner (add)" msg dir | |
403 (substring | |
404 (symbol-name (nth 2 oper)) | |
405 9))) | |
406 '(0 0 0))) | |
407 (args nil) | |
408 (nargs (if (> (nth 1 oper) 0) | |
409 (nth 1 oper) | |
410 (car oper2))) | |
411 (n nargs) | |
412 (p calc-arg-values)) | |
413 (while (and p (> n 0)) | |
414 (or (math-expr-contains (nth 1 oper2) (car p)) | |
415 (math-expr-contains (nth 1 oper3) (car p)) | |
416 (setq args (nconc args (list (car p))) | |
417 n (1- n))) | |
418 (setq p (cdr p))) | |
419 (setq oper (list "" nargs | |
420 (append | |
421 '(calcFunc-lambda) | |
422 args | |
423 (list (math-build-call | |
424 (intern | |
425 (concat | |
426 (symbol-name (nth 2 oper)) | |
427 calc-mapping-dir)) | |
428 (cons (math-calcFunc-to-var | |
429 (nth 1 oper2)) | |
430 (if (eq key ?I) | |
431 (cons | |
432 (math-calcFunc-to-var | |
433 (nth 1 oper3)) | |
434 args) | |
435 args)))))) | |
436 done t)) | |
437 (setq done t)))) | |
438 (t (beep)))) | |
439 (and nargs (>= nargs 0) | |
440 (/= nargs (nth 1 oper)) | |
441 (error "Must be a %d-argument operator" nargs)) | |
442 (append (if forcenargs | |
443 (cons forcenargs (cdr (cdr oper))) | |
444 (cdr oper)) | |
445 (list | |
446 (let ((name (concat (if inv "I" "") (if hyp "H" "") | |
447 (if prefix (char-to-string prefix) "") | |
448 (char-to-string key)))) | |
449 (if (> (length name) 3) | |
450 (substring name 0 3) | |
451 name))))) | |
452 ) | |
453 (setq calc-verify-arglist t) | |
454 (setq calc-mapping-dir nil) | |
455 | |
456 (defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add ) | |
457 ( ?- 2 calcFunc-sub ) | |
458 ( ?* 2 calcFunc-mul ) | |
459 ( ?/ 2 calcFunc-div ) | |
460 ( ?^ 2 calcFunc-pow ) | |
461 ( ?| 2 calcFunc-vconcat ) | |
462 ( ?% 2 calcFunc-mod ) | |
463 ( ?\\ 2 calcFunc-idiv ) | |
464 ( ?! 1 calcFunc-fact ) | |
465 ( ?& 1 calcFunc-inv ) | |
466 ( ?n 1 calcFunc-neg ) | |
467 ( ?x user ) | |
468 ( ?z user ) | |
469 ( ?A 1 calcFunc-abs ) | |
470 ( ?J 1 calcFunc-conj ) | |
471 ( ?G 1 calcFunc-arg ) | |
472 ( ?Q 1 calcFunc-sqrt ) | |
473 ( ?N 2 calcFunc-min ) | |
474 ( ?X 2 calcFunc-max ) | |
475 ( ?F 1 calcFunc-floor ) | |
476 ( ?R 1 calcFunc-round ) | |
477 ( ?S 1 calcFunc-sin ) | |
478 ( ?C 1 calcFunc-cos ) | |
479 ( ?T 1 calcFunc-tan ) | |
480 ( ?L 1 calcFunc-ln ) | |
481 ( ?E 1 calcFunc-exp ) | |
482 ( ?B 2 calcFunc-log ) ) | |
483 ( ( ?F 1 calcFunc-ceil ) ; inverse | |
484 ( ?R 1 calcFunc-trunc ) | |
485 ( ?Q 1 calcFunc-sqr ) | |
486 ( ?S 1 calcFunc-arcsin ) | |
487 ( ?C 1 calcFunc-arccos ) | |
488 ( ?T 1 calcFunc-arctan ) | |
489 ( ?L 1 calcFunc-exp ) | |
490 ( ?E 1 calcFunc-ln ) | |
491 ( ?B 2 calcFunc-alog ) | |
492 ( ?^ 2 calcFunc-nroot ) | |
493 ( ?| 2 calcFunc-vconcatrev ) ) | |
494 ( ( ?F 1 calcFunc-ffloor ) ; hyperbolic | |
495 ( ?R 1 calcFunc-fround ) | |
496 ( ?S 1 calcFunc-sinh ) | |
497 ( ?C 1 calcFunc-cosh ) | |
498 ( ?T 1 calcFunc-tanh ) | |
499 ( ?L 1 calcFunc-log10 ) | |
500 ( ?E 1 calcFunc-exp10 ) | |
501 ( ?| 2 calcFunc-append ) ) | |
502 ( ( ?F 1 calcFunc-fceil ) ; inverse-hyperbolic | |
503 ( ?R 1 calcFunc-ftrunc ) | |
504 ( ?S 1 calcFunc-arcsinh ) | |
505 ( ?C 1 calcFunc-arccosh ) | |
506 ( ?T 1 calcFunc-arctanh ) | |
507 ( ?L 1 calcFunc-exp10 ) | |
508 ( ?E 1 calcFunc-log10 ) | |
509 ( ?| 2 calcFunc-appendrev ) ) | |
510 )) | |
511 (defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart ) | |
512 ( ?b 3 calcFunc-subst ) | |
513 ( ?c 2 calcFunc-collect ) | |
514 ( ?d 2 calcFunc-deriv ) | |
515 ( ?e 1 calcFunc-esimplify ) | |
516 ( ?f 2 calcFunc-factor ) | |
517 ( ?g 2 calcFunc-pgcd ) | |
518 ( ?i 2 calcFunc-integ ) | |
519 ( ?m 2 calcFunc-match ) | |
520 ( ?n 1 calcFunc-nrat ) | |
521 ( ?r 2 calcFunc-rewrite ) | |
522 ( ?s 1 calcFunc-simplify ) | |
523 ( ?t 3 calcFunc-taylor ) | |
524 ( ?x 1 calcFunc-expand ) | |
525 ( ?M 2 calcFunc-mapeq ) | |
526 ( ?N 3 calcFunc-minimize ) | |
527 ( ?P 2 calcFunc-roots ) | |
528 ( ?R 3 calcFunc-root ) | |
529 ( ?S 2 calcFunc-solve ) | |
530 ( ?T 4 calcFunc-table ) | |
531 ( ?X 3 calcFunc-maximize ) | |
532 ( ?= 2 calcFunc-eq ) | |
533 ( ?\# 2 calcFunc-neq ) | |
534 ( ?< 2 calcFunc-lt ) | |
535 ( ?> 2 calcFunc-gt ) | |
536 ( ?\[ 2 calcFunc-leq ) | |
537 ( ?\] 2 calcFunc-geq ) | |
538 ( ?{ 2 calcFunc-in ) | |
539 ( ?! 1 calcFunc-lnot ) | |
540 ( ?& 2 calcFunc-land ) | |
541 ( ?\| 2 calcFunc-lor ) | |
542 ( ?: 3 calcFunc-if ) | |
543 ( ?. 2 calcFunc-rmeq ) | |
544 ( ?+ 4 calcFunc-sum ) | |
545 ( ?- 4 calcFunc-asum ) | |
546 ( ?* 4 calcFunc-prod ) | |
547 ( ?_ 2 calcFunc-subscr ) | |
548 ( ?\\ 2 calcFunc-pdiv ) | |
549 ( ?% 2 calcFunc-prem ) | |
550 ( ?/ 2 calcFunc-pdivrem ) ) | |
551 ( ( ?m 2 calcFunc-matchnot ) | |
552 ( ?M 2 calcFunc-mapeqr ) | |
553 ( ?S 2 calcFunc-finv ) ) | |
554 ( ( ?d 2 calcFunc-tderiv ) | |
555 ( ?f 2 calcFunc-factors ) | |
556 ( ?M 2 calcFunc-mapeqp ) | |
557 ( ?N 3 calcFunc-wminimize ) | |
558 ( ?R 3 calcFunc-wroot ) | |
559 ( ?S 2 calcFunc-fsolve ) | |
560 ( ?X 3 calcFunc-wmaximize ) | |
561 ( ?/ 2 calcFunc-pdivide ) ) | |
562 ( ( ?S 2 calcFunc-ffinv ) ) | |
563 )) | |
564 (defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and ) | |
565 ( ?o 2 calcFunc-or ) | |
566 ( ?x 2 calcFunc-xor ) | |
567 ( ?d 2 calcFunc-diff ) | |
568 ( ?n 1 calcFunc-not ) | |
569 ( ?c 1 calcFunc-clip ) | |
570 ( ?l 2 calcFunc-lsh ) | |
571 ( ?r 2 calcFunc-rsh ) | |
572 ( ?L 2 calcFunc-ash ) | |
573 ( ?R 2 calcFunc-rash ) | |
574 ( ?t 2 calcFunc-rot ) | |
575 ( ?p 1 calcFunc-vpack ) | |
576 ( ?u 1 calcFunc-vunpack ) | |
577 ( ?D 4 calcFunc-ddb ) | |
578 ( ?F 3 calcFunc-fv ) | |
579 ( ?I 1 calcFunc-irr ) | |
580 ( ?M 3 calcFunc-pmt ) | |
581 ( ?N 2 calcFunc-npv ) | |
582 ( ?P 3 calcFunc-pv ) | |
583 ( ?S 3 calcFunc-sln ) | |
584 ( ?T 3 calcFunc-rate ) | |
585 ( ?Y 4 calcFunc-syd ) | |
586 ( ?\# 3 calcFunc-nper ) | |
587 ( ?\% 2 calcFunc-relch ) ) | |
588 ( ( ?F 3 calcFunc-fvb ) | |
589 ( ?I 1 calcFunc-irrb ) | |
590 ( ?M 3 calcFunc-pmtb ) | |
591 ( ?N 2 calcFunc-npvb ) | |
592 ( ?P 3 calcFunc-pvb ) | |
593 ( ?T 3 calcFunc-rateb ) | |
594 ( ?\# 3 calcFunc-nperb ) ) | |
595 ( ( ?F 3 calcFunc-fvl ) | |
596 ( ?M 3 calcFunc-pmtl ) | |
597 ( ?P 3 calcFunc-pvl ) | |
598 ( ?T 3 calcFunc-ratel ) | |
599 ( ?\# 3 calcFunc-nperl ) ) | |
600 )) | |
601 (defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg ) | |
602 ( ?r 1 calcFunc-rad ) | |
603 ( ?h 1 calcFunc-hms ) | |
604 ( ?f 1 calcFunc-float ) | |
605 ( ?F 1 calcFunc-frac ) ) | |
606 )) | |
607 (defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta ) | |
608 ( ?e 1 calcFunc-erf ) | |
609 ( ?g 1 calcFunc-gamma ) | |
610 ( ?h 2 calcFunc-hypot ) | |
611 ( ?i 1 calcFunc-im ) | |
612 ( ?j 2 calcFunc-besJ ) | |
613 ( ?n 2 calcFunc-min ) | |
614 ( ?r 1 calcFunc-re ) | |
615 ( ?s 1 calcFunc-sign ) | |
616 ( ?x 2 calcFunc-max ) | |
617 ( ?y 2 calcFunc-besY ) | |
618 ( ?A 1 calcFunc-abssqr ) | |
619 ( ?B 3 calcFunc-betaI ) | |
620 ( ?E 1 calcFunc-expm1 ) | |
621 ( ?G 2 calcFunc-gammaP ) | |
622 ( ?I 2 calcFunc-ilog ) | |
623 ( ?L 1 calcFunc-lnp1 ) | |
624 ( ?M 1 calcFunc-mant ) | |
625 ( ?Q 1 calcFunc-isqrt ) | |
626 ( ?S 1 calcFunc-scf ) | |
627 ( ?T 2 calcFunc-arctan2 ) | |
628 ( ?X 1 calcFunc-xpon ) | |
629 ( ?\[ 2 calcFunc-decr ) | |
630 ( ?\] 2 calcFunc-incr ) ) | |
631 ( ( ?e 1 calcFunc-erfc ) | |
632 ( ?E 1 calcFunc-lnp1 ) | |
633 ( ?G 2 calcFunc-gammaQ ) | |
634 ( ?L 1 calcFunc-expm1 ) ) | |
635 ( ( ?B 3 calcFunc-betaB ) | |
636 ( ?G 2 calcFunc-gammag) ) | |
637 ( ( ?G 2 calcFunc-gammaG ) ) | |
638 )) | |
639 (defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern ) | |
640 ( ?c 2 calcFunc-choose ) | |
641 ( ?d 1 calcFunc-dfact ) | |
642 ( ?e 1 calcFunc-euler ) | |
643 ( ?f 1 calcFunc-prfac ) | |
644 ( ?g 2 calcFunc-gcd ) | |
645 ( ?h 2 calcFunc-shuffle ) | |
646 ( ?l 2 calcFunc-lcm ) | |
647 ( ?m 1 calcFunc-moebius ) | |
648 ( ?n 1 calcFunc-nextprime ) | |
649 ( ?r 1 calcFunc-random ) | |
650 ( ?s 2 calcFunc-stir1 ) | |
651 ( ?t 1 calcFunc-totient ) | |
652 ( ?B 3 calcFunc-utpb ) | |
653 ( ?C 2 calcFunc-utpc ) | |
654 ( ?F 3 calcFunc-utpf ) | |
655 ( ?N 3 calcFunc-utpn ) | |
656 ( ?P 2 calcFunc-utpp ) | |
657 ( ?T 2 calcFunc-utpt ) ) | |
658 ( ( ?n 1 calcFunc-prevprime ) | |
659 ( ?B 3 calcFunc-ltpb ) | |
660 ( ?C 2 calcFunc-ltpc ) | |
661 ( ?F 3 calcFunc-ltpf ) | |
662 ( ?N 3 calcFunc-ltpn ) | |
663 ( ?P 2 calcFunc-ltpp ) | |
664 ( ?T 2 calcFunc-ltpt ) ) | |
665 ( ( ?b 2 calcFunc-bern ) | |
666 ( ?c 2 calcFunc-perm ) | |
667 ( ?e 2 calcFunc-euler ) | |
668 ( ?s 2 calcFunc-stir2 ) ) | |
669 )) | |
670 (defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign ) | |
671 ( ?= 1 calcFunc-evalto ) ) | |
672 )) | |
673 (defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv ) | |
674 ( ?D 1 calcFunc-date ) | |
675 ( ?I 2 calcFunc-incmonth ) | |
676 ( ?J 1 calcFunc-julian ) | |
677 ( ?M 1 calcFunc-newmonth ) | |
678 ( ?W 1 calcFunc-newweek ) | |
679 ( ?U 1 calcFunc-unixtime ) | |
680 ( ?Y 1 calcFunc-newyear ) ) | |
681 )) | |
682 (defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov ) | |
683 ( ?G 1 calcFunc-vgmean ) | |
684 ( ?M 1 calcFunc-vmean ) | |
685 ( ?N 1 calcFunc-vmin ) | |
686 ( ?S 1 calcFunc-vsdev ) | |
687 ( ?X 1 calcFunc-vmax ) ) | |
688 ( ( ?C 2 calcFunc-vpcov ) | |
689 ( ?M 1 calcFunc-vmeane ) | |
690 ( ?S 1 calcFunc-vpsdev ) ) | |
691 ( ( ?C 2 calcFunc-vcorr ) | |
692 ( ?G 1 calcFunc-agmean ) | |
693 ( ?M 1 calcFunc-vmedian ) | |
694 ( ?S 1 calcFunc-vvar ) ) | |
695 ( ( ?M 1 calcFunc-vhmean ) | |
696 ( ?S 1 calcFunc-vpvar ) ) | |
697 )) | |
698 (defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange ) | |
699 ( ?b 2 calcFunc-cvec ) | |
700 ( ?c 2 calcFunc-mcol ) | |
701 ( ?d 2 calcFunc-diag ) | |
702 ( ?e 2 calcFunc-vexp ) | |
703 ( ?f 2 calcFunc-find ) | |
704 ( ?h 1 calcFunc-head ) | |
705 ( ?k 2 calcFunc-cons ) | |
706 ( ?l 1 calcFunc-vlen ) | |
707 ( ?m 2 calcFunc-vmask ) | |
708 ( ?n 1 calcFunc-rnorm ) | |
709 ( ?p 2 calcFunc-pack ) | |
710 ( ?r 2 calcFunc-mrow ) | |
711 ( ?s 3 calcFunc-subvec ) | |
712 ( ?t 1 calcFunc-trn ) | |
713 ( ?u 1 calcFunc-unpack ) | |
714 ( ?v 1 calcFunc-rev ) | |
715 ( ?x 1 calcFunc-index ) | |
716 ( ?A 1 calcFunc-apply ) | |
717 ( ?C 1 calcFunc-cross ) | |
718 ( ?D 1 calcFunc-det ) | |
719 ( ?E 1 calcFunc-venum ) | |
720 ( ?F 1 calcFunc-vfloor ) | |
721 ( ?G 1 calcFunc-grade ) | |
722 ( ?H 2 calcFunc-histogram ) | |
723 ( ?I 2 calcFunc-inner ) | |
724 ( ?L 1 calcFunc-lud ) | |
725 ( ?M 0 calcFunc-map ) | |
726 ( ?N 1 calcFunc-cnorm ) | |
727 ( ?O 2 calcFunc-outer ) | |
728 ( ?R 1 calcFunc-reduce ) | |
729 ( ?S 1 calcFunc-sort ) | |
730 ( ?T 1 calcFunc-tr ) | |
731 ( ?U 1 calcFunc-accum ) | |
732 ( ?V 2 calcFunc-vunion ) | |
733 ( ?X 2 calcFunc-vxor ) | |
734 ( ?- 2 calcFunc-vdiff ) | |
735 ( ?^ 2 calcFunc-vint ) | |
736 ( ?~ 1 calcFunc-vcompl ) | |
737 ( ?# 1 calcFunc-vcard ) | |
738 ( ?: 1 calcFunc-vspan ) | |
739 ( ?+ 1 calcFunc-rdup ) ) | |
740 ( ( ?h 1 calcFunc-tail ) | |
741 ( ?s 3 calcFunc-rsubvec ) | |
742 ( ?G 1 calcFunc-rgrade ) | |
743 ( ?R 1 calcFunc-rreduce ) | |
744 ( ?S 1 calcFunc-rsort ) | |
745 ( ?U 1 calcFunc-raccum ) ) | |
746 ( ( ?e 3 calcFunc-vexp ) | |
747 ( ?h 1 calcFunc-rhead ) | |
748 ( ?k 2 calcFunc-rcons ) | |
749 ( ?H 3 calcFunc-histogram ) | |
750 ( ?R 2 calcFunc-nest ) | |
751 ( ?U 2 calcFunc-anest ) ) | |
752 ( ( ?h 1 calcFunc-rtail ) | |
753 ( ?R 1 calcFunc-fixp ) | |
754 ( ?U 1 calcFunc-afixp ) ) | |
755 )) | |
756 | |
757 | |
758 ;;; Convert a variable name (as a formula) into a like-looking function name. | |
759 (defun math-var-to-calcFunc (f) | |
760 (if (eq (car-safe f) 'var) | |
761 (if (fboundp (nth 2 f)) | |
762 (nth 2 f) | |
763 (intern (concat "calcFunc-" (symbol-name (nth 1 f))))) | |
764 (if (memq (car-safe f) '(lambda calcFunc-lambda)) | |
765 f | |
766 (math-reject-arg f "*Expected a function name"))) | |
767 ) | |
768 | |
769 ;;; Convert a function name into a like-looking variable name formula. | |
770 (defun math-calcFunc-to-var (f) | |
771 (if (symbolp f) | |
772 (let* ((func (or (cdr (assq f '( ( + . calcFunc-add ) | |
773 ( - . calcFunc-sub ) | |
774 ( * . calcFunc-mul ) | |
775 ( / . calcFunc-div ) | |
776 ( ^ . calcFunc-pow ) | |
777 ( % . calcFunc-mod ) | |
778 ( neg . calcFunc-neg ) | |
779 ( | . calcFunc-vconcat ) ))) | |
780 f)) | |
781 (base (if (string-match "\\`calcFunc-\\(.+\\)\\'" | |
782 (symbol-name func)) | |
783 (math-match-substring (symbol-name func) 1) | |
784 (symbol-name func)))) | |
785 (list 'var | |
786 (intern base) | |
787 (intern (concat "var-" base)))) | |
788 f) | |
789 ) | |
790 | |
791 ;;; Expand a function call using "lambda" notation. | |
792 (defun math-build-call (f args) | |
793 (if (eq (car-safe f) 'calcFunc-lambda) | |
794 (if (= (length args) (- (length f) 2)) | |
795 (math-multi-subst (nth (1- (length f)) f) (cdr f) args) | |
796 (calc-record-why "*Wrong number of arguments" f) | |
797 (cons 'calcFunc-call (cons (math-calcFunc-to-var f) args))) | |
798 (if (and (eq f 'calcFunc-neg) | |
799 (= (length args) 1)) | |
800 (list 'neg (car args)) | |
801 (let ((func (assq f '( ( calcFunc-add . + ) | |
802 ( calcFunc-sub . - ) | |
803 ( calcFunc-mul . * ) | |
804 ( calcFunc-div . / ) | |
805 ( calcFunc-pow . ^ ) | |
806 ( calcFunc-mod . % ) | |
807 ( calcFunc-vconcat . | ) )))) | |
808 (if (and func (= (length args) 2)) | |
809 (cons (cdr func) args) | |
810 (cons f args))))) | |
811 ) | |
812 | |
813 ;;; Do substitutions in parallel to avoid crosstalk. | |
814 (defun math-multi-subst (expr olds news) | |
815 (let ((args nil) | |
816 temp) | |
817 (while (and olds news) | |
818 (setq args (cons (cons (car olds) (car news)) args) | |
819 olds (cdr olds) | |
820 news (cdr news))) | |
821 (math-multi-subst-rec expr)) | |
822 ) | |
823 | |
824 (defun math-multi-subst-rec (expr) | |
825 (cond ((setq temp (assoc expr args)) (cdr temp)) | |
826 ((Math-primp expr) expr) | |
827 ((and (eq (car expr) 'calcFunc-lambda) (> (length expr) 2)) | |
828 (let ((new (list (car expr))) | |
829 (args args)) | |
830 (while (cdr (setq expr (cdr expr))) | |
831 (setq new (cons (car expr) new)) | |
832 (if (assoc (car expr) args) | |
833 (setq args (cons (cons (car expr) (car expr)) args)))) | |
834 (nreverse (cons (math-multi-subst-rec (car expr)) new)))) | |
835 (t | |
836 (cons (car expr) | |
837 (mapcar 'math-multi-subst-rec (cdr expr))))) | |
838 ) | |
839 | |
840 (defun calcFunc-call (f &rest args) | |
841 (setq args (math-build-call (math-var-to-calcFunc f) args)) | |
842 (if (eq (car-safe args) 'calcFunc-call) | |
843 args | |
844 (math-normalize args)) | |
845 ) | |
846 | |
847 (defun calcFunc-apply (f args) | |
848 (or (Math-vectorp args) | |
849 (math-reject-arg args 'vectorp)) | |
850 (apply 'calcFunc-call (cons f (cdr args))) | |
851 ) | |
852 | |
853 | |
854 | |
855 | |
856 ;;; Map a function over a vector symbolically. [Public] | |
857 (defun math-symb-map (f mode args) | |
858 (let* ((func (math-var-to-calcFunc f)) | |
859 (nargs (length args)) | |
860 (ptrs (vconcat args)) | |
861 (vflags (make-vector nargs nil)) | |
862 (heads '(vec)) | |
863 (head nil) | |
864 (vec nil) | |
865 (i -1) | |
866 (math-working-step 0) | |
867 (math-working-step-2 nil) | |
868 len cols obj expr) | |
869 (if (eq mode 'eqn) | |
870 (setq mode 'elems | |
871 heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt | |
872 calcFunc-leq calcFunc-geq)) | |
873 (while (and (< (setq i (1+ i)) nargs) | |
874 (not (math-matrixp (aref ptrs i))))) | |
875 (if (< i nargs) | |
876 (if (eq mode 'elems) | |
877 (setq func (list 'lambda '(&rest x) | |
878 (list 'math-symb-map | |
879 (list 'quote f) '(quote elems) 'x)) | |
880 mode 'rows) | |
881 (if (eq mode 'cols) | |
882 (while (< i nargs) | |
883 (if (math-matrixp (aref ptrs i)) | |
884 (aset ptrs i (math-transpose (aref ptrs i)))) | |
885 (setq i (1+ i))))) | |
886 (setq mode 'elems)) | |
887 (setq i -1)) | |
888 (while (< (setq i (1+ i)) nargs) | |
889 (setq obj (aref ptrs i)) | |
890 (if (and (memq (car-safe obj) heads) | |
891 (or (eq mode 'elems) | |
892 (math-matrixp obj))) | |
893 (progn | |
894 (aset vflags i t) | |
895 (if head | |
896 (if (cdr heads) | |
897 (setq head (nth | |
898 (aref (aref [ [0 1 2 3 4 5] | |
899 [1 1 2 3 2 3] | |
900 [2 2 2 1 2 1] | |
901 [3 3 1 3 1 3] | |
902 [4 2 2 1 4 1] | |
903 [5 3 1 3 1 5] ] | |
904 (- 6 (length (memq head heads)))) | |
905 (- 6 (length (memq (car obj) heads)))) | |
906 heads))) | |
907 (setq head (car obj))) | |
908 (if len | |
909 (or (= (length obj) len) | |
910 (math-dimension-error)) | |
911 (setq len (length obj)))))) | |
912 (or len | |
913 (if (= nargs 1) | |
914 (math-reject-arg (aref ptrs 0) 'vectorp) | |
915 (math-reject-arg nil "At least one argument must be a vector"))) | |
916 (setq math-working-step-2 (1- len)) | |
917 (while (> (setq len (1- len)) 0) | |
918 (setq expr nil | |
919 i -1) | |
920 (while (< (setq i (1+ i)) nargs) | |
921 (if (aref vflags i) | |
922 (progn | |
923 (aset ptrs i (cdr (aref ptrs i))) | |
924 (setq expr (nconc expr (list (car (aref ptrs i)))))) | |
925 (setq expr (nconc expr (list (aref ptrs i)))))) | |
926 (setq math-working-step (1+ math-working-step) | |
927 vec (cons (math-normalize (math-build-call func expr)) vec))) | |
928 (setq vec (cons head (nreverse vec))) | |
929 (if (and (eq mode 'cols) (math-matrixp vec)) | |
930 (math-transpose vec) | |
931 vec)) | |
932 ) | |
933 | |
934 (defun calcFunc-map (func &rest args) | |
935 (math-symb-map func 'elems args) | |
936 ) | |
937 | |
938 (defun calcFunc-mapr (func &rest args) | |
939 (math-symb-map func 'rows args) | |
940 ) | |
941 | |
942 (defun calcFunc-mapc (func &rest args) | |
943 (math-symb-map func 'cols args) | |
944 ) | |
945 | |
946 (defun calcFunc-mapa (func arg) | |
947 (if (math-matrixp arg) | |
948 (math-symb-map func 'elems (cdr (math-transpose arg))) | |
949 (math-symb-map func 'elems arg)) | |
950 ) | |
951 | |
952 (defun calcFunc-mapd (func arg) | |
953 (if (math-matrixp arg) | |
954 (math-symb-map func 'elems (cdr arg)) | |
955 (math-symb-map func 'elems arg)) | |
956 ) | |
957 | |
958 (defun calcFunc-mapeq (func &rest args) | |
959 (if (and (or (equal func '(var mul var-mul)) | |
960 (equal func '(var div var-div))) | |
961 (= (length args) 2)) | |
962 (if (math-negp (car args)) | |
963 (let ((func (nth 1 (assq (car-safe (nth 1 args)) | |
964 calc-tweak-eqn-table)))) | |
965 (and func (setq args (list (car args) | |
966 (cons func (cdr (nth 1 args))))))) | |
967 (if (math-negp (nth 1 args)) | |
968 (let ((func (nth 1 (assq (car-safe (car args)) | |
969 calc-tweak-eqn-table)))) | |
970 (and func (setq args (list (cons func (cdr (car args))) | |
971 (nth 1 args)))))))) | |
972 (if (or (and (equal func '(var div var-div)) | |
973 (assq (car-safe (nth 1 args)) calc-tweak-eqn-table)) | |
974 (equal func '(var neg var-neg)) | |
975 (equal func '(var inv var-inv))) | |
976 (apply 'calcFunc-mapeqr func args) | |
977 (apply 'calcFunc-mapeqp func args)) | |
978 ) | |
979 | |
980 (defun calcFunc-mapeqr (func &rest args) | |
981 (setq args (mapcar (function (lambda (x) | |
982 (let ((func (assq (car-safe x) | |
983 calc-tweak-eqn-table))) | |
984 (if func | |
985 (cons (nth 1 func) (cdr x)) | |
986 x)))) | |
987 args)) | |
988 (apply 'calcFunc-mapeqp func args) | |
989 ) | |
990 | |
991 (defun calcFunc-mapeqp (func &rest args) | |
992 (if (or (and (memq (car-safe (car args)) '(calcFunc-lt calcFunc-leq)) | |
993 (memq (car-safe (nth 1 args)) '(calcFunc-gt calcFunc-geq))) | |
994 (and (memq (car-safe (car args)) '(calcFunc-gt calcFunc-geq)) | |
995 (memq (car-safe (nth 1 args)) '(calcFunc-lt calcFunc-leq)))) | |
996 (setq args (cons (car args) | |
997 (cons (list (nth 1 (assq (car (nth 1 args)) | |
998 calc-tweak-eqn-table)) | |
999 (nth 2 (nth 1 args)) | |
1000 (nth 1 (nth 1 args))) | |
1001 (cdr (cdr args)))))) | |
1002 (math-symb-map func 'eqn args) | |
1003 ) | |
1004 | |
1005 | |
1006 | |
1007 ;;; Reduce a function over a vector symbolically. [Public] | |
1008 (defun calcFunc-reduce (func vec) | |
1009 (if (math-matrixp vec) | |
1010 (let (expr row) | |
1011 (setq func (math-var-to-calcFunc func)) | |
1012 (while (setq vec (cdr vec)) | |
1013 (setq row (car vec)) | |
1014 (while (setq row (cdr row)) | |
1015 (setq expr (if expr | |
1016 (if (Math-numberp expr) | |
1017 (math-normalize | |
1018 (math-build-call func (list expr (car row)))) | |
1019 (math-build-call func (list expr (car row)))) | |
1020 (car row))))) | |
1021 (math-normalize expr)) | |
1022 (calcFunc-reducer func vec)) | |
1023 ) | |
1024 | |
1025 (defun calcFunc-rreduce (func vec) | |
1026 (if (math-matrixp vec) | |
1027 (let (expr row) | |
1028 (setq func (math-var-to-calcFunc func) | |
1029 vec (reverse (cdr vec))) | |
1030 (while vec | |
1031 (setq row (reverse (cdr (car vec)))) | |
1032 (while row | |
1033 (setq expr (if expr | |
1034 (math-build-call func (list (car row) expr)) | |
1035 (car row)) | |
1036 row (cdr row))) | |
1037 (setq vec (cdr vec))) | |
1038 (math-normalize expr)) | |
1039 (calcFunc-rreducer func vec)) | |
1040 ) | |
1041 | |
1042 (defun calcFunc-reducer (func vec) | |
1043 (setq func (math-var-to-calcFunc func)) | |
1044 (or (math-vectorp vec) | |
1045 (math-reject-arg vec 'vectorp)) | |
1046 (let ((expr (car (setq vec (cdr vec))))) | |
1047 (if expr | |
1048 (progn | |
1049 (condition-case err | |
1050 (and (symbolp func) | |
1051 (let ((lfunc (or (cdr (assq func | |
1052 '( (calcFunc-add . math-add) | |
1053 (calcFunc-sub . math-sub) | |
1054 (calcFunc-mul . math-mul) | |
1055 (calcFunc-div . math-div) | |
1056 (calcFunc-pow . math-pow) | |
1057 (calcFunc-mod . math-mod) | |
1058 (calcFunc-vconcat . | |
1059 math-concat) ))) | |
1060 lfunc))) | |
1061 (while (cdr vec) | |
1062 (setq expr (funcall lfunc expr (nth 1 vec)) | |
1063 vec (cdr vec))))) | |
1064 (error nil)) | |
1065 (while (setq vec (cdr vec)) | |
1066 (setq expr (math-build-call func (list expr (car vec))))) | |
1067 (math-normalize expr)) | |
1068 (or (math-identity-value func) | |
1069 (math-reject-arg vec "*Vector is empty")))) | |
1070 ) | |
1071 | |
1072 (defun math-identity-value (func) | |
1073 (cdr (assq func '( (calcFunc-add . 0) (calcFunc-sub . 0) | |
1074 (calcFunc-mul . 1) (calcFunc-div . 1) | |
1075 (calcFunc-idiv . 1) (calcFunc-fdiv . 1) | |
1076 (calcFunc-min . (var inf var-inf)) | |
1077 (calcFunc-max . (neg (var inf var-inf))) | |
1078 (calcFunc-vconcat . (vec)) | |
1079 (calcFunc-append . (vec)) ))) | |
1080 ) | |
1081 | |
1082 (defun calcFunc-rreducer (func vec) | |
1083 (setq func (math-var-to-calcFunc func)) | |
1084 (or (math-vectorp vec) | |
1085 (math-reject-arg vec 'vectorp)) | |
1086 (if (eq func 'calcFunc-sub) ; do this in a way that looks nicer | |
1087 (let ((expr (car (setq vec (cdr vec))))) | |
1088 (if expr | |
1089 (progn | |
1090 (while (setq vec (cdr vec)) | |
1091 (setq expr (math-build-call func (list expr (car vec))) | |
1092 func (if (eq func 'calcFunc-sub) | |
1093 'calcFunc-add 'calcFunc-sub))) | |
1094 (math-normalize expr)) | |
1095 0)) | |
1096 (let ((expr (car (setq vec (reverse (cdr vec)))))) | |
1097 (if expr | |
1098 (progn | |
1099 (while (setq vec (cdr vec)) | |
1100 (setq expr (math-build-call func (list (car vec) expr)))) | |
1101 (math-normalize expr)) | |
1102 (or (math-identity-value func) | |
1103 (math-reject-arg vec "*Vector is empty"))))) | |
1104 ) | |
1105 | |
1106 (defun calcFunc-reducec (func vec) | |
1107 (if (math-matrixp vec) | |
1108 (calcFunc-reducer func (math-transpose vec)) | |
1109 (calcFunc-reducer func vec)) | |
1110 ) | |
1111 | |
1112 (defun calcFunc-rreducec (func vec) | |
1113 (if (math-matrixp vec) | |
1114 (calcFunc-rreducer func (math-transpose vec)) | |
1115 (calcFunc-rreducer func vec)) | |
1116 ) | |
1117 | |
1118 (defun calcFunc-reducea (func vec) | |
1119 (if (math-matrixp vec) | |
1120 (cons 'vec | |
1121 (mapcar (function (lambda (x) (calcFunc-reducer func x))) | |
1122 (cdr vec))) | |
1123 (calcFunc-reducer func vec)) | |
1124 ) | |
1125 | |
1126 (defun calcFunc-rreducea (func vec) | |
1127 (if (math-matrixp vec) | |
1128 (cons 'vec | |
1129 (mapcar (function (lambda (x) (calcFunc-rreducer func x))) | |
1130 (cdr vec))) | |
1131 (calcFunc-rreducer func vec)) | |
1132 ) | |
1133 | |
1134 (defun calcFunc-reduced (func vec) | |
1135 (if (math-matrixp vec) | |
1136 (cons 'vec | |
1137 (mapcar (function (lambda (x) (calcFunc-reducer func x))) | |
1138 (cdr (math-transpose vec)))) | |
1139 (calcFunc-reducer func vec)) | |
1140 ) | |
1141 | |
1142 (defun calcFunc-rreduced (func vec) | |
1143 (if (math-matrixp vec) | |
1144 (cons 'vec | |
1145 (mapcar (function (lambda (x) (calcFunc-rreducer func x))) | |
1146 (cdr (math-transpose vec)))) | |
1147 (calcFunc-rreducer func vec)) | |
1148 ) | |
1149 | |
1150 (defun calcFunc-accum (func vec) | |
1151 (setq func (math-var-to-calcFunc func)) | |
1152 (or (math-vectorp vec) | |
1153 (math-reject-arg vec 'vectorp)) | |
1154 (let* ((expr (car (setq vec (cdr vec)))) | |
1155 (res (list 'vec expr))) | |
1156 (or expr | |
1157 (math-reject-arg vec "*Vector is empty")) | |
1158 (while (setq vec (cdr vec)) | |
1159 (setq expr (math-build-call func (list expr (car vec))) | |
1160 res (nconc res (list expr)))) | |
1161 (math-normalize res)) | |
1162 ) | |
1163 | |
1164 (defun calcFunc-raccum (func vec) | |
1165 (setq func (math-var-to-calcFunc func)) | |
1166 (or (math-vectorp vec) | |
1167 (math-reject-arg vec 'vectorp)) | |
1168 (let* ((expr (car (setq vec (reverse (cdr vec))))) | |
1169 (res (list expr))) | |
1170 (or expr | |
1171 (math-reject-arg vec "*Vector is empty")) | |
1172 (while (setq vec (cdr vec)) | |
1173 (setq expr (math-build-call func (list (car vec) expr)) | |
1174 res (cons (list expr) res))) | |
1175 (math-normalize (cons 'vec res))) | |
1176 ) | |
1177 | |
1178 | |
1179 (defun math-nest-calls (func base iters accum tol) | |
1180 (or (symbolp tol) | |
1181 (if (math-realp tol) | |
1182 (or (math-numberp base) (math-reject-arg base 'numberp)) | |
1183 (math-reject-arg tol 'realp))) | |
1184 (setq func (math-var-to-calcFunc func)) | |
1185 (or (null iters) | |
1186 (if (equal iters '(var inf var-inf)) | |
1187 (setq iters nil) | |
1188 (progn | |
1189 (if (math-messy-integerp iters) | |
1190 (setq iters (math-trunc iters))) | |
1191 (or (integerp iters) (math-reject-arg iters 'fixnump)) | |
1192 (or (not tol) (natnump iters) (math-reject-arg iters 'fixnatnump)) | |
1193 (if (< iters 0) | |
1194 (let* ((dummy '(var DummyArg var-DummyArg)) | |
1195 (dummy2 '(var DummyArg2 var-DummyArg2)) | |
1196 (finv (math-solve-for (math-build-call func (list dummy2)) | |
1197 dummy dummy2 nil))) | |
1198 (or finv (math-reject-arg nil "*Unable to find an inverse")) | |
1199 (if (and (= (length finv) 2) | |
1200 (equal (nth 1 finv) dummy)) | |
1201 (setq func (car finv)) | |
1202 (setq func (list 'calcFunc-lambda dummy finv))) | |
1203 (setq iters (- iters))))))) | |
1204 (math-with-extra-prec 1 | |
1205 (let ((value base) | |
1206 (ovalue nil) | |
1207 (avalues (list base)) | |
1208 (math-working-step 0) | |
1209 (math-working-step-2 iters)) | |
1210 (while (and (or (null iters) | |
1211 (>= (setq iters (1- iters)) 0)) | |
1212 (or (null tol) | |
1213 (null ovalue) | |
1214 (if (eq tol t) | |
1215 (not (if (and (Math-numberp value) | |
1216 (Math-numberp ovalue)) | |
1217 (math-nearly-equal value ovalue) | |
1218 (Math-equal value ovalue))) | |
1219 (if (math-numberp value) | |
1220 (Math-lessp tol (math-abs (math-sub value ovalue))) | |
1221 (math-reject-arg value 'numberp))))) | |
1222 (setq ovalue value | |
1223 math-working-step (1+ math-working-step) | |
1224 value (math-normalize (math-build-call func (list value)))) | |
1225 (if accum | |
1226 (setq avalues (cons value avalues)))) | |
1227 (if accum | |
1228 (cons 'vec (nreverse avalues)) | |
1229 value))) | |
1230 ) | |
1231 | |
1232 (defun calcFunc-nest (func base iters) | |
1233 (math-nest-calls func base iters nil nil) | |
1234 ) | |
1235 | |
1236 (defun calcFunc-anest (func base iters) | |
1237 (math-nest-calls func base iters t nil) | |
1238 ) | |
1239 | |
1240 (defun calcFunc-fixp (func base &optional iters tol) | |
1241 (math-nest-calls func base iters nil (or tol t)) | |
1242 ) | |
1243 | |
1244 (defun calcFunc-afixp (func base &optional iters tol) | |
1245 (math-nest-calls func base iters t (or tol t)) | |
1246 ) | |
1247 | |
1248 | |
1249 (defun calcFunc-outer (func a b) | |
1250 (or (math-vectorp a) (math-reject-arg a 'vectorp)) | |
1251 (or (math-vectorp b) (math-reject-arg b 'vectorp)) | |
1252 (setq func (math-var-to-calcFunc func)) | |
1253 (let ((mat nil)) | |
1254 (while (setq a (cdr a)) | |
1255 (setq mat (cons (cons 'vec | |
1256 (mapcar (function (lambda (x) | |
1257 (math-build-call func | |
1258 (list (car a) | |
1259 x)))) | |
1260 (cdr b))) | |
1261 mat))) | |
1262 (math-normalize (cons 'vec (nreverse mat)))) | |
1263 ) | |
1264 | |
1265 | |
1266 (defun calcFunc-inner (mul-func add-func a b) | |
1267 (or (math-vectorp a) (math-reject-arg a 'vectorp)) | |
1268 (or (math-vectorp b) (math-reject-arg b 'vectorp)) | |
1269 (if (math-matrixp a) | |
1270 (if (math-matrixp b) | |
1271 (if (= (length (nth 1 a)) (length b)) | |
1272 (math-inner-mats a b) | |
1273 (math-dimension-error)) | |
1274 (if (= (length (nth 1 a)) 2) | |
1275 (if (= (length a) (length b)) | |
1276 (math-inner-mats a (list 'vec b)) | |
1277 (math-dimension-error)) | |
1278 (if (= (length (nth 1 a)) (length b)) | |
1279 (math-mat-col (math-inner-mats a (math-col-matrix b)) | |
1280 1) | |
1281 (math-dimension-error)))) | |
1282 (if (math-matrixp b) | |
1283 (nth 1 (math-inner-mats (list 'vec a) b)) | |
1284 (calcFunc-reduce add-func (calcFunc-map mul-func a b)))) | |
1285 ) | |
1286 | |
1287 (defun math-inner-mats (a b) | |
1288 (let ((mat nil) | |
1289 (cols (length (nth 1 b))) | |
1290 row col ap bp accum) | |
1291 (while (setq a (cdr a)) | |
1292 (setq col cols | |
1293 row nil) | |
1294 (while (> (setq col (1- col)) 0) | |
1295 (setq row (cons (calcFunc-reduce add-func | |
1296 (calcFunc-map mul-func | |
1297 (car a) | |
1298 (math-mat-col b col))) | |
1299 row))) | |
1300 (setq mat (cons (cons 'vec row) mat))) | |
1301 (cons 'vec (nreverse mat))) | |
1302 ) | |
1303 | |
1304 | |
1305 |