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