diff options
Diffstat (limited to 'lisp/calc/calc-map.el')
| -rw-r--r-- | lisp/calc/calc-map.el | 555 |
1 files changed, 280 insertions, 275 deletions
diff --git a/lisp/calc/calc-map.el b/lisp/calc/calc-map.el index 17ea4f2b829..baed3573789 100644 --- a/lisp/calc/calc-map.el +++ b/lisp/calc/calc-map.el @@ -1,6 +1,9 @@ -;; Calculator for GNU Emacs, part II [calc-map.el] +;;; calc-map.el --- higher-order functions for Calc + ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. -;; Written by Dave Gillespie, daveg@synaptics.com. + +;; Author: David Gillespie <daveg@synaptics.com> +;; Maintainer: Colin Walters <walters@debian.org> ;; This file is part of GNU Emacs. @@ -19,7 +22,9 @@ ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. +;;; Commentary: +;;; Code: ;; This file is autoloaded from calc-ext.el. (require 'calc-ext) @@ -140,6 +145,8 @@ nargs (1+ calc-dollar-used)))))))) +(defvar calc-verify-arglist t) +(defvar calc-mapping-dir nil) (defun calc-map-stack () "This is meant to be called by calc-keypad mode." (interactive) @@ -191,259 +198,6 @@ (calc-top-list-n 2 (+ 1 mul-used calc-dollar-used))))))) -;;; 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) - (defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add ) ( ?- 2 calcFunc-sub ) ( ?* 2 calcFunc-mul ) @@ -497,8 +251,8 @@ ( ?T 1 calcFunc-arctanh ) ( ?L 1 calcFunc-exp10 ) ( ?E 1 calcFunc-log10 ) - ( ?| 2 calcFunc-appendrev ) ) -)) + ( ?| 2 calcFunc-appendrev ) ))) + (defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart ) ( ?b 3 calcFunc-subst ) ( ?c 2 calcFunc-collect ) @@ -550,8 +304,8 @@ ( ?S 2 calcFunc-fsolve ) ( ?X 3 calcFunc-wmaximize ) ( ?/ 2 calcFunc-pdivide ) ) - ( ( ?S 2 calcFunc-ffinv ) ) -)) + ( ( ?S 2 calcFunc-ffinv ) ))) + (defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and ) ( ?o 2 calcFunc-or ) ( ?x 2 calcFunc-xor ) @@ -587,14 +341,14 @@ ( ?M 3 calcFunc-pmtl ) ( ?P 3 calcFunc-pvl ) ( ?T 3 calcFunc-ratel ) - ( ?\# 3 calcFunc-nperl ) ) -)) + ( ?\# 3 calcFunc-nperl ) ))) + (defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg ) ( ?r 1 calcFunc-rad ) ( ?h 1 calcFunc-hms ) ( ?f 1 calcFunc-float ) - ( ?F 1 calcFunc-frac ) ) -)) + ( ?F 1 calcFunc-frac ) ))) + (defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta ) ( ?e 1 calcFunc-erf ) ( ?g 1 calcFunc-gamma ) @@ -625,8 +379,8 @@ ( ?L 1 calcFunc-expm1 ) ) ( ( ?B 3 calcFunc-betaB ) ( ?G 2 calcFunc-gammag) ) - ( ( ?G 2 calcFunc-gammaG ) ) -)) + ( ( ?G 2 calcFunc-gammaG ) ))) + (defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern ) ( ?c 2 calcFunc-choose ) ( ?d 1 calcFunc-dfact ) @@ -656,11 +410,11 @@ ( ( ?b 2 calcFunc-bern ) ( ?c 2 calcFunc-perm ) ( ?e 2 calcFunc-euler ) - ( ?s 2 calcFunc-stir2 ) ) -)) + ( ?s 2 calcFunc-stir2 ) ))) + (defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign ) - ( ?= 1 calcFunc-evalto ) ) -)) + ( ?= 1 calcFunc-evalto ) ))) + (defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv ) ( ?D 1 calcFunc-date ) ( ?I 2 calcFunc-incmonth ) @@ -668,8 +422,8 @@ ( ?M 1 calcFunc-newmonth ) ( ?W 1 calcFunc-newweek ) ( ?U 1 calcFunc-unixtime ) - ( ?Y 1 calcFunc-newyear ) ) -)) + ( ?Y 1 calcFunc-newyear ) ))) + (defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov ) ( ?G 1 calcFunc-vgmean ) ( ?M 1 calcFunc-vmean ) @@ -684,8 +438,8 @@ ( ?M 1 calcFunc-vmedian ) ( ?S 1 calcFunc-vvar ) ) ( ( ?M 1 calcFunc-vhmean ) - ( ?S 1 calcFunc-vpvar ) ) -)) + ( ?S 1 calcFunc-vpvar ) ))) + (defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange ) ( ?b 2 calcFunc-cvec ) ( ?c 2 calcFunc-mcol ) @@ -742,8 +496,259 @@ ( ?U 2 calcFunc-anest ) ) ( ( ?h 1 calcFunc-rtail ) ( ?R 1 calcFunc-fixp ) - ( ?U 1 calcFunc-afixp ) ) -)) + ( ?U 1 calcFunc-afixp ) ))) + + +;;; 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)))))) ;;; Convert a variable name (as a formula) into a like-looking function name. |