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