1 |
;; Calculator for GNU Emacs, part II [calc-map.el] |
;;; calc-map.el --- higher-order functions for Calc |
2 |
|
|
3 |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
4 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
|
5 |
|
;; Author: David Gillespie <daveg@synaptics.com> |
6 |
|
;; Maintainer: Colin Walters <walters@debian.org> |
7 |
|
|
8 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
9 |
|
|
22 |
;; file named COPYING. Among other things, the copyright notice |
;; file named COPYING. Among other things, the copyright notice |
23 |
;; and this notice must be preserved on all copies. |
;; and this notice must be preserved on all copies. |
24 |
|
|
25 |
|
;;; Commentary: |
26 |
|
|
27 |
|
;;; Code: |
28 |
|
|
29 |
;; This file is autoloaded from calc-ext.el. |
;; This file is autoloaded from calc-ext.el. |
30 |
(require 'calc-ext) |
(require 'calc-ext) |
145 |
nargs |
nargs |
146 |
(1+ calc-dollar-used)))))))) |
(1+ calc-dollar-used)))))))) |
147 |
|
|
148 |
|
(defvar calc-verify-arglist t) |
149 |
|
(defvar calc-mapping-dir nil) |
150 |
(defun calc-map-stack () |
(defun calc-map-stack () |
151 |
"This is meant to be called by calc-keypad mode." |
"This is meant to be called by calc-keypad mode." |
152 |
(interactive) |
(interactive) |
198 |
(calc-top-list-n |
(calc-top-list-n |
199 |
2 (+ 1 mul-used calc-dollar-used))))))) |
2 (+ 1 mul-used calc-dollar-used))))))) |
200 |
|
|
|
;;; Return a list of the form (nargs func name) |
|
|
(defun calc-get-operator (msg &optional nargs) |
|
|
(setq calc-aborted-prefix nil) |
|
|
(let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil) |
|
|
done key oper (which 0) |
|
|
(msgs '( "(Press ? for help)" |
|
|
"+, -, *, /, ^, %, \\, :, &, !, |, Neg" |
|
|
"SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt" |
|
|
"SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB" |
|
|
"Algebra + Simp, Esimp, Deriv, Integ, !, =, etc." |
|
|
"Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip" |
|
|
"Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction" |
|
|
"Functions + Re, Im; Hypot; Mant, Expon, Scale; etc." |
|
|
"Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc." |
|
|
"Time/date + newYear, Incmonth, etc." |
|
|
"Vectors + Length, Row, Col, Diag, Mask, etc." |
|
|
"_ = mapr/reducea, : = mapc/reduced, = = reducer" |
|
|
"X or Z = any function by name; ' = alg entry; $ = stack"))) |
|
|
(while (not done) |
|
|
(message "%s%s: %s: %s%s%s" |
|
|
msg |
|
|
(cond ((equal calc-mapping-dir "r") " rows") |
|
|
((equal calc-mapping-dir "c") " columns") |
|
|
((equal calc-mapping-dir "a") " across") |
|
|
((equal calc-mapping-dir "d") " down") |
|
|
(t "")) |
|
|
(if forcenargs |
|
|
(format "(%d arg%s)" |
|
|
forcenargs (if (= forcenargs 1) "" "s")) |
|
|
(nth which msgs)) |
|
|
(if inv "Inv " "") (if hyp "Hyp " "") |
|
|
(if prefix (concat (char-to-string prefix) "-") "")) |
|
|
(setq key (read-char)) |
|
|
(if (>= key 128) (setq key (- key 128))) |
|
|
(cond ((memq key '(?\C-g ?q)) |
|
|
(keyboard-quit)) |
|
|
((memq key '(?\C-u ?\e))) |
|
|
((= key ??) |
|
|
(setq which (% (1+ which) (length msgs)))) |
|
|
((and (= key ?I) (null prefix)) |
|
|
(setq inv (not inv))) |
|
|
((and (= key ?H) (null prefix)) |
|
|
(setq hyp (not hyp))) |
|
|
((and (eq key prefix) (not (eq key ?v))) |
|
|
(setq prefix nil)) |
|
|
((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V)) |
|
|
(null prefix)) |
|
|
(setq prefix (downcase key))) |
|
|
((and (eq key ?\=) (null prefix)) |
|
|
(if calc-mapping-dir |
|
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "r") |
|
|
"" "r")) |
|
|
(beep))) |
|
|
((and (eq key ?\_) (null prefix)) |
|
|
(if calc-mapping-dir |
|
|
(if (string-match "map$" msg) |
|
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "r") |
|
|
"" "r")) |
|
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "a") |
|
|
"" "a"))) |
|
|
(beep))) |
|
|
((and (eq key ?\:) (null prefix)) |
|
|
(if calc-mapping-dir |
|
|
(if (string-match "map$" msg) |
|
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "c") |
|
|
"" "c")) |
|
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "d") |
|
|
"" "d"))) |
|
|
(beep))) |
|
|
((and (>= key ?0) (<= key ?9) (null prefix)) |
|
|
(setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0))) |
|
|
(and nargs forcenargs (/= nargs forcenargs) (>= nargs 0) |
|
|
(error "Must be a %d-argument operator" nargs))) |
|
|
((memq key '(?\$ ?\')) |
|
|
(let* ((arglist nil) |
|
|
(has-args nil) |
|
|
(record-entry nil) |
|
|
(expr (if (eq key ?\$) |
|
|
(progn |
|
|
(setq calc-dollar-used 1) |
|
|
(if calc-dollar-values |
|
|
(car calc-dollar-values) |
|
|
(error "Stack underflow"))) |
|
|
(let* ((calc-dollar-values calc-arg-values) |
|
|
(calc-dollar-used 0) |
|
|
(calc-hashes-used 0) |
|
|
(func (calc-do-alg-entry "" "Function: "))) |
|
|
(setq record-entry t) |
|
|
(or (= (length func) 1) |
|
|
(error "Bad format")) |
|
|
(if (> calc-dollar-used 0) |
|
|
(progn |
|
|
(setq has-args calc-dollar-used |
|
|
arglist (calc-invent-args has-args)) |
|
|
(math-multi-subst (car func) |
|
|
(reverse arglist) |
|
|
arglist)) |
|
|
(if (> calc-hashes-used 0) |
|
|
(setq has-args calc-hashes-used |
|
|
arglist (calc-invent-args has-args))) |
|
|
(car func)))))) |
|
|
(if (eq (car-safe expr) 'calcFunc-lambda) |
|
|
(setq oper (list "$" (- (length expr) 2) expr) |
|
|
done t) |
|
|
(or has-args |
|
|
(progn |
|
|
(calc-default-formula-arglist expr) |
|
|
(setq record-entry t |
|
|
arglist (sort arglist 'string-lessp)) |
|
|
(if calc-verify-arglist |
|
|
(setq arglist (read-from-minibuffer |
|
|
"Function argument list: " |
|
|
(if arglist |
|
|
(prin1-to-string arglist) |
|
|
"()") |
|
|
minibuffer-local-map |
|
|
t))) |
|
|
(setq arglist (mapcar (function |
|
|
(lambda (x) |
|
|
(list 'var |
|
|
x |
|
|
(intern |
|
|
(concat |
|
|
"var-" |
|
|
(symbol-name x)))))) |
|
|
arglist)))) |
|
|
(setq oper (list "$" |
|
|
(length arglist) |
|
|
(append '(calcFunc-lambda) arglist |
|
|
(list expr))) |
|
|
done t)) |
|
|
(if record-entry |
|
|
(calc-record (nth 2 oper) "oper")))) |
|
|
((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0)) |
|
|
(if prefix |
|
|
(symbol-value |
|
|
(intern (format "calc-%c-oper-keys" |
|
|
prefix))) |
|
|
calc-oper-keys)))) |
|
|
(if (eq (nth 1 oper) 'user) |
|
|
(let ((func (intern |
|
|
(completing-read "Function name: " |
|
|
obarray 'fboundp |
|
|
nil "calcFunc-")))) |
|
|
(if (or forcenargs nargs) |
|
|
(setq oper (list "z" (or forcenargs nargs) func) |
|
|
done t) |
|
|
(if (fboundp func) |
|
|
(let* ((defn (symbol-function func))) |
|
|
(and (symbolp defn) |
|
|
(setq defn (symbol-function defn))) |
|
|
(if (eq (car-safe defn) 'lambda) |
|
|
(let ((args (nth 1 defn)) |
|
|
(nargs 0)) |
|
|
(while (not (memq (car args) '(&optional |
|
|
&rest nil))) |
|
|
(setq nargs (1+ nargs) |
|
|
args (cdr args))) |
|
|
(setq oper (list "z" nargs func) |
|
|
done t)) |
|
|
(error |
|
|
"Function is not suitable for this operation"))) |
|
|
(message "Number of arguments: ") |
|
|
(let ((nargs (read-char))) |
|
|
(if (and (>= nargs ?0) (<= nargs ?9)) |
|
|
(setq oper (list "z" (- nargs ?0) func) |
|
|
done t) |
|
|
(beep)))))) |
|
|
(if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U))) |
|
|
(and (eq prefix ?a) (eq key ?M))) |
|
|
(let* ((dir (cond ((and (equal calc-mapping-dir "") |
|
|
(string-match "map$" msg)) |
|
|
(setq calc-mapping-dir "r") |
|
|
" rows") |
|
|
((equal calc-mapping-dir "r") " rows") |
|
|
((equal calc-mapping-dir "c") " columns") |
|
|
((equal calc-mapping-dir "a") " across") |
|
|
((equal calc-mapping-dir "d") " down") |
|
|
(t ""))) |
|
|
(calc-mapping-dir (and (memq (nth 2 oper) |
|
|
'(calcFunc-map |
|
|
calcFunc-reduce |
|
|
calcFunc-rreduce)) |
|
|
"")) |
|
|
(oper2 (calc-get-operator |
|
|
(format "%s%s, %s%s" msg dir |
|
|
(substring (symbol-name (nth 2 oper)) |
|
|
9) |
|
|
(if (eq key ?I) " (mult)" "")) |
|
|
(cdr (assq (nth 2 oper) |
|
|
'((calcFunc-reduce . 2) |
|
|
(calcFunc-rreduce . 2) |
|
|
(calcFunc-accum . 2) |
|
|
(calcFunc-raccum . 2) |
|
|
(calcFunc-nest . 2) |
|
|
(calcFunc-anest . 2) |
|
|
(calcFunc-fixp . 2) |
|
|
(calcFunc-afixp . 2)))))) |
|
|
(oper3 (if (eq (nth 2 oper) 'calcFunc-inner) |
|
|
(calc-get-operator |
|
|
(format "%s%s, inner (add)" msg dir |
|
|
(substring |
|
|
(symbol-name (nth 2 oper)) |
|
|
9))) |
|
|
'(0 0 0))) |
|
|
(args nil) |
|
|
(nargs (if (> (nth 1 oper) 0) |
|
|
(nth 1 oper) |
|
|
(car oper2))) |
|
|
(n nargs) |
|
|
(p calc-arg-values)) |
|
|
(while (and p (> n 0)) |
|
|
(or (math-expr-contains (nth 1 oper2) (car p)) |
|
|
(math-expr-contains (nth 1 oper3) (car p)) |
|
|
(setq args (nconc args (list (car p))) |
|
|
n (1- n))) |
|
|
(setq p (cdr p))) |
|
|
(setq oper (list "" nargs |
|
|
(append |
|
|
'(calcFunc-lambda) |
|
|
args |
|
|
(list (math-build-call |
|
|
(intern |
|
|
(concat |
|
|
(symbol-name (nth 2 oper)) |
|
|
calc-mapping-dir)) |
|
|
(cons (math-calcFunc-to-var |
|
|
(nth 1 oper2)) |
|
|
(if (eq key ?I) |
|
|
(cons |
|
|
(math-calcFunc-to-var |
|
|
(nth 1 oper3)) |
|
|
args) |
|
|
args)))))) |
|
|
done t)) |
|
|
(setq done t)))) |
|
|
(t (beep)))) |
|
|
(and nargs (>= nargs 0) |
|
|
(/= nargs (nth 1 oper)) |
|
|
(error "Must be a %d-argument operator" nargs)) |
|
|
(append (if forcenargs |
|
|
(cons forcenargs (cdr (cdr oper))) |
|
|
(cdr oper)) |
|
|
(list |
|
|
(let ((name (concat (if inv "I" "") (if hyp "H" "") |
|
|
(if prefix (char-to-string prefix) "") |
|
|
(char-to-string key)))) |
|
|
(if (> (length name) 3) |
|
|
(substring name 0 3) |
|
|
name)))))) |
|
|
(setq calc-verify-arglist t) |
|
|
(setq calc-mapping-dir nil) |
|
|
|
|
201 |
(defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add ) |
(defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add ) |
202 |
( ?- 2 calcFunc-sub ) |
( ?- 2 calcFunc-sub ) |
203 |
( ?* 2 calcFunc-mul ) |
( ?* 2 calcFunc-mul ) |
251 |
( ?T 1 calcFunc-arctanh ) |
( ?T 1 calcFunc-arctanh ) |
252 |
( ?L 1 calcFunc-exp10 ) |
( ?L 1 calcFunc-exp10 ) |
253 |
( ?E 1 calcFunc-log10 ) |
( ?E 1 calcFunc-log10 ) |
254 |
( ?| 2 calcFunc-appendrev ) ) |
( ?| 2 calcFunc-appendrev ) ))) |
255 |
)) |
|
256 |
(defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart ) |
(defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart ) |
257 |
( ?b 3 calcFunc-subst ) |
( ?b 3 calcFunc-subst ) |
258 |
( ?c 2 calcFunc-collect ) |
( ?c 2 calcFunc-collect ) |
304 |
( ?S 2 calcFunc-fsolve ) |
( ?S 2 calcFunc-fsolve ) |
305 |
( ?X 3 calcFunc-wmaximize ) |
( ?X 3 calcFunc-wmaximize ) |
306 |
( ?/ 2 calcFunc-pdivide ) ) |
( ?/ 2 calcFunc-pdivide ) ) |
307 |
( ( ?S 2 calcFunc-ffinv ) ) |
( ( ?S 2 calcFunc-ffinv ) ))) |
308 |
)) |
|
309 |
(defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and ) |
(defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and ) |
310 |
( ?o 2 calcFunc-or ) |
( ?o 2 calcFunc-or ) |
311 |
( ?x 2 calcFunc-xor ) |
( ?x 2 calcFunc-xor ) |
341 |
( ?M 3 calcFunc-pmtl ) |
( ?M 3 calcFunc-pmtl ) |
342 |
( ?P 3 calcFunc-pvl ) |
( ?P 3 calcFunc-pvl ) |
343 |
( ?T 3 calcFunc-ratel ) |
( ?T 3 calcFunc-ratel ) |
344 |
( ?\# 3 calcFunc-nperl ) ) |
( ?\# 3 calcFunc-nperl ) ))) |
345 |
)) |
|
346 |
(defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg ) |
(defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg ) |
347 |
( ?r 1 calcFunc-rad ) |
( ?r 1 calcFunc-rad ) |
348 |
( ?h 1 calcFunc-hms ) |
( ?h 1 calcFunc-hms ) |
349 |
( ?f 1 calcFunc-float ) |
( ?f 1 calcFunc-float ) |
350 |
( ?F 1 calcFunc-frac ) ) |
( ?F 1 calcFunc-frac ) ))) |
351 |
)) |
|
352 |
(defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta ) |
(defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta ) |
353 |
( ?e 1 calcFunc-erf ) |
( ?e 1 calcFunc-erf ) |
354 |
( ?g 1 calcFunc-gamma ) |
( ?g 1 calcFunc-gamma ) |
379 |
( ?L 1 calcFunc-expm1 ) ) |
( ?L 1 calcFunc-expm1 ) ) |
380 |
( ( ?B 3 calcFunc-betaB ) |
( ( ?B 3 calcFunc-betaB ) |
381 |
( ?G 2 calcFunc-gammag) ) |
( ?G 2 calcFunc-gammag) ) |
382 |
( ( ?G 2 calcFunc-gammaG ) ) |
( ( ?G 2 calcFunc-gammaG ) ))) |
383 |
)) |
|
384 |
(defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern ) |
(defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern ) |
385 |
( ?c 2 calcFunc-choose ) |
( ?c 2 calcFunc-choose ) |
386 |
( ?d 1 calcFunc-dfact ) |
( ?d 1 calcFunc-dfact ) |
410 |
( ( ?b 2 calcFunc-bern ) |
( ( ?b 2 calcFunc-bern ) |
411 |
( ?c 2 calcFunc-perm ) |
( ?c 2 calcFunc-perm ) |
412 |
( ?e 2 calcFunc-euler ) |
( ?e 2 calcFunc-euler ) |
413 |
( ?s 2 calcFunc-stir2 ) ) |
( ?s 2 calcFunc-stir2 ) ))) |
414 |
)) |
|
415 |
(defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign ) |
(defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign ) |
416 |
( ?= 1 calcFunc-evalto ) ) |
( ?= 1 calcFunc-evalto ) ))) |
417 |
)) |
|
418 |
(defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv ) |
(defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv ) |
419 |
( ?D 1 calcFunc-date ) |
( ?D 1 calcFunc-date ) |
420 |
( ?I 2 calcFunc-incmonth ) |
( ?I 2 calcFunc-incmonth ) |
422 |
( ?M 1 calcFunc-newmonth ) |
( ?M 1 calcFunc-newmonth ) |
423 |
( ?W 1 calcFunc-newweek ) |
( ?W 1 calcFunc-newweek ) |
424 |
( ?U 1 calcFunc-unixtime ) |
( ?U 1 calcFunc-unixtime ) |
425 |
( ?Y 1 calcFunc-newyear ) ) |
( ?Y 1 calcFunc-newyear ) ))) |
426 |
)) |
|
427 |
(defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov ) |
(defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov ) |
428 |
( ?G 1 calcFunc-vgmean ) |
( ?G 1 calcFunc-vgmean ) |
429 |
( ?M 1 calcFunc-vmean ) |
( ?M 1 calcFunc-vmean ) |
438 |
( ?M 1 calcFunc-vmedian ) |
( ?M 1 calcFunc-vmedian ) |
439 |
( ?S 1 calcFunc-vvar ) ) |
( ?S 1 calcFunc-vvar ) ) |
440 |
( ( ?M 1 calcFunc-vhmean ) |
( ( ?M 1 calcFunc-vhmean ) |
441 |
( ?S 1 calcFunc-vpvar ) ) |
( ?S 1 calcFunc-vpvar ) ))) |
442 |
)) |
|
443 |
(defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange ) |
(defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange ) |
444 |
( ?b 2 calcFunc-cvec ) |
( ?b 2 calcFunc-cvec ) |
445 |
( ?c 2 calcFunc-mcol ) |
( ?c 2 calcFunc-mcol ) |
496 |
( ?U 2 calcFunc-anest ) ) |
( ?U 2 calcFunc-anest ) ) |
497 |
( ( ?h 1 calcFunc-rtail ) |
( ( ?h 1 calcFunc-rtail ) |
498 |
( ?R 1 calcFunc-fixp ) |
( ?R 1 calcFunc-fixp ) |
499 |
( ?U 1 calcFunc-afixp ) ) |
( ?U 1 calcFunc-afixp ) ))) |
500 |
)) |
|
501 |
|
|
502 |
|
;;; Return a list of the form (nargs func name) |
503 |
|
(defun calc-get-operator (msg &optional nargs) |
504 |
|
(setq calc-aborted-prefix nil) |
505 |
|
(let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil) |
506 |
|
done key oper (which 0) |
507 |
|
(msgs '( "(Press ? for help)" |
508 |
|
"+, -, *, /, ^, %, \\, :, &, !, |, Neg" |
509 |
|
"SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt" |
510 |
|
"SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB" |
511 |
|
"Algebra + Simp, Esimp, Deriv, Integ, !, =, etc." |
512 |
|
"Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip" |
513 |
|
"Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction" |
514 |
|
"Functions + Re, Im; Hypot; Mant, Expon, Scale; etc." |
515 |
|
"Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc." |
516 |
|
"Time/date + newYear, Incmonth, etc." |
517 |
|
"Vectors + Length, Row, Col, Diag, Mask, etc." |
518 |
|
"_ = mapr/reducea, : = mapc/reduced, = = reducer" |
519 |
|
"X or Z = any function by name; ' = alg entry; $ = stack"))) |
520 |
|
(while (not done) |
521 |
|
(message "%s%s: %s: %s%s%s" |
522 |
|
msg |
523 |
|
(cond ((equal calc-mapping-dir "r") " rows") |
524 |
|
((equal calc-mapping-dir "c") " columns") |
525 |
|
((equal calc-mapping-dir "a") " across") |
526 |
|
((equal calc-mapping-dir "d") " down") |
527 |
|
(t "")) |
528 |
|
(if forcenargs |
529 |
|
(format "(%d arg%s)" |
530 |
|
forcenargs (if (= forcenargs 1) "" "s")) |
531 |
|
(nth which msgs)) |
532 |
|
(if inv "Inv " "") (if hyp "Hyp " "") |
533 |
|
(if prefix (concat (char-to-string prefix) "-") "")) |
534 |
|
(setq key (read-char)) |
535 |
|
(if (>= key 128) (setq key (- key 128))) |
536 |
|
(cond ((memq key '(?\C-g ?q)) |
537 |
|
(keyboard-quit)) |
538 |
|
((memq key '(?\C-u ?\e))) |
539 |
|
((= key ??) |
540 |
|
(setq which (% (1+ which) (length msgs)))) |
541 |
|
((and (= key ?I) (null prefix)) |
542 |
|
(setq inv (not inv))) |
543 |
|
((and (= key ?H) (null prefix)) |
544 |
|
(setq hyp (not hyp))) |
545 |
|
((and (eq key prefix) (not (eq key ?v))) |
546 |
|
(setq prefix nil)) |
547 |
|
((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V)) |
548 |
|
(null prefix)) |
549 |
|
(setq prefix (downcase key))) |
550 |
|
((and (eq key ?\=) (null prefix)) |
551 |
|
(if calc-mapping-dir |
552 |
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "r") |
553 |
|
"" "r")) |
554 |
|
(beep))) |
555 |
|
((and (eq key ?\_) (null prefix)) |
556 |
|
(if calc-mapping-dir |
557 |
|
(if (string-match "map$" msg) |
558 |
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "r") |
559 |
|
"" "r")) |
560 |
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "a") |
561 |
|
"" "a"))) |
562 |
|
(beep))) |
563 |
|
((and (eq key ?\:) (null prefix)) |
564 |
|
(if calc-mapping-dir |
565 |
|
(if (string-match "map$" msg) |
566 |
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "c") |
567 |
|
"" "c")) |
568 |
|
(setq calc-mapping-dir (if (equal calc-mapping-dir "d") |
569 |
|
"" "d"))) |
570 |
|
(beep))) |
571 |
|
((and (>= key ?0) (<= key ?9) (null prefix)) |
572 |
|
(setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0))) |
573 |
|
(and nargs forcenargs (/= nargs forcenargs) (>= nargs 0) |
574 |
|
(error "Must be a %d-argument operator" nargs))) |
575 |
|
((memq key '(?\$ ?\')) |
576 |
|
(let* ((arglist nil) |
577 |
|
(has-args nil) |
578 |
|
(record-entry nil) |
579 |
|
(expr (if (eq key ?\$) |
580 |
|
(progn |
581 |
|
(setq calc-dollar-used 1) |
582 |
|
(if calc-dollar-values |
583 |
|
(car calc-dollar-values) |
584 |
|
(error "Stack underflow"))) |
585 |
|
(let* ((calc-dollar-values calc-arg-values) |
586 |
|
(calc-dollar-used 0) |
587 |
|
(calc-hashes-used 0) |
588 |
|
(func (calc-do-alg-entry "" "Function: "))) |
589 |
|
(setq record-entry t) |
590 |
|
(or (= (length func) 1) |
591 |
|
(error "Bad format")) |
592 |
|
(if (> calc-dollar-used 0) |
593 |
|
(progn |
594 |
|
(setq has-args calc-dollar-used |
595 |
|
arglist (calc-invent-args has-args)) |
596 |
|
(math-multi-subst (car func) |
597 |
|
(reverse arglist) |
598 |
|
arglist)) |
599 |
|
(if (> calc-hashes-used 0) |
600 |
|
(setq has-args calc-hashes-used |
601 |
|
arglist (calc-invent-args has-args))) |
602 |
|
(car func)))))) |
603 |
|
(if (eq (car-safe expr) 'calcFunc-lambda) |
604 |
|
(setq oper (list "$" (- (length expr) 2) expr) |
605 |
|
done t) |
606 |
|
(or has-args |
607 |
|
(progn |
608 |
|
(calc-default-formula-arglist expr) |
609 |
|
(setq record-entry t |
610 |
|
arglist (sort arglist 'string-lessp)) |
611 |
|
(if calc-verify-arglist |
612 |
|
(setq arglist (read-from-minibuffer |
613 |
|
"Function argument list: " |
614 |
|
(if arglist |
615 |
|
(prin1-to-string arglist) |
616 |
|
"()") |
617 |
|
minibuffer-local-map |
618 |
|
t))) |
619 |
|
(setq arglist (mapcar (function |
620 |
|
(lambda (x) |
621 |
|
(list 'var |
622 |
|
x |
623 |
|
(intern |
624 |
|
(concat |
625 |
|
"var-" |
626 |
|
(symbol-name x)))))) |
627 |
|
arglist)))) |
628 |
|
(setq oper (list "$" |
629 |
|
(length arglist) |
630 |
|
(append '(calcFunc-lambda) arglist |
631 |
|
(list expr))) |
632 |
|
done t)) |
633 |
|
(if record-entry |
634 |
|
(calc-record (nth 2 oper) "oper")))) |
635 |
|
((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0)) |
636 |
|
(if prefix |
637 |
|
(symbol-value |
638 |
|
(intern (format "calc-%c-oper-keys" |
639 |
|
prefix))) |
640 |
|
calc-oper-keys)))) |
641 |
|
(if (eq (nth 1 oper) 'user) |
642 |
|
(let ((func (intern |
643 |
|
(completing-read "Function name: " |
644 |
|
obarray 'fboundp |
645 |
|
nil "calcFunc-")))) |
646 |
|
(if (or forcenargs nargs) |
647 |
|
(setq oper (list "z" (or forcenargs nargs) func) |
648 |
|
done t) |
649 |
|
(if (fboundp func) |
650 |
|
(let* ((defn (symbol-function func))) |
651 |
|
(and (symbolp defn) |
652 |
|
(setq defn (symbol-function defn))) |
653 |
|
(if (eq (car-safe defn) 'lambda) |
654 |
|
(let ((args (nth 1 defn)) |
655 |
|
(nargs 0)) |
656 |
|
(while (not (memq (car args) '(&optional |
657 |
|
&rest nil))) |
658 |
|
(setq nargs (1+ nargs) |
659 |
|
args (cdr args))) |
660 |
|
(setq oper (list "z" nargs func) |
661 |
|
done t)) |
662 |
|
(error |
663 |
|
"Function is not suitable for this operation"))) |
664 |
|
(message "Number of arguments: ") |
665 |
|
(let ((nargs (read-char))) |
666 |
|
(if (and (>= nargs ?0) (<= nargs ?9)) |
667 |
|
(setq oper (list "z" (- nargs ?0) func) |
668 |
|
done t) |
669 |
|
(beep)))))) |
670 |
|
(if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U))) |
671 |
|
(and (eq prefix ?a) (eq key ?M))) |
672 |
|
(let* ((dir (cond ((and (equal calc-mapping-dir "") |
673 |
|
(string-match "map$" msg)) |
674 |
|
(setq calc-mapping-dir "r") |
675 |
|
" rows") |
676 |
|
((equal calc-mapping-dir "r") " rows") |
677 |
|
((equal calc-mapping-dir "c") " columns") |
678 |
|
((equal calc-mapping-dir "a") " across") |
679 |
|
((equal calc-mapping-dir "d") " down") |
680 |
|
(t ""))) |
681 |
|
(calc-mapping-dir (and (memq (nth 2 oper) |
682 |
|
'(calcFunc-map |
683 |
|
calcFunc-reduce |
684 |
|
calcFunc-rreduce)) |
685 |
|
"")) |
686 |
|
(oper2 (calc-get-operator |
687 |
|
(format "%s%s, %s%s" msg dir |
688 |
|
(substring (symbol-name (nth 2 oper)) |
689 |
|
9) |
690 |
|
(if (eq key ?I) " (mult)" "")) |
691 |
|
(cdr (assq (nth 2 oper) |
692 |
|
'((calcFunc-reduce . 2) |
693 |
|
(calcFunc-rreduce . 2) |
694 |
|
(calcFunc-accum . 2) |
695 |
|
(calcFunc-raccum . 2) |
696 |
|
(calcFunc-nest . 2) |
697 |
|
(calcFunc-anest . 2) |
698 |
|
(calcFunc-fixp . 2) |
699 |
|
(calcFunc-afixp . 2)))))) |
700 |
|
(oper3 (if (eq (nth 2 oper) 'calcFunc-inner) |
701 |
|
(calc-get-operator |
702 |
|
(format "%s%s, inner (add)" msg dir |
703 |
|
(substring |
704 |
|
(symbol-name (nth 2 oper)) |
705 |
|
9))) |
706 |
|
'(0 0 0))) |
707 |
|
(args nil) |
708 |
|
(nargs (if (> (nth 1 oper) 0) |
709 |
|
(nth 1 oper) |
710 |
|
(car oper2))) |
711 |
|
(n nargs) |
712 |
|
(p calc-arg-values)) |
713 |
|
(while (and p (> n 0)) |
714 |
|
(or (math-expr-contains (nth 1 oper2) (car p)) |
715 |
|
(math-expr-contains (nth 1 oper3) (car p)) |
716 |
|
(setq args (nconc args (list (car p))) |
717 |
|
n (1- n))) |
718 |
|
(setq p (cdr p))) |
719 |
|
(setq oper (list "" nargs |
720 |
|
(append |
721 |
|
'(calcFunc-lambda) |
722 |
|
args |
723 |
|
(list (math-build-call |
724 |
|
(intern |
725 |
|
(concat |
726 |
|
(symbol-name (nth 2 oper)) |
727 |
|
calc-mapping-dir)) |
728 |
|
(cons (math-calcFunc-to-var |
729 |
|
(nth 1 oper2)) |
730 |
|
(if (eq key ?I) |
731 |
|
(cons |
732 |
|
(math-calcFunc-to-var |
733 |
|
(nth 1 oper3)) |
734 |
|
args) |
735 |
|
args)))))) |
736 |
|
done t)) |
737 |
|
(setq done t)))) |
738 |
|
(t (beep)))) |
739 |
|
(and nargs (>= nargs 0) |
740 |
|
(/= nargs (nth 1 oper)) |
741 |
|
(error "Must be a %d-argument operator" nargs)) |
742 |
|
(append (if forcenargs |
743 |
|
(cons forcenargs (cdr (cdr oper))) |
744 |
|
(cdr oper)) |
745 |
|
(list |
746 |
|
(let ((name (concat (if inv "I" "") (if hyp "H" "") |
747 |
|
(if prefix (char-to-string prefix) "") |
748 |
|
(char-to-string key)))) |
749 |
|
(if (> (length name) 3) |
750 |
|
(substring name 0 3) |
751 |
|
name)))))) |
752 |
|
|
753 |
|
|
754 |
;;; Convert a variable name (as a formula) into a like-looking function name. |
;;; Convert a variable name (as a formula) into a like-looking function name. |