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