]> code.delx.au - gnu-emacs/blob - lisp/calc/calc-map.el
delx.au / code / gnu-emacs / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Convert consecutive FSF copyright years to ranges.
[gnu-emacs] / lisp / calc / calc-map.el
1 ;;; calc-map.el --- higher-order functions for Calc
2
3 ;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
4
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
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
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 ;; This file is autoloaded from calc-ext.el.
28
29 (require 'calc-ext)
30 (require 'calc-macs)
31
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))
51 expr)))))
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))
93 (calc-top-n (1+ calc-dollar-used))))))))
94
95 (defun calc-accumulate (&optional oper)
96 (interactive)
97 (calc-reduce oper t))
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
118 (1+ calc-dollar-used))))))))
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
141 (1+ calc-dollar-used))))))))
142
143 (defvar calc-verify-arglist t)
144 (defvar calc-mapping-dir nil)
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 ?\$)
150 (calc-map)))
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
168 2 (1+ calc-dollar-used))))))))
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
194 2 (+ 1 mul-used calc-dollar-used)))))))
195
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 )
249 ( ?| 2 calcFunc-appendrev ) )))
250
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 ) )
302 ( ( ?S 2 calcFunc-ffinv ) )))
303
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 )
339 ( ?\# 3 calcFunc-nperl ) )))
340
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 )
345 ( ?F 1 calcFunc-frac ) )))
346
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) )
377 ( ( ?G 2 calcFunc-gammaG ) )))
378
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 )
408 ( ?s 2 calcFunc-stir2 ) )))
409
410 (defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign )
411 ( ?= 1 calcFunc-evalto ) )))
412
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 )
420 ( ?Y 1 calcFunc-newyear ) )))
421
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 )
436 ( ?S 1 calcFunc-vpvar ) )))
437
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 )
494 ( ?U 1 calcFunc-afixp ) )))
495
496
497 ;;; Return a list of the form (nargs func name)
498 (defvar calc-get-operator-history nil
499 "History for calc-get-operator.")
500
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."
510 "Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip"
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 '(?\$ ?\'))
574 (let* ((math-arglist nil)
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)
586 (func (calc-do-alg-entry "" "Function: " nil
587 'calc-get-operator-history)))
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
594 math-arglist (calc-invent-args has-args))
595 (math-multi-subst (car func)
596 (reverse math-arglist)
597 math-arglist))
598 (if (> calc-hashes-used 0)
599 (setq has-args calc-hashes-used
600 math-arglist (calc-invent-args has-args)))
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
609 math-arglist (sort math-arglist 'string-lessp))
610 (if calc-verify-arglist
611 (setq math-arglist (read-from-minibuffer
612 "Function argument list: "
613 (if math-arglist
614 (prin1-to-string math-arglist)
615 "()")
616 minibuffer-local-map
617 t)))
618 (setq math-arglist (mapcar (function
619 (lambda (x)
620 (list 'var
621 x
622 (intern
623 (concat
624 "var-"
625 (symbol-name x))))))
626 math-arglist))))
627 (setq oper (list "$"
628 (length math-arglist)
629 (append '(calcFunc-lambda) math-arglist
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
701 (format "%s%s, inner (add)" msg dir))
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))))))
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
758 (math-reject-arg f "*Expected a function name"))))
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))))
779 f))
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)
800 (cons f args))))))
801
802 ;;; Do substitutions in parallel to avoid crosstalk.
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
810 (defun math-multi-subst (expr olds news)
811 (let ((math-ms-args nil)
812 math-ms-temp)
813 (while (and olds news)
814 (setq math-ms-args (cons (cons (car olds) (car news)) math-ms-args)
815 olds (cdr olds)
816 news (cdr news)))
817 (math-multi-subst-rec expr)))
818
819 (defun math-multi-subst-rec (expr)
820 (cond ((setq math-ms-temp (assoc expr math-ms-args))
821 (cdr math-ms-temp))
822 ((Math-primp expr) expr)
823 ((and (eq (car expr) 'calcFunc-lambda) (> (length expr) 2))
824 (let ((new (list (car expr)))
825 (math-ms-args math-ms-args))
826 (while (cdr (setq expr (cdr expr)))
827 (setq new (cons (car expr) new))
828 (if (assoc (car expr) math-ms-args)
829 (setq math-ms-args (cons (cons (car expr) (car expr))
830 math-ms-args))))
831 (nreverse (cons (math-multi-subst-rec (car expr)) new))))
832 (t
833 (cons (car expr)
834 (mapcar 'math-multi-subst-rec (cdr expr))))))
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
840 (math-normalize args)))
841
842 (defun calcFunc-apply (f args)
843 (or (Math-vectorp args)
844 (math-reject-arg args 'vectorp))
845 (apply 'calcFunc-call (cons f (cdr args))))
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)
925 vec)))
926
927 (defun calcFunc-map (func &rest args)
928 (math-symb-map func 'elems args))
929
930 (defun calcFunc-mapr (func &rest args)
931 (math-symb-map func 'rows args))
932
933 (defun calcFunc-mapc (func &rest args)
934 (math-symb-map func 'cols args))
935
936 (defun calcFunc-mapa (func arg)
937 (if (math-matrixp arg)
938 (math-symb-map func 'elems (cdr (math-transpose arg)))
939 (math-symb-map func 'elems arg)))
940
941 (defun calcFunc-mapd (func arg)
942 (if (math-matrixp arg)
943 (math-symb-map func 'elems (cdr arg))
944 (math-symb-map func 'elems arg)))
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)
965 (apply 'calcFunc-mapeqp func args)))
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))
975 (apply 'calcFunc-mapeqp func args))
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))))))
988 (math-symb-map func 'eqn args))
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))
1007 (calcFunc-reducer func vec)))
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))
1023 (calcFunc-rreducer func vec)))
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) )))
1043 func)))
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)
1052 (math-reject-arg vec "*Vector is empty")))))
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))
1061 (calcFunc-append . (vec)) ))))
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)
1084 (math-reject-arg vec "*Vector is empty"))))))
1085
1086 (defun calcFunc-reducec (func vec)
1087 (if (math-matrixp vec)
1088 (calcFunc-reducer func (math-transpose vec))
1089 (calcFunc-reducer func vec)))
1090
1091 (defun calcFunc-rreducec (func vec)
1092 (if (math-matrixp vec)
1093 (calcFunc-rreducer func (math-transpose vec))
1094 (calcFunc-rreducer func vec)))
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)))
1101 (calcFunc-reducer func vec)))
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)))
1108 (calcFunc-rreducer func vec)))
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))))
1115 (calcFunc-reducer func vec)))
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))))
1122 (calcFunc-rreducer func vec)))
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))))
1135 (math-normalize res)))
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)))
1148 (math-normalize (cons 'vec res))))
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))
1201 value))))
1202
1203 (defun calcFunc-nest (func base iters)
1204 (math-nest-calls func base iters nil nil))
1205
1206 (defun calcFunc-anest (func base iters)
1207 (math-nest-calls func base iters t nil))
1208
1209 (defun calcFunc-fixp (func base &optional iters tol)
1210 (math-nest-calls func base iters nil (or tol t)))
1211
1212 (defun calcFunc-afixp (func base &optional iters tol)
1213 (math-nest-calls func base iters t (or tol t)))
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)))
1229 (math-normalize (cons 'vec (nreverse mat)))))
1230
1231
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)
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))
1256 (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b)))))
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)
1266 (setq row (cons (calcFunc-reduce math-inner-add-func
1267 (calcFunc-map math-inner-mul-func
1268 (car a)
1269 (math-mat-col b col)))
1270 row)))
1271 (setq mat (cons (cons 'vec row) mat)))
1272 (cons 'vec (nreverse mat))))
1273
1274 (provide 'calc-map)
1275
1276 ;;; calc-map.el ends here