]> code.delx.au - gnu-emacs/blob - lisp/calc/calc-map.el
delx.au / code / gnu-emacs / blob


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