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