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