-;; Calculator for GNU Emacs, part II [calc-map.el]
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
-;; Written by Dave Gillespie, daveg@synaptics.com.
+;;; calc-map.el --- higher-order functions for Calc
+
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: David Gillespie <daveg@synaptics.com>
+;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
;; This file is part of GNU Emacs.
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY. No author or distributor
-;; accepts responsibility to anyone for the consequences of using it
-;; or for whether it serves any particular purpose or works at all,
-;; unless he says so in writing. Refer to the GNU Emacs General Public
-;; License for full details.
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
-;; Everyone is granted permission to copy, modify and redistribute
-;; GNU Emacs, but only under the conditions described in the
-;; GNU Emacs General Public License. A copy of this license is
-;; supposed to have been given to you along with GNU Emacs so you
-;; can know your rights and responsibilities. It should be in a
-;; file named COPYING. Among other things, the copyright notice
-;; and this notice must be preserved on all copies.
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;; Commentary:
+;;; Code:
;; This file is autoloaded from calc-ext.el.
-(require 'calc-ext)
+(require 'calc-ext)
(require 'calc-macs)
-(defun calc-Need-calc-map () nil)
-
-
(defun calc-apply (&optional oper)
(interactive)
(calc-wrapper
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)
(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 )
( ?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 )
( ?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 )
( ?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 )
( ?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 )
( ( ?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 )
( ?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 )
( ?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 )
( ?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)
+(defvar calc-get-operator-history nil
+ "History for calc-get-operator.")
+
+(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: " nil
+ 'calc-get-operator-history)))
+ (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))
+ '(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.
(cons f args))))))
;;; Do substitutions in parallel to avoid crosstalk.
+
+;; The variables math-ms-temp and math-ms-args are local to
+;; math-multi-subst, but are used by math-multi-subst-rec, which
+;; is called by math-multi-subst.
+(defvar math-ms-temp)
+(defvar math-ms-args)
+
(defun math-multi-subst (expr olds news)
- (let ((args nil)
- temp)
+ (let ((math-ms-args nil)
+ math-ms-temp)
(while (and olds news)
- (setq args (cons (cons (car olds) (car news)) args)
+ (setq math-ms-args (cons (cons (car olds) (car news)) math-ms-args)
olds (cdr olds)
news (cdr news)))
(math-multi-subst-rec expr)))
(defun math-multi-subst-rec (expr)
- (cond ((setq temp (assoc expr args)) (cdr temp))
+ (cond ((setq math-ms-temp (assoc expr math-ms-args))
+ (cdr math-ms-temp))
((Math-primp expr) expr)
((and (eq (car expr) 'calcFunc-lambda) (> (length expr) 2))
(let ((new (list (car expr)))
- (args args))
+ (math-ms-args math-ms-args))
(while (cdr (setq expr (cdr expr)))
(setq new (cons (car expr) new))
- (if (assoc (car expr) args)
- (setq args (cons (cons (car expr) (car expr)) args))))
+ (if (assoc (car expr) math-ms-args)
+ (setq math-ms-args (cons (cons (car expr) (car expr))
+ math-ms-args))))
(nreverse (cons (math-multi-subst-rec (car expr)) new))))
(t
(cons (car expr)
(calcFunc-mod . math-mod)
(calcFunc-vconcat .
math-concat) )))
- lfunc)))
+ func)))
(while (cdr vec)
(setq expr (funcall lfunc expr (nth 1 vec))
vec (cdr vec)))))
(math-normalize (cons 'vec (nreverse mat)))))
-(defun calcFunc-inner (mul-func add-func a b)
+;; The variables math-inner-mul-func and math-inner-add-func are
+;; local to calcFunc-inner, but are used by math-inner-mats,
+;; which is called by math-inner-mats.
+(defvar math-inner-mul-func)
+(defvar math-inner-add-func)
+
+(defun calcFunc-inner (math-inner-mul-func math-inner-add-func a b)
(or (math-vectorp a) (math-reject-arg a 'vectorp))
(or (math-vectorp b) (math-reject-arg b 'vectorp))
(if (math-matrixp a)
(math-dimension-error))))
(if (math-matrixp b)
(nth 1 (math-inner-mats (list 'vec a) b))
- (calcFunc-reduce add-func (calcFunc-map mul-func a b)))))
+ (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b)))))
(defun math-inner-mats (a b)
(let ((mat nil)
(setq col cols
row nil)
(while (> (setq col (1- col)) 0)
- (setq row (cons (calcFunc-reduce add-func
- (calcFunc-map mul-func
+ (setq row (cons (calcFunc-reduce math-inner-add-func
+ (calcFunc-map math-inner-mul-func
(car a)
(math-mat-col b col)))
row)))
(setq mat (cons (cons 'vec row) mat)))
(cons 'vec (nreverse mat))))
-;;; calc-map.el ends here
+(provide 'calc-map)
+;;; calc-map.el ends here
HCoop / bpt / emacs.git / blobdiff