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