Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume24/gnucalc/part20

Text File | 1991-10-31 | 55.2 KB | 1,807 lines

Newsgroups: comp.sources.misc
From: [e-mail] (David Gillespie)
Subject:  v24i068:  gnucalc - GNU Emacs Calculator, v2.00, Part20/56
Message-ID: <[e-mail]>
X-Md4-Signature: 11216148d336062cdeea96b5953f7641
Date: Thu, 31 Oct 1991 07:26:23 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (David Gillespie)
Posting-number: Volume 24, Issue 68
Archive-name: gnucalc/part20
Environment: Emacs
Supersedes: gmcalc: Volume 13, Issue 27-45

---- Cut Here and unpack ----
#!/bin/sh
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-maint.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 20; then
    echo Please unpack part "$Scheck" next!
    exit 1
 else
    exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
    echo 'x - still skipping calc-maint.el'
else
echo 'x - continuing file calc-maint.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-maint.el' &&
X    (beginning-of-line)
X    (setq tutpos (point))
X    (search-forward "@c [reference]")
X    (beginning-of-line)
X    (setq refpos (point))
X    (search-forward "@c [end]")
X    (beginning-of-line)
X    (setq endpos (point))
X    (find-file "calctut.tex")
X    (erase-buffer)
X    (insert-buffer-substring srcbuf 1 refpos)
X    (insert-buffer-substring srcbuf endpos maxpos)
X    (calc-split-volume "I" "ref" "Tutorial" "Reference")
X    (save-buffer)
X    (find-file "calcref.tex")
X    (erase-buffer)
X    (insert-buffer-substring srcbuf 1 tutpos)
X    (insert "\n@tex\n\\global\\advance\\chapno by 1\n@end tex\n")
X    (insert-buffer-substring srcbuf refpos maxpos)
X    (calc-split-volume "II" "tut" "Reference" "Tutorial")
X    (save-buffer)
X    (switch-to-buffer srcbuf)
X    (goto-char 1))
X  (message "Wrote files calctut.tex and calcref.tex")
)
X
(defun calc-split-volume (number fix name other-name)
X  (goto-char 1)
X  (search-forward "@c [title]\n")
X  (search-forward "Manual")
X  (delete-backward-char 6)
X  (insert name)
X  (search-forward "@c [volume]\n")
X  (insert "@sp 1\n@center Volume " number ": " name "\n")
X  (let ((pat (format "@c \\[fix-%s \\(.*\\)\\]\n" fix)))
X    (while (re-search-forward pat nil t)
X      (let ((topic (buffer-substring (match-beginning 1) (match-end 1))))
X    (re-search-forward "@\\(p?xref\\){[^}]*}")
X    (let ((cmd (buffer-substring (match-beginning 1) (match-end 1))))
X      (delete-region (match-beginning 0) (match-end 0))
X      (insert (if (equal cmd "pxref") "see" "See")
X          " ``" topic "'' in @emph{the Calc "
X          other-name "}")))))
X  (goto-char 1)
X  (while (search-forward "@c [when-split]\n" nil t)
X    (while (looking-at "@c ")
X      (delete-char 3)
X      (forward-line 1)))
X  (goto-char 1)
X  (while (search-forward "@c [not-split]\n" nil t)
X    (while (not (looking-at "@c"))
X      (insert "@c ")
X      (forward-line 1)))
)
X
X
(defun calc-split-summary (&optional force)
X  "Make a special \"calcsum.tex\" file with just the Calc summary."
X  (interactive "P")
X  (or (let ((case-fold-search t))
X    (string-match "calc\\.texinfo" (buffer-name)))
X      force
X      (error "This command should be used in the calc.texinfo buffer."))
X  (let ((srcbuf (current-buffer))
X    begpos sumpos endpos)
X    (goto-char 1)
X    (search-forward "{Calc Manual}")
X    (backward-char 1)
X    (delete-backward-char 6)
X    (insert "Summary")
X    (search-forward "@c [begin]")
X    (beginning-of-line)
X    (setq begpos (point))
X    (search-forward "@c [summary]")
X    (beginning-of-line)
X    (setq sumpos (point))
X    (search-forward "@c [end-summary]")
X    (beginning-of-line)
X    (setq endpos (point))
X    (find-file "calcsum.tex")
X    (erase-buffer)
X    (insert-buffer-substring srcbuf 1 begpos)
X    (insert "@tex\n"
X        "\\global\\advance\\appendixno2\n"
X        "\\gdef\\xref#1.{See ``#1.''}\n"
X        "@end tex\n")
X    (insert-buffer-substring srcbuf sumpos endpos)
X    (insert "@bye\n")
X    (goto-char 1)
X    (if (search-forward "@c smallbook" nil t)
X    (progn   ; activate "smallbook" format for compactness
X      (beginning-of-line)
X      (forward-char 1)
X      (delete-char 2)))
X    (save-buffer))
X  (message "Wrote file calcsum.tex")
)
X
X
X
(defun calc-public-autoloads ()
X  "Modify the public \"default\" file to contain the necessary autoload and
global-set-key commands for Calc."
X  (interactive)
X  (let ((home default-directory)
X    (p load-path)
X    instbuf name)
X    (while (and p
X        (not (file-exists-p
X              (setq name (expand-file-name "default" (car p)))))
X        (not (file-exists-p
X              (setq name (expand-file-name "default.el" (car p))))))
X      (setq p (cdr p)))
X    (or p (error "Unable to find \"default\" file.  Create one and try again."))
X    (find-file name)
X    (if buffer-read-only (error "No write permission for \"%s\"" buffer-file-name))
X    (goto-char (point-max))
X    (calc-add-autoloads home "calc-public-autoloads"))
)
X
(defun calc-private-autoloads ()
X  "Modify the public \"default\" file to contain the necessary autoload and
global-set-key commands for Calc."
X  (interactive)
X  (let ((home default-directory))
X    (find-file "~/.emacs")
X    (goto-char (point-max))
X    (calc-add-autoloads home "calc-private-autoloads"))
)
X
(defun calc-add-autoloads (home cmd)
X  (barf-if-buffer-read-only)
X  (let (top)
X    (if (and (re-search-backward ";;; Commands added by calc-.*-autoloads"
X                 nil t)
X         (setq top (point))
X         (search-forward ";;; End of Calc autoloads" nil t))
X    (progn
X      (forward-line 1)
X      (message "(Removing previous autoloads)")
X      (delete-region top (point)))
X      (insert "\n\n")
X      (backward-char 1)))
X  (insert ";;; Commands added by " cmd " on "
X      (current-time-string) ".
\(autoload 'calc-dispatch       \"calc\" \"Calculator Options\" t)
\(autoload 'full-calc           \"calc\" \"Full-screen Calculator\" t)
\(autoload 'full-calc-keypad       \"calc\" \"Full-screen X Calculator\" t)
\(autoload 'calc-eval           \"calc\" \"Use Calculator from Lisp\")
\(autoload 'defmath           \"calc\" nil t t)
\(autoload 'calc               \"calc\" \"Calculator Mode\" t)
\(autoload 'quick-calc           \"calc\" \"Quick Calculator\" t)
\(autoload 'calc-keypad           \"calc\" \"X windows Calculator\" t)
\(autoload 'calc-embedded       \"calc\" \"Use Calc inside any buffer\" t)
\(autoload 'calc-embedded-activate  \"calc\" \"Activate =>'s in buffer\" t)
\(autoload 'calc-grab-region       \"calc\" \"Grab region of Calc data\" t)
\(autoload 'calc-grab-rectangle       \"calc\" \"Grab rectangle of data\" t)
\(autoload 'edit-kbd-macro       \"macedit\" \"Edit Keyboard Macro\" t)
\(autoload 'edit-last-kbd-macro       \"macedit\" \"Edit Keyboard Macro\" t)
\(autoload 'read-kbd-macro       \"macedit\" \"Read Keyboard Macro\" t)
\(setq load-path (append load-path (list \"" (directory-file-name home) "\")))
\(global-set-key \"\\e#\" 'calc-dispatch)
;;; End of Calc autoloads.\n")
X  (save-buffer)
)
X
X
X
;;; End.
SHAR_EOF
echo 'File calc-maint.el is complete' &&
chmod 0644 calc-maint.el ||
echo 'restore of calc-maint.el failed'
Wc_c="`wc -c < 'calc-maint.el'`"
test 12652 -eq "$Wc_c" ||
    echo 'calc-maint.el: original size 12652, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-map.el ==============
if test -f 'calc-map.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-map.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-map.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-map.el' &&
;; Calculator for GNU Emacs, part II [calc-map.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; 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.
X
;; 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.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-map () nil)
X
X
(defun calc-apply (&optional oper)
X  (interactive)
X  (calc-wrapper
X   (let* ((sel-mode nil)
X      (calc-dollar-values (mapcar 'calc-get-stack-element
X                      (nthcdr calc-stack-top calc-stack)))
X      (calc-dollar-used 0)
X      (oper (or oper (calc-get-operator "Apply"
X                        (if (math-vectorp (calc-top 1))
X                        (1- (length (calc-top 1)))
X                          -1))))
X      (expr (calc-top-n (1+ calc-dollar-used))))
X     (message "Working...")
X     (calc-set-command-flag 'clear-message)
X     (calc-enter-result (1+ calc-dollar-used)
X            (concat (substring "apl" 0 (- 4 (length (nth 2 oper))))
X                (nth 2 oper))
X            (list 'calcFunc-apply
X                  (math-calcFunc-to-var (nth 1 oper))
X                  expr))))
)
X
(defun calc-reduce (&optional oper accum)
X  (interactive)
X  (calc-wrapper
X   (let* ((sel-mode nil)
X      (nest (calc-is-hyperbolic))
X      (rev (calc-is-inverse))
X      (nargs (if (and nest (not rev)) 2 1))
X      (calc-dollar-values (mapcar 'calc-get-stack-element
X                      (nthcdr calc-stack-top calc-stack)))
X      (calc-dollar-used 0)
X      (calc-mapping-dir (and (not accum) (not nest) ""))
X      (oper (or oper (calc-get-operator
X              (if nest
X                  (concat (if accum "Accumulate " "")
X                      (if rev "Fixed Point" "Nest"))
X                (concat (if rev "Inv " "")
X                    (if accum "Accumulate" "Reduce")))
X              (if nest 1 2)))))
X     (message "Working...")
X     (calc-set-command-flag 'clear-message)
X     (calc-enter-result (+ calc-dollar-used nargs)
X            (concat (substring (if nest
X                           (if rev "fxp" "nst")
X                         (if accum "acc" "red"))
X                       0 (- 4 (length (nth 2 oper))))
X                (nth 2 oper))
X            (if nest
X                (cons (if rev
X                      (if accum 'calcFunc-afixp 'calcFunc-fixp)
X                    (if accum 'calcFunc-anest 'calcFunc-nest))
X                  (cons (math-calcFunc-to-var (nth 1 oper))
X                    (calc-top-list-n
X                     nargs (1+ calc-dollar-used))))
X              (list (if accum
X                    (if rev 'calcFunc-raccum 'calcFunc-accum)
X                  (intern (concat "calcFunc-"
X                          (if rev "r" "")
X                          "reduce"
X                          calc-mapping-dir)))
X                (math-calcFunc-to-var (nth 1 oper))
X                (calc-top-n (1+ calc-dollar-used)))))))
)
X
(defun calc-accumulate (&optional oper)
X  (interactive)
X  (calc-reduce oper t)
)
X
(defun calc-map (&optional oper)
X  (interactive)
X  (calc-wrapper
X   (let* ((sel-mode nil)
X      (calc-dollar-values (mapcar 'calc-get-stack-element
X                      (nthcdr calc-stack-top calc-stack)))
X      (calc-dollar-used 0)
X      (calc-mapping-dir "")
X      (oper (or oper (calc-get-operator "Map")))
X      (nargs (car oper)))
X     (message "Working...")
X     (calc-set-command-flag 'clear-message)
X     (calc-enter-result (+ nargs calc-dollar-used)
X            (concat (substring "map" 0 (- 4 (length (nth 2 oper))))
X                (nth 2 oper))
X            (cons (intern (concat "calcFunc-map" calc-mapping-dir))
X                  (cons (math-calcFunc-to-var (nth 1 oper))
X                    (calc-top-list-n
X                     nargs
X                     (1+ calc-dollar-used)))))))
)
X
(defun calc-map-equation (&optional oper)
X  (interactive)
X  (calc-wrapper
X   (let* ((sel-mode nil)
X      (calc-dollar-values (mapcar 'calc-get-stack-element
X                      (nthcdr calc-stack-top calc-stack)))
X      (calc-dollar-used 0)
X      (oper (or oper (calc-get-operator "Map-equation")))
X      (nargs (car oper)))
X     (message "Working...")
X     (calc-set-command-flag 'clear-message)
X     (calc-enter-result (+ nargs calc-dollar-used)
X            (concat (substring "map" 0 (- 4 (length (nth 2 oper))))
X                (nth 2 oper))
X            (cons (if (calc-is-inverse)
X                  'calcFunc-mapeqr
X                (if (calc-is-hyperbolic)
X                    'calcFunc-mapeqp 'calcFunc-mapeq))
X                  (cons (math-calcFunc-to-var (nth 1 oper))
X                    (calc-top-list-n
X                     nargs
X                     (1+ calc-dollar-used)))))))
)
X
(defun calc-map-stack ()
X  "This is meant to be called by calc-keypad mode."
X  (interactive)
X  (let ((calc-verify-arglist nil))
X    (setq unread-command-char ?\$)
X    (calc-map))
)
X
(defun calc-outer-product (&optional oper)
X  (interactive)
X  (calc-wrapper
X   (let* ((sel-mode nil)
X      (calc-dollar-values (mapcar 'calc-get-stack-element
X                      (nthcdr calc-stack-top calc-stack)))
X      (calc-dollar-used 0)
X      (oper (or oper (calc-get-operator "Outer" 2))))
X     (message "Working...")
X     (calc-set-command-flag 'clear-message)
X     (calc-enter-result (+ 2 calc-dollar-used)
X            (concat (substring "out" 0 (- 4 (length (nth 2 oper))))
X                (nth 2 oper))
X            (cons 'calcFunc-outer
X                  (cons (math-calcFunc-to-var (nth 1 oper))
X                    (calc-top-list-n
X                     2 (1+ calc-dollar-used)))))))
)
X
(defun calc-inner-product (&optional mul-oper add-oper)
X  (interactive)
X  (calc-wrapper
X   (let* ((sel-mode nil)
X      (calc-dollar-values (mapcar 'calc-get-stack-element
X                      (nthcdr calc-stack-top calc-stack)))
X      (calc-dollar-used 0)
X      (mul-oper (or mul-oper (calc-get-operator "Inner (Mult)" 2)))
X      (mul-used calc-dollar-used)
X      (calc-dollar-values (if (> mul-used 0)
X                  (cdr calc-dollar-values)
X                calc-dollar-values))
X      (calc-dollar-used 0)
X      (add-oper (or add-oper (calc-get-operator "Inner (Add)" 2))))
X     (message "Working...")
X     (calc-set-command-flag 'clear-message)
X     (calc-enter-result (+ 2 mul-used calc-dollar-used)
X            (concat "in"
X                (substring (nth 2 mul-oper) 0 1)
X                (substring (nth 2 add-oper) 0 1))
X            (nconc (list 'calcFunc-inner
X                     (math-calcFunc-to-var (nth 1 mul-oper))
X                     (math-calcFunc-to-var (nth 1 add-oper)))
X                   (calc-top-list-n
X                2 (+ 1 mul-used calc-dollar-used))))))
)
X
;;; Return a list of the form (nargs func name)
(defun calc-get-operator (msg &optional nargs)
X  (setq calc-aborted-prefix nil)
X  (let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil)
X    done key oper (which 0)
X    (msgs '( "(Press ? for help)"
X         "+, -, *, /, ^, %, \\, :, &, !, |, Neg"
X         "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt"
X         "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB"
X         "Algebra + Simp, Esimp, Deriv, Integ, !, =, etc."
X         "Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip"
X         "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction"
X         "Functions + Re, Im; Hypot; Mant, Expon, Scale; etc."
X         "Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc."
X         "Time/date + newYear, Incmonth, etc."
X         "Vectors + Length, Row, Col, Diag, Mask, etc."
X         "_ = mapr/reducea, : = mapc/reduced, = = reducer"
X         "X or Z = any function by name; ' = alg entry; $ = stack")))
X    (while (not done)
X      (message "%s%s: %s: %s%s%s"
X           msg
X           (cond ((equal calc-mapping-dir "r") " rows")
X             ((equal calc-mapping-dir "c") " columns")
X             ((equal calc-mapping-dir "a") " across")
X             ((equal calc-mapping-dir "d") " down")
X             (t ""))
X           (if forcenargs
X           (format "(%d arg%s)"
X               forcenargs (if (= forcenargs 1) "" "s"))
X         (nth which msgs))
X           (if inv "Inv " "") (if hyp "Hyp " "")
X           (if prefix (concat (char-to-string prefix) "-") ""))
X      (setq key (read-char))
X      (if (>= key 128) (setq key (- key 128)))
X      (cond ((memq key '(?\C-g ?q))
X         (keyboard-quit))
X        ((memq key '(?\C-u ?\e)))
X        ((= key ??)
X         (setq which (% (1+ which) (length msgs))))
X        ((and (= key ?I) (null prefix))
X         (setq inv (not inv)))
X        ((and (= key ?H) (null prefix))
X         (setq hyp (not hyp)))
X        ((and (eq key prefix) (not (eq key ?v)))
X         (setq prefix nil))
X        ((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V))
X          (null prefix))
X         (setq prefix (downcase key)))
X        ((and (eq key ?\=) (null prefix))
X         (if calc-mapping-dir
X         (setq calc-mapping-dir (if (equal calc-mapping-dir "r")
X                        "" "r"))
X           (beep)))
X        ((and (eq key ?\_) (null prefix))
X         (if calc-mapping-dir
X         (if (string-match "map$" msg)
X             (setq calc-mapping-dir (if (equal calc-mapping-dir "r")
X                        "" "r"))
X           (setq calc-mapping-dir (if (equal calc-mapping-dir "a")
X                          "" "a")))
X           (beep)))
X        ((and (eq key ?\:) (null prefix))
X         (if calc-mapping-dir
X         (if (string-match "map$" msg)
X             (setq calc-mapping-dir (if (equal calc-mapping-dir "c")
X                        "" "c"))
X           (setq calc-mapping-dir (if (equal calc-mapping-dir "d")
X                          "" "d")))
X           (beep)))
X        ((and (>= key ?0) (<= key ?9) (null prefix))
X         (setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0)))
X         (and nargs forcenargs (/= nargs forcenargs) (>= nargs 0)
X          (error "Must be a %d-argument operator" nargs)))
X        ((memq key '(?\$ ?\'))
X         (let* ((arglist nil)
X            (has-args nil)
X            (record-entry nil)
X            (expr (if (eq key ?\$)
X                  (progn
X                (setq calc-dollar-used 1)
X                (if calc-dollar-values
X                    (car calc-dollar-values)
X                  (error "Stack underflow")))
X                (let* ((calc-dollar-values calc-arg-values)
X                   (calc-dollar-used 0)
X                   (calc-hashes-used 0)
X                   (func (calc-do-alg-entry "" "Function: ")))
X                  (setq record-entry t)
X                  (or (= (length func) 1)
X                  (error "Bad format"))
X                  (if (> calc-dollar-used 0)
X                  (progn
X                    (setq has-args calc-dollar-used
X                      arglist (calc-invent-args has-args))
X                    (math-multi-subst (car func)
X                              (reverse arglist)
X                              arglist))
X                (if (> calc-hashes-used 0)
X                    (setq has-args calc-hashes-used
X                      arglist (calc-invent-args has-args)))
X                (car func))))))
X           (if (eq (car-safe expr) 'calcFunc-lambda)
X           (setq oper (list "$" (- (length expr) 2) expr)
X             done t)
X         (or has-args
X             (progn
X               (calc-default-formula-arglist expr)
X               (setq record-entry t
X                 arglist (sort arglist 'string-lessp))
X               (if calc-verify-arglist
X               (setq arglist (read-from-minibuffer
X                      "Function argument list: "
X                      (if arglist
X                          (prin1-to-string arglist)
X                        "()")
X                      minibuffer-local-map
X                      t)))
X               (setq arglist (mapcar (function
X                          (lambda (x)
X                        (list 'var
X                              x
X                              (intern
X                               (concat
X                            "var-"
X                            (symbol-name x))))))
X                         arglist))))
X         (setq oper (list "$"
X                  (length arglist)
X                  (append '(calcFunc-lambda) arglist
X                      (list expr)))
X               done t))
X           (if record-entry
X           (calc-record (nth 2 oper) "oper"))))
X        ((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0))
X                       (if prefix
X                       (symbol-value
X                        (intern (format "calc-%c-oper-keys"
X                                prefix)))
X                     calc-oper-keys))))
X         (if (eq (nth 1 oper) 'user)
X         (let ((func (intern
X                  (completing-read "Function name: "
X                           obarray 'fboundp
X                           nil "calcFunc-"))))
X           (if (or forcenargs nargs)
X               (setq oper (list "z" (or forcenargs nargs) func)
X                 done t)
X             (if (fboundp func)
X             (let* ((defn (symbol-function func)))
X               (and (symbolp defn)
X                (setq defn (symbol-function defn)))
X               (if (eq (car-safe defn) 'lambda)
X                   (let ((args (nth 1 defn))
X                     (nargs 0))
X                 (while (not (memq (car args) '(&optional
X                                &rest nil)))
X                   (setq nargs (1+ nargs)
X                     args (cdr args)))
X                 (setq oper (list "z" nargs func)
X                       done t))
X                 (error
X                  "Function is not suitable for this operation")))
X               (message "Number of arguments: ")
X               (let ((nargs (read-char)))
X             (if (and (>= nargs ?0) (<= nargs ?9))
X                 (setq oper (list "z" (- nargs ?0) func)
X                   done t)
X               (beep))))))
X           (if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U)))
X               (and (eq prefix ?a) (eq key ?M)))
X           (let* ((dir (cond ((and (equal calc-mapping-dir "")
X                       (string-match "map$" msg))
X                      (setq calc-mapping-dir "r")
X                      " rows")
X                     ((equal calc-mapping-dir "r") " rows")
X                     ((equal calc-mapping-dir "c") " columns")
X                     ((equal calc-mapping-dir "a") " across")
X                     ((equal calc-mapping-dir "d") " down")
X                     (t "")))
X              (calc-mapping-dir (and (memq (nth 2 oper)
X                               '(calcFunc-map
X                             calcFunc-reduce
X                             calcFunc-rreduce))
X                         ""))
X              (oper2 (calc-get-operator
X                  (format "%s%s, %s%s" msg dir
X                      (substring (symbol-name (nth 2 oper))
X                             9)
X                      (if (eq key ?I) " (mult)" ""))
X                  (cdr (assq (nth 2 oper)
X                         '((calcFunc-reduce  . 2)
X                           (calcFunc-rreduce . 2)
X                           (calcFunc-accum   . 2)
X                           (calcFunc-raccum  . 2)
X                           (calcFunc-nest    . 2)
X                           (calcFunc-anest   . 2)
X                           (calcFunc-fixp    . 2)
X                           (calcFunc-afixp   . 2))))))
X              (oper3 (if (eq (nth 2 oper) 'calcFunc-inner)
X                     (calc-get-operator
X                      (format "%s%s, inner (add)" msg dir
X                          (substring
X                           (symbol-name (nth 2 oper))
X                           9)))
X                   '(0 0 0)))
X              (args nil)
X              (nargs (if (> (nth 1 oper) 0)
X                     (nth 1 oper)
X                   (car oper2)))
X              (n nargs)
X              (p calc-arg-values))
X             (while (and p (> n 0))
X               (or (math-expr-contains (nth 1 oper2) (car p))
X               (math-expr-contains (nth 1 oper3) (car p))
X               (setq args (nconc args (list (car p)))
X                 n (1- n)))
X               (setq p (cdr p)))
X             (setq oper (list "" nargs
X                      (append
X                       '(calcFunc-lambda)
X                       args
X                       (list (math-build-call
X                          (intern
X                           (concat
X                        (symbol-name (nth 2 oper))
X                        calc-mapping-dir))
X                          (cons (math-calcFunc-to-var
X                             (nth 1 oper2))
X                            (if (eq key ?I)
X                            (cons
X                             (math-calcFunc-to-var
X                              (nth 1 oper3))
X                             args)
X                              args))))))
X               done t))
X         (setq done t))))
X        (t (beep))))
X    (and nargs (>= nargs 0)
X     (/= nargs (nth 1 oper))
X     (error "Must be a %d-argument operator" nargs))
X    (append (if forcenargs
X        (cons forcenargs (cdr (cdr oper)))
X          (cdr oper))
X        (list
X         (let ((name (concat (if inv "I" "") (if hyp "H" "")
X                 (if prefix (char-to-string prefix) "")
X                 (char-to-string key))))
X           (if (> (length name) 3)
X           (substring name 0 3)
X         name)))))
)
(setq calc-verify-arglist t)
(setq calc-mapping-dir nil)
X
(defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add )
X                  ( ?- 2 calcFunc-sub )
X                  ( ?* 2 calcFunc-mul )
X                  ( ?/ 2 calcFunc-div )
X                  ( ?^ 2 calcFunc-pow )
X                  ( ?| 2 calcFunc-vconcat )
X                  ( ?% 2 calcFunc-mod )
X                  ( ?\\ 2 calcFunc-idiv )
X                  ( ?! 1 calcFunc-fact )
X                  ( ?& 1 calcFunc-inv )
X                  ( ?n 1 calcFunc-neg )
X                  ( ?x user )
X                  ( ?z user )
X                  ( ?A 1 calcFunc-abs )
X                  ( ?J 1 calcFunc-conj )
X                  ( ?G 1 calcFunc-arg )
X                  ( ?Q 1 calcFunc-sqrt )
X                  ( ?N 2 calcFunc-min )
X                  ( ?X 2 calcFunc-max )
X                  ( ?F 1 calcFunc-floor )
X                  ( ?R 1 calcFunc-round )
X                  ( ?S 1 calcFunc-sin )
X                  ( ?C 1 calcFunc-cos )
X                  ( ?T 1 calcFunc-tan )
X                  ( ?L 1 calcFunc-ln )
X                  ( ?E 1 calcFunc-exp )
X                  ( ?B 2 calcFunc-log ) )
X                ( ( ?F 1 calcFunc-ceil )     ; inverse
X                  ( ?R 1 calcFunc-trunc )
X                  ( ?Q 1 calcFunc-sqr )
X                  ( ?S 1 calcFunc-arcsin )
X                  ( ?C 1 calcFunc-arccos )
X                  ( ?T 1 calcFunc-arctan )
X                  ( ?L 1 calcFunc-exp )
X                  ( ?E 1 calcFunc-ln )
X                  ( ?B 2 calcFunc-alog )
X                  ( ?^ 2 calcFunc-nroot )
X                  ( ?| 2 calcFunc-vconcatrev ) )
X                ( ( ?F 1 calcFunc-ffloor )   ; hyperbolic
X                  ( ?R 1 calcFunc-fround )
X                  ( ?S 1 calcFunc-sinh )
X                  ( ?C 1 calcFunc-cosh )
X                  ( ?T 1 calcFunc-tanh )
X                  ( ?L 1 calcFunc-log10 )
X                  ( ?E 1 calcFunc-exp10 )
X                  ( ?| 2 calcFunc-append ) )
X                ( ( ?F 1 calcFunc-fceil )    ; inverse-hyperbolic
X                  ( ?R 1 calcFunc-ftrunc )
X                  ( ?S 1 calcFunc-arcsinh )
X                  ( ?C 1 calcFunc-arccosh )
X                  ( ?T 1 calcFunc-arctanh )
X                  ( ?L 1 calcFunc-exp10 )
X                  ( ?E 1 calcFunc-log10 )
X                  ( ?| 2 calcFunc-appendrev ) )
))
(defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart )
X                ( ?b 3 calcFunc-subst )
X                ( ?c 2 calcFunc-collect )
X                ( ?d 2 calcFunc-deriv )
X                ( ?e 1 calcFunc-esimplify )
X                ( ?f 2 calcFunc-factor )
X                ( ?g 2 calcFunc-pgcd )
X                ( ?i 2 calcFunc-integ )
X                ( ?m 2 calcFunc-match )
X                ( ?n 1 calcFunc-nrat )
X                ( ?r 2 calcFunc-rewrite )
X                ( ?s 1 calcFunc-simplify )
X                ( ?t 3 calcFunc-taylor )
X                ( ?x 1 calcFunc-expand )
X                ( ?M 2 calcFunc-mapeq )
X                ( ?N 3 calcFunc-minimize )
X                ( ?P 2 calcFunc-roots )
X                ( ?R 3 calcFunc-root )
X                ( ?S 2 calcFunc-solve )
X                ( ?T 4 calcFunc-table )
X                ( ?X 3 calcFunc-maximize )
X                ( ?= 2 calcFunc-eq )
X                ( ?\# 2 calcFunc-neq )
X                ( ?< 2 calcFunc-lt )
X                ( ?> 2 calcFunc-gt )
X                ( ?\[ 2 calcFunc-leq )
X                ( ?\] 2 calcFunc-geq )
X                ( ?{ 2 calcFunc-in )
X                ( ?! 1 calcFunc-lnot )
X                ( ?& 2 calcFunc-land )
X                ( ?\| 2 calcFunc-lor )
X                ( ?: 3 calcFunc-if )
X                ( ?. 2 calcFunc-rmeq )
X                ( ?+ 4 calcFunc-sum )
X                ( ?- 4 calcFunc-asum )
X                ( ?* 4 calcFunc-prod )
X                ( ?_ 2 calcFunc-subscr )
X                ( ?\\ 2 calcFunc-pdiv )
X                ( ?% 2 calcFunc-prem )
X                ( ?/ 2 calcFunc-pdivrem ) )
X                  ( ( ?m 2 calcFunc-matchnot )
X                ( ?M 2 calcFunc-mapeqr )
X                ( ?S 2 calcFunc-finv ) )
X                  ( ( ?d 2 calcFunc-tderiv )
X                ( ?f 2 calcFunc-factors )
X                ( ?M 2 calcFunc-mapeqp )
X                ( ?N 3 calcFunc-wminimize )
X                ( ?R 3 calcFunc-wroot )
X                ( ?S 2 calcFunc-fsolve )
X                ( ?X 3 calcFunc-wmaximize )
X                ( ?/ 2 calcFunc-pdivide ) )
X                  ( ( ?S 2 calcFunc-ffinv ) )
))
(defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and )
X                ( ?o 2 calcFunc-or )
X                ( ?x 2 calcFunc-xor )
X                ( ?d 2 calcFunc-diff )
X                ( ?n 1 calcFunc-not )
X                ( ?c 1 calcFunc-clip )
X                ( ?l 2 calcFunc-lsh )
X                ( ?r 2 calcFunc-rsh )
X                ( ?L 2 calcFunc-ash )
X                ( ?R 2 calcFunc-rash )
X                ( ?t 2 calcFunc-rot )
X                ( ?p 1 calcFunc-vpack )
X                ( ?u 1 calcFunc-vunpack )
X                ( ?D 4 calcFunc-ddb )
X                ( ?F 3 calcFunc-fv )
X                ( ?I 1 calcFunc-irr )
X                ( ?M 3 calcFunc-pmt )
X                ( ?N 2 calcFunc-npv )
X                ( ?P 3 calcFunc-pv )
X                ( ?S 3 calcFunc-sln )
X                ( ?T 3 calcFunc-rate )
X                ( ?Y 4 calcFunc-syd )
X                ( ?\# 3 calcFunc-nper ) )
X                  ( ( ?F 3 calcFunc-fvb )
X                ( ?I 1 calcFunc-irrb )
X                ( ?M 3 calcFunc-pmtb )
X                ( ?N 2 calcFunc-npvb )
X                ( ?P 3 calcFunc-pvb )
X                ( ?T 3 calcFunc-rateb )
X                ( ?\# 3 calcFunc-nperb ) )
X                  ( ( ?F 3 calcFunc-fvl )
X                ( ?M 3 calcFunc-pmtl )
X                ( ?P 3 calcFunc-pvl )
X                ( ?T 3 calcFunc-ratel )
X                ( ?\# 3 calcFunc-nperl ) )
))
(defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg )
X                ( ?r 1 calcFunc-rad )
X                ( ?h 1 calcFunc-hms )
X                ( ?f 1 calcFunc-float )
X                ( ?F 1 calcFunc-frac ) )
))
(defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta )
X                ( ?e 1 calcFunc-erf )
X                ( ?g 1 calcFunc-gamma )
X                ( ?h 2 calcFunc-hypot )
X                ( ?i 1 calcFunc-im )
X                ( ?j 2 calcFunc-besJ )
X                ( ?n 2 calcFunc-min )
X                ( ?r 1 calcFunc-re )
X                ( ?s 1 calcFunc-sign )
X                ( ?x 2 calcFunc-max )
X                ( ?y 2 calcFunc-besY )
X                ( ?A 1 calcFunc-abssqr )
X                ( ?B 3 calcFunc-betaI )
X                ( ?E 1 calcFunc-expm1 )
X                ( ?G 2 calcFunc-gammaP )
X                ( ?I 2 calcFunc-ilog )
X                ( ?L 1 calcFunc-lnp1 )
X                ( ?M 1 calcFunc-mant )
X                ( ?Q 1 calcFunc-isqrt )
X                ( ?S 1 calcFunc-scf )
X                ( ?T 2 calcFunc-arctan2 )
X                ( ?X 1 calcFunc-xpon )
X                ( ?\[ 2 calcFunc-decr )
X                ( ?\] 2 calcFunc-incr ) )
X                  ( ( ?e 1 calcFunc-erfc )
X                ( ?E 1 calcFunc-lnp1 )
X                ( ?G 2 calcFunc-gammaQ )
X                ( ?L 1 calcFunc-expm1 ) )
X                  ( ( ?B 3 calcFunc-betaB )
X                ( ?G 2 calcFunc-gammag) )
X                  ( ( ?G 2 calcFunc-gammaG ) )
))
(defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern )
X                ( ?c 2 calcFunc-choose )
X                ( ?d 1 calcFunc-dfact )
X                ( ?e 1 calcFunc-euler )
X                ( ?f 1 calcFunc-prfac )
X                ( ?g 2 calcFunc-gcd )
X                ( ?h 2 calcFunc-shuffle )
X                ( ?l 2 calcFunc-lcm )
X                ( ?m 1 calcFunc-moebius )
X                ( ?n 1 calcFunc-nextprime )
X                ( ?r 1 calcFunc-random )
X                ( ?s 2 calcFunc-stir1 )
X                ( ?t 1 calcFunc-totient )
X                ( ?B 3 calcFunc-utpb )
X                ( ?C 2 calcFunc-utpc )
X                ( ?F 3 calcFunc-utpf )
X                ( ?N 3 calcFunc-utpn )
X                ( ?P 2 calcFunc-utpp )
X                ( ?T 2 calcFunc-utpt ) )
X                  ( ( ?n 1 calcFunc-prevprime )
X                ( ?B 3 calcFunc-ltpb )
X                ( ?C 2 calcFunc-ltpc )
X                ( ?F 3 calcFunc-ltpf )
X                ( ?N 3 calcFunc-ltpn )
X                ( ?P 2 calcFunc-ltpp )
X                ( ?T 2 calcFunc-ltpt ) )
X                  ( ( ?b 2 calcFunc-bern )
X                ( ?c 2 calcFunc-perm )
X                ( ?e 2 calcFunc-euler )
X                ( ?s 2 calcFunc-stir2 ) )
))
(defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign )
X                ( ?= 1 calcFunc-evalto ) )
))
(defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv )
X                ( ?D 1 calcFunc-date )
X                ( ?I 2 calcFunc-incmonth )
X                ( ?J 1 calcFunc-julian )
X                ( ?M 1 calcFunc-newmonth )
X                ( ?W 1 calcFunc-newweek )
X                ( ?U 1 calcFunc-unixtime )
X                ( ?Y 1 calcFunc-newyear ) )
))
(defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov )
X                ( ?G 1 calcFunc-vgmean )
X                ( ?M 1 calcFunc-vmean )
X                ( ?N 1 calcFunc-vmin )
X                ( ?S 1 calcFunc-vsdev )
X                ( ?X 1 calcFunc-vmax ) )
X                  ( ( ?C 2 calcFunc-vpcov )
X                ( ?M 1 calcFunc-vmeane )
X                ( ?S 1 calcFunc-vpsdev ) )
X                  ( ( ?C 2 calcFunc-vcorr )
X                ( ?G 1 calcFunc-agmean )
X                ( ?M 1 calcFunc-vmedian )
X                ( ?S 1 calcFunc-vvar ) )
X                  ( ( ?M 1 calcFunc-vhmean )
X                ( ?S 1 calcFunc-vpvar ) )
))
(defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange )
X                ( ?b 2 calcFunc-cvec )
X                ( ?c 2 calcFunc-mcol )
X                ( ?d 2 calcFunc-diag )
X                ( ?e 2 calcFunc-vexp )
X                ( ?f 2 calcFunc-find )
X                ( ?h 1 calcFunc-head )
X                ( ?k 2 calcFunc-cons )
X                ( ?l 1 calcFunc-vlen )
X                ( ?m 2 calcFunc-vmask )
X                ( ?n 1 calcFunc-rnorm )
X                ( ?p 2 calcFunc-pack )
X                ( ?r 2 calcFunc-mrow )
X                ( ?s 3 calcFunc-subvec )
X                ( ?t 1 calcFunc-trn )
X                ( ?u 1 calcFunc-unpack )
X                ( ?v 1 calcFunc-rev )
X                ( ?x 1 calcFunc-index )
X                ( ?A 1 calcFunc-apply )
X                ( ?C 1 calcFunc-cross )
X                ( ?D 1 calcFunc-det )
X                ( ?E 1 calcFunc-venum )
X                ( ?F 1 calcFunc-vfloor )
X                ( ?G 1 calcFunc-grade )
X                ( ?H 2 calcFunc-histogram )
X                ( ?I 2 calcFunc-inner )
X                ( ?L 1 calcFunc-lud )
X                ( ?M 0 calcFunc-map )
X                ( ?N 1 calcFunc-cnorm )
X                ( ?O 2 calcFunc-outer )
X                ( ?R 1 calcFunc-reduce )
X                ( ?S 1 calcFunc-sort )
X                ( ?T 1 calcFunc-tr )
X                ( ?U 1 calcFunc-accum )
X                ( ?V 2 calcFunc-vunion )
X                ( ?X 2 calcFunc-vxor )
X                ( ?- 2 calcFunc-vdiff )
X                ( ?^ 2 calcFunc-vint )
X                ( ?~ 1 calcFunc-vcompl )
X                ( ?# 1 calcFunc-vcard )
X                ( ?: 1 calcFunc-vspan )
X                ( ?+ 1 calcFunc-rdup ) )
X                  ( ( ?h 1 calcFunc-tail )
X                ( ?s 3 calcFunc-rsubvec )
X                ( ?G 1 calcFunc-rgrade )
X                ( ?R 1 calcFunc-rreduce )
X                ( ?S 1 calcFunc-rsort )
X                ( ?U 1 calcFunc-raccum ) )
X                  ( ( ?e 3 calcFunc-vexp )
X                ( ?h 1 calcFunc-rhead )
X                ( ?k 2 calcFunc-rcons )
X                ( ?H 3 calcFunc-histogram )
X                ( ?R 2 calcFunc-nest )
X                ( ?U 2 calcFunc-anest ) )
X                  ( ( ?h 1 calcFunc-rtail )
X                ( ?R 1 calcFunc-fixp )
X                ( ?U 1 calcFunc-afixp ) )
))
X
X
;;; Convert a variable name (as a formula) into a like-looking function name.
(defun math-var-to-calcFunc (f)
X  (if (eq (car-safe f) 'var)
X      (if (fboundp (nth 2 f))
X      (nth 2 f)
X    (intern (concat "calcFunc-" (symbol-name (nth 1 f)))))
X    (if (memq (car-safe f) '(lambda calcFunc-lambda))
X    f
X      (math-reject-arg f "*Expected a function name")))
)
X
;;; Convert a function name into a like-looking variable name formula.
(defun math-calcFunc-to-var (f)
X  (if (symbolp f)
X      (let* ((func (or (cdr (assq f '( ( + . calcFunc-add )
X                       ( - . calcFunc-sub )
X                       ( * . calcFunc-mul )
X                       ( / . calcFunc-div )
X                       ( ^ . calcFunc-pow )
X                       ( % . calcFunc-mod )
X                       ( neg . calcFunc-neg )
X                       ( | . calcFunc-vconcat ) )))
X               f))
X         (base (if (string-match "\\`calcFunc-\\(.+\\)\\'"
X                     (symbol-name func))
X               (math-match-substring (symbol-name func) 1)
X             (symbol-name func))))
X    (list 'var
X          (intern base)
X          (intern (concat "var-" base))))
X    f)
)
X
;;; Expand a function call using "lambda" notation.
(defun math-build-call (f args)
X  (if (eq (car-safe f) 'calcFunc-lambda)
X      (if (= (length args) (- (length f) 2))
X      (math-multi-subst (nth (1- (length f)) f) (cdr f) args)
X    (calc-record-why "*Wrong number of arguments" f)
X    (cons 'calcFunc-call (cons (math-calcFunc-to-var f) args)))
X    (if (and (eq f 'calcFunc-neg)
X         (= (length args) 1))
X    (list 'neg (car args))
X      (let ((func (assq f '( ( calcFunc-add . + )
X                 ( calcFunc-sub . - )
X                 ( calcFunc-mul . * )
X                 ( calcFunc-div . / )
X                 ( calcFunc-pow . ^ )
X                 ( calcFunc-mod . % )
X                 ( calcFunc-vconcat . | ) ))))
X    (if (and func (= (length args) 2))
X        (cons (cdr func) args)
X      (cons f args)))))
)
X
;;; Do substitutions in parallel to avoid crosstalk.
(defun math-multi-subst (expr olds news)
X  (let ((args nil)
X    temp)
X    (while (and olds news)
X      (setq args (cons (cons (car olds) (car news)) args)
X        olds (cdr olds)
X        news (cdr news)))
X    (math-multi-subst-rec expr))
)
X
(defun math-multi-subst-rec (expr)
X  (cond ((setq temp (assoc expr args)) (cdr temp))
X    ((Math-primp expr) expr)
X    ((and (eq (car expr) 'calcFunc-lambda) (> (length expr) 2))
X     (let ((new (list (car expr)))
X           (args args))
X       (while (cdr (setq expr (cdr expr)))
X         (setq new (cons (car expr) new))
X         (if (assoc (car expr) args)
X         (setq args (cons (cons (car expr) (car expr)) args))))
X       (nreverse (cons (math-multi-subst-rec (car expr)) new))))
X    (t
X     (cons (car expr)
X           (mapcar 'math-multi-subst-rec (cdr expr)))))
)
X
(defun calcFunc-call (f &rest args)
X  (setq args (math-build-call (math-var-to-calcFunc f) args))
X  (if (eq (car-safe args) 'calcFunc-call)
X      args
X    (math-normalize args))
)
X
(defun calcFunc-apply (f args)
X  (or (Math-vectorp args)
X      (math-reject-arg args 'vectorp))
X  (apply 'calcFunc-call (cons f (cdr args)))
)
X
X
X
X
;;; Map a function over a vector symbolically. [Public]
(defun math-symb-map (f mode args)
X  (let* ((func (math-var-to-calcFunc f))
X     (nargs (length args))
X     (ptrs (vconcat args))
X     (vflags (make-vector nargs nil))
X     (heads '(vec))
X     (head nil)
X     (vec nil)
X     (i -1)
X     (math-working-step 0)
X     (math-working-step-2 nil)
X     len cols obj expr)
X    (if (eq mode 'eqn)
X    (setq mode 'elems
X          heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt
X                  calcFunc-leq calcFunc-geq))
X      (while (and (< (setq i (1+ i)) nargs)
X          (not (math-matrixp (aref ptrs i)))))
X      (if (< i nargs)
X      (if (eq mode 'elems)
X          (setq func (list 'lambda '(&rest x)
X                   (list 'math-symb-map
X                     (list 'quote f) '(quote elems) 'x))
X            mode 'rows)
X        (if (eq mode 'cols)
X        (while (< i nargs)
X          (if (math-matrixp (aref ptrs i))
X              (aset ptrs i (math-transpose (aref ptrs i))))
X          (setq i (1+ i)))))
X    (setq mode 'elems))
X      (setq i -1))
X    (while (< (setq i (1+ i)) nargs)
X      (setq obj (aref ptrs i))
X      (if (and (memq (car-safe obj) heads)
X           (or (eq mode 'elems)
X           (math-matrixp obj)))
X      (progn
X        (aset vflags i t)
X        (if head
X        (if (cdr heads)
X            (setq head (nth
X                (aref (aref [ [0 1 2 3 4 5]
X                          [1 1 2 3 2 3]
X                          [2 2 2 1 2 1]
X                          [3 3 1 3 1 3]
X                          [4 2 2 1 4 1]
X                          [5 3 1 3 1 5] ]
X                        (- 6 (length (memq head heads))))
X                      (- 6 (length (memq (car obj) heads))))
X                heads)))
X          (setq head (car obj)))
X        (if len
X        (or (= (length obj) len)
X            (math-dimension-error))
X          (setq len (length obj))))))
X    (or len
X    (if (= nargs 1)
X        (math-reject-arg (aref ptrs 0) 'vectorp)
X      (math-reject-arg nil "At least one argument must be a vector")))
X    (setq math-working-step-2 (1- len))
X    (while (> (setq len (1- len)) 0)
X      (setq expr nil
X        i -1)
X      (while (< (setq i (1+ i)) nargs)
X    (if (aref vflags i)
X        (progn
X          (aset ptrs i (cdr (aref ptrs i)))
X          (setq expr (nconc expr (list (car (aref ptrs i))))))
X      (setq expr (nconc expr (list (aref ptrs i))))))
X      (setq math-working-step (1+ math-working-step)
X        vec (cons (math-normalize (math-build-call func expr)) vec)))
X    (setq vec (cons head (nreverse vec)))
X    (if (and (eq mode 'cols) (math-matrixp vec))
X    (math-transpose vec)
X      vec))
)
X
(defun calcFunc-map (func &rest args)
X  (math-symb-map func 'elems args)
)
X
(defun calcFunc-mapr (func &rest args)
X  (math-symb-map func 'rows args)
)
X
(defun calcFunc-mapc (func &rest args)
X  (math-symb-map func 'cols args)
)
X
(defun calcFunc-mapa (func arg)
X  (if (math-matrixp arg)
X      (math-symb-map func 'elems (cdr (math-transpose arg)))
X    (math-symb-map func 'elems arg))
)
X
(defun calcFunc-mapd (func arg)
X  (if (math-matrixp arg)
X      (math-symb-map func 'elems (cdr arg))
X    (math-symb-map func 'elems arg))
)
X
(defun calcFunc-mapeq (func &rest args)
X  (if (and (or (equal func '(var mul var-mul))
X           (equal func '(var div var-div)))
X       (= (length args) 2))
X      (if (math-negp (car args))
X      (let ((func (nth 1 (assq (car-safe (nth 1 args))
X                   calc-tweak-eqn-table))))
X        (and func (setq args (list (car args)
X                       (cons func (cdr (nth 1 args)))))))
X    (if (math-negp (nth 1 args))
X        (let ((func (nth 1 (assq (car-safe (car args))
X                     calc-tweak-eqn-table))))
X          (and func (setq args (list (cons func (cdr (car args)))
X                     (nth 1 args))))))))
X  (if (or (and (equal func '(var div var-div))
X           (assq (car-safe (nth 1 args)) calc-tweak-eqn-table))
X      (equal func '(var neg var-neg))
X      (equal func '(var inv var-inv)))
X      (apply 'calcFunc-mapeqr func args)
X    (apply 'calcFunc-mapeqp func args))
)
X
(defun calcFunc-mapeqr (func &rest args)
X  (setq args (mapcar (function (lambda (x)
X                 (let ((func (assq (car-safe x)
X                           calc-tweak-eqn-table)))
X                   (if func
X                       (cons (nth 1 func) (cdr x))
X                     x))))
X             args))
X  (apply 'calcFunc-mapeqp func args)
)
X
(defun calcFunc-mapeqp (func &rest args)
X  (if (or (and (memq (car-safe (car args)) '(calcFunc-lt calcFunc-leq))
X           (memq (car-safe (nth 1 args)) '(calcFunc-gt calcFunc-geq)))
X      (and (memq (car-safe (car args)) '(calcFunc-gt calcFunc-geq))
X           (memq (car-safe (nth 1 args)) '(calcFunc-lt calcFunc-leq))))
X      (setq args (cons (car args)
X               (cons (list (nth 1 (assq (car (nth 1 args))
X                        calc-tweak-eqn-table))
X                   (nth 2 (nth 1 args))
X                   (nth 1 (nth 1 args)))
X                 (cdr (cdr args))))))
X  (math-symb-map func 'eqn args)
)
X
X
X
;;; Reduce a function over a vector symbolically. [Public]
(defun calcFunc-reduce (func vec)
X  (if (math-matrixp vec)
X      (let (expr row)
X    (setq func (math-var-to-calcFunc func))
X    (while (setq vec (cdr vec))
X      (setq row (car vec))
X      (while (setq row (cdr row))
X        (setq expr (if expr
X               (math-build-call func (list expr (car row)))
X             (car row)))))
X    (math-normalize expr))
X    (calcFunc-reducer func vec))
)
X
(defun calcFunc-rreduce (func vec)
X  (if (math-matrixp vec)
X      (let (expr row)
X    (setq func (math-var-to-calcFunc func)
X          vec (reverse (cdr vec)))
X    (while vec
X      (setq row (reverse (cdr (car vec))))
X      (while row
X        (setq expr (if expr
X               (math-build-call func (list (car row) expr))
X             (car row))
X          row (cdr row)))
X      (setq vec (cdr vec)))
X    (math-normalize expr))
X    (calcFunc-rreducer func vec))
)
X
(defun calcFunc-reducer (func vec)
X  (setq func (math-var-to-calcFunc func))
X  (or (math-vectorp vec)
X      (math-reject-arg vec 'vectorp))
X  (let ((expr (car (setq vec (cdr vec)))))
X    (if expr
X    (progn
X      (while (setq vec (cdr vec))
X        (setq expr (math-build-call func (list expr (car vec)))))
X      (math-normalize expr))
X      (or (math-identity-value func)
X      (math-reject-arg vec "*Vector is empty"))))
)
X
(defun math-identity-value (func)
X  (cdr (assq func '( (calcFunc-add . 0) (calcFunc-sub . 0)
X             (calcFunc-mul . 1) (calcFunc-div . 1)
X             (calcFunc-idiv . 1) (calcFunc-fdiv . 1)
X             (calcFunc-min . (var inf var-inf))
X             (calcFunc-max . (neg (var inf var-inf)))
X             (calcFunc-vconcat . (vec))
X             (calcFunc-append . (vec)) )))
)
X
(defun calcFunc-rreducer (func vec)
X  (setq func (math-var-to-calcFunc func))
X  (or (math-vectorp vec)
X      (math-reject-arg vec 'vectorp))
X  (if (eq func 'calcFunc-sub)   ; do this in a way that looks nicer
X      (let ((expr (car (setq vec (cdr vec)))))
X    (if expr
X        (progn
X          (while (setq vec (cdr vec))
X        (setq expr (math-build-call func (list expr (car vec)))
X              func (if (eq func 'calcFunc-sub)
X                   'calcFunc-add 'calcFunc-sub)))
X          (math-normalize expr))
X      0))
X    (let ((expr (car (setq vec (reverse (cdr vec))))))
X      (if expr
X      (progn
X        (while (setq vec (cdr vec))
X          (setq expr (math-build-call func (list (car vec) expr))))
X        (math-normalize expr))
X    (or (math-identity-value func)
X        (math-reject-arg vec "*Vector is empty")))))
)
X
(defun calcFunc-reducec (func vec)
X  (if (math-matrixp vec)
X      (calcFunc-reducer func (math-transpose vec))
X    (calcFunc-reducer func vec))
)
X
(defun calcFunc-rreducec (func vec)
X  (if (math-matrixp vec)
X      (calcFunc-rreducer func (math-transpose vec))
X    (calcFunc-rreducer func vec))
)
X
(defun calcFunc-reducea (func vec)
X  (if (math-matrixp vec)
X      (cons 'vec
X        (mapcar (function (lambda (x) (calcFunc-reducer func x)))
X            (cdr vec)))
X    (calcFunc-reducer func vec))
)
X
(defun calcFunc-rreducea (func vec)
X  (if (math-matrixp vec)
X      (cons 'vec
X        (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
X            (cdr vec)))
X    (calcFunc-rreducer func vec))
)
X
(defun calcFunc-reduced (func vec)
X  (if (math-matrixp vec)
X      (cons 'vec
X        (mapcar (function (lambda (x) (calcFunc-reducer func x)))
X            (cdr (math-transpose vec))))
X    (calcFunc-reducer func vec))
)
X
(defun calcFunc-rreduced (func vec)
X  (if (math-matrixp vec)
X      (cons 'vec
X        (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
X            (cdr (math-transpose vec))))
X    (calcFunc-rreducer func vec))
)
X
(defun calcFunc-accum (func vec)
X  (setq func (math-var-to-calcFunc func))
X  (or (math-vectorp vec)
X      (math-reject-arg vec 'vectorp))
X  (let* ((expr (car (setq vec (cdr vec))))
X     (res (list 'vec expr)))
X    (or expr
X    (math-reject-arg vec "*Vector is empty"))
X    (while (setq vec (cdr vec))
X      (setq expr (math-build-call func (list expr (car vec)))
X        res (nconc res (list expr))))
X    (math-normalize res))
)
X
(defun calcFunc-raccum (func vec)
X  (setq func (math-var-to-calcFunc func))
X  (or (math-vectorp vec)
X      (math-reject-arg vec 'vectorp))
X  (let* ((expr (car (setq vec (reverse (cdr vec)))))
X     (res (list expr)))
X    (or expr
X    (math-reject-arg vec "*Vector is empty"))
X    (while (setq vec (cdr vec))
X      (setq expr (math-build-call func (list (car vec) expr))
X        res (cons (list expr) res)))
X    (math-normalize (cons 'vec res)))
)
X
X
(defun math-nest-calls (func base iters accum tol)
X  (or (symbolp tol)
X      (if (math-realp tol)
X      (or (math-numberp base) (math-reject-arg base 'numberp))
X    (math-reject-arg tol 'realp)))
X  (setq func (math-var-to-calcFunc func))
X  (or (null iters)
X      (if (equal iters '(var inf var-inf))
X      (setq iters nil)
X    (progn
X      (if (math-messy-integerp iters)
X          (setq iters (math-trunc iters)))
X      (or (integerp iters) (math-reject-arg iters 'fixnump))
X      (or (not tol) (natnump iters) (math-reject-arg iters 'fixnatnump))
X      (if (< iters 0)
X          (let* ((dummy '(var DummyArg var-DummyArg))
X             (dummy2 '(var DummyArg2 var-DummyArg2))
X             (finv (math-solve-for (math-build-call func (list dummy2))
X                       dummy dummy2 nil)))
X        (or finv (math-reject-arg nil "*Unable to find an inverse"))
X        (if (and (= (length finv) 2)
X             (equal (nth 1 finv) dummy))
X            (setq func (car finv))
X          (setq func (list 'calcFunc-lambda dummy finv)))
X        (setq iters (- iters)))))))
X  (math-with-extra-prec 1
X    (let ((value base)
X      (ovalue nil)
X      (avalues (list base))
X      (math-working-step 0)
X      (math-working-step-2 iters))
X      (while (and (or (null iters)
X              (>= (setq iters (1- iters)) 0))
X          (or (null tol)
X              (null ovalue)
X              (if (eq tol t)
X              (not (if (and (Math-numberp value)
X                    (Math-numberp ovalue))
X                   (math-nearly-equal value ovalue)
X                 (Math-equal value ovalue)))
X            (if (math-numberp value)
X                (Math-lessp tol (math-abs (math-sub value ovalue)))
X              (math-reject-arg value 'numberp)))))
X    (setq ovalue value
X          math-working-step (1+ math-working-step)
X          value (math-normalize (math-build-call func (list value))))
X    (if accum
X        (setq avalues (cons value avalues))))
X      (if accum
X      (cons 'vec (nreverse avalues))
X    value)))
)
X
(defun calcFunc-nest (func base iters)
X  (math-nest-calls func base iters nil nil)
)
X
(defun calcFunc-anest (func base iters)
X  (math-nest-calls func base iters t nil)
)
X
(defun calcFunc-fixp (func base &optional iters tol)
X  (math-nest-calls func base iters nil (or tol t))
)
X
(defun calcFunc-afixp (func base &optional iters tol)
X  (math-nest-calls func base iters t (or tol t))
)
X
X
(defun calcFunc-outer (func a b)
X  (or (math-vectorp a) (math-reject-arg a 'vectorp))
X  (or (math-vectorp b) (math-reject-arg b 'vectorp))
X  (setq func (math-var-to-calcFunc func))
X  (let ((mat nil))
X    (while (setq a (cdr a))
X      (setq mat (cons (cons 'vec
X                (mapcar (function (lambda (x)
X                        (math-build-call func
X                                 (list (car a)
X                                       x))))
X                    (cdr b)))
X              mat)))
X    (math-normalize (cons 'vec (nreverse mat))))
)
X
X
(defun calcFunc-inner (mul-func add-func a b)
X  (or (math-vectorp a) (math-reject-arg a 'vectorp))
X  (or (math-vectorp b) (math-reject-arg b 'vectorp))
X  (if (math-matrixp a)
X      (if (math-matrixp b)
X      (if (= (length (nth 1 a)) (length b))
X          (math-inner-mats a b)
X        (math-dimension-error))
X    (if (= (length (nth 1 a)) 2)
X        (if (= (length a) (length b))
X        (math-inner-mats a (list 'vec b))
X          (math-dimension-error))
X      (if (= (length (nth 1 a)) (length b))
X          (math-mat-col (math-inner-mats a (math-col-matrix b))
X                1)
X        (math-dimension-error))))
X    (if (math-matrixp b)
X    (nth 1 (math-inner-mats (list 'vec a) b))
X      (calcFunc-reduce add-func (calcFunc-map mul-func a b))))
)
X
(defun math-inner-mats (a b)
X  (let ((mat nil)
X    (cols (length (nth 1 b)))
X    row col ap bp accum)
X    (while (setq a (cdr a))
X      (setq col cols
X        row nil)
X      (while (> (setq col (1- col)) 0)
X    (setq row (cons (calcFunc-reduce add-func
X                     (calcFunc-map mul-func
X                               (car a)
X                               (math-mat-col b col)))
X            row)))
X      (setq mat (cons (cons 'vec row) mat)))
X    (cons 'vec (nreverse mat)))
)
X
X
X
SHAR_EOF
chmod 0644 calc-map.el ||
echo 'restore of calc-map.el failed'
Wc_c="`wc -c < 'calc-map.el'`"
test 39224 -eq "$Wc_c" ||
    echo 'calc-map.el: original size 39224, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-mat.el ==============
if test -f 'calc-mat.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-mat.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-mat.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-mat.el' &&
;; Calculator for GNU Emacs, part II [calc-mat.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; 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.
X
;; 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.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-mat () nil)
X
X
(defun calc-mdet (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "mdet" 'calcFunc-det arg))
)
X
(defun calc-mtrace (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "mtr" 'calcFunc-tr arg))
)
X
(defun calc-mlud (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "mlud" 'calcFunc-lud arg))
)
X
X
;;; Coerce row vector A to be a matrix.  [V V]
(defun math-row-matrix (a)
X  (if (and (Math-vectorp a)
X       (not (math-matrixp a)))
X      (list 'vec a)
X    a)
)
X
;;; Coerce column vector A to be a matrix.  [V V]
(defun math-col-matrix (a)
X  (if (and (Math-vectorp a)
X       (not (math-matrixp a)))
X      (cons 'vec (mapcar (function (lambda (x) (list 'vec x))) (cdr a)))
X    a)
)
X
X
X
;;; Multiply matrices A and B.  [V V V]
(defun math-mul-mats (a b)
X  (let ((mat nil)
X    (cols (length (nth 1 b)))
X    row col ap bp accum)
X    (while (setq a (cdr a))
X      (setq col cols
X        row nil)
X      (while (> (setq col (1- col)) 0)
X    (setq ap (cdr (car a))
X          bp (cdr b)
X          accum (math-mul (car ap) (nth col (car bp))))
X    (while (setq ap (cdr ap) bp (cdr bp))
X      (setq accum (math-add accum (math-mul (car ap) (nth col (car bp))))))
X    (setq row (cons accum row)))
X      (setq mat (cons (cons 'vec row) mat)))
X    (cons 'vec (nreverse mat)))
)
X
(defun math-mul-mat-vec (a b)
X  (cons 'vec (mapcar (function (lambda (row)
X                 (math-dot-product row b)))
X             (cdr a)))
)
X
X
X
(defun calcFunc-tr (mat)   ; [Public]
X  (if (math-square-matrixp mat)
X      (math-matrix-trace-step 2 (1- (length mat)) mat (nth 1 (nth 1 mat)))
X    (math-reject-arg mat 'square-matrixp))
)
X
(defun math-matrix-trace-step (n size mat sum)
X  (if (<= n size)
X      (math-matrix-trace-step (1+ n) size mat
X                  (math-add sum (nth n (nth n mat))))
X    sum)
)
X
X
;;; Matrix inverse and determinant.
(defun math-matrix-inv-raw (m)
X  (let ((n (1- (length m))))
X    (if (<= n 3)
X    (let ((det (math-det-raw m)))
X      (and (not (math-zerop det))
X           (math-div
X        (cond ((= n 1) 1)
X              ((= n 2)
X               (list 'vec
X                 (list 'vec
X                   (nth 2 (nth 2 m))
X                   (math-neg (nth 2 (nth 1 m))))
X                 (list 'vec
X                   (math-neg (nth 1 (nth 2 m)))
X                   (nth 1 (nth 1 m)))))
X              ((= n 3)
X               (list 'vec
X                 (list 'vec
X                   (math-sub (math-mul (nth 3 (nth 3 m))
X                               (nth 2 (nth 2 m)))
X                         (math-mul (nth 3 (nth 2 m))
X                               (nth 2 (nth 3 m))))
X                   (math-sub (math-mul (nth 3 (nth 1 m))
X                               (nth 2 (nth 3 m)))
X                         (math-mul (nth 3 (nth 3 m))
X                               (nth 2 (nth 1 m))))
X                   (math-sub (math-mul (nth 3 (nth 2 m))
X                               (nth 2 (nth 1 m)))
X                         (math-mul (nth 3 (nth 1 m))
X                               (nth 2 (nth 2 m)))))
X                 (list 'vec
X                   (math-sub (math-mul (nth 3 (nth 2 m))
X                               (nth 1 (nth 3 m)))
X                         (math-mul (nth 3 (nth 3 m))
X                               (nth 1 (nth 2 m))))
X                   (math-sub (math-mul (nth 3 (nth 3 m))
X                               (nth 1 (nth 1 m)))
X                         (math-mul (nth 3 (nth 1 m))
X                               (nth 1 (nth 3 m))))
X                   (math-sub (math-mul (nth 3 (nth 1 m))
X                               (nth 1 (nth 2 m)))
X                         (math-mul (nth 3 (nth 2 m))
X                               (nth 1 (nth 1 m)))))
X                 (list 'vec
X                   (math-sub (math-mul (nth 2 (nth 3 m))
X                               (nth 1 (nth 2 m)))
X                         (math-mul (nth 2 (nth 2 m))
X                               (nth 1 (nth 3 m))))
X                   (math-sub (math-mul (nth 2 (nth 1 m))
X                               (nth 1 (nth 3 m)))
X                         (math-mul (nth 2 (nth 3 m))
X                               (nth 1 (nth 1 m))))
X                   (math-sub (math-mul (nth 2 (nth 2 m))
X                               (nth 1 (nth 1 m)))
X                         (math-mul (nth 2 (nth 1 m))
X                               (nth 1 (nth 2 m))))))))
X        det)))
X      (let ((lud (math-matrix-lud m)))
X    (and lud
X         (math-lud-solve lud (calcFunc-idn 1 n))))))
)
X
(defun calcFunc-det (m)
X  (if (math-square-matrixp m)
X      (math-with-extra-prec 2 (math-det-raw m))
X    (if (and (eq (car-safe m) 'calcFunc-idn)
X         (or (math-zerop (nth 1 m))
X         (math-equal-int (nth 1 m) 1)))
X    (nth 1 m)
X      (math-reject-arg m 'square-matrixp)))
)
X
(defun math-det-raw (m)
X  (let ((n (1- (length m))))
X    (cond ((= n 1)
X       (nth 1 (nth 1 m)))
X      ((= n 2)
X       (math-sub (math-mul (nth 1 (nth 1 m))
X                   (nth 2 (nth 2 m)))
X             (math-mul (nth 2 (nth 1 m))
X                   (nth 1 (nth 2 m)))))
X      ((= n 3)
X       (math-sub
X        (math-sub
X         (math-sub
X          (math-add
X           (math-add
X        (math-mul (nth 1 (nth 1 m))
X              (math-mul (nth 2 (nth 2 m))
X                    (nth 3 (nth 3 m))))
X        (math-mul (nth 2 (nth 1 m))
X              (math-mul (nth 3 (nth 2 m))
X                    (nth 1 (nth 3 m)))))
X           (math-mul (nth 3 (nth 1 m))
X             (math-mul (nth 1 (nth 2 m))
X                   (nth 2 (nth 3 m)))))
X          (math-mul (nth 3 (nth 1 m))
X            (math-mul (nth 2 (nth 2 m))
X                  (nth 1 (nth 3 m)))))
X         (math-mul (nth 1 (nth 1 m))
X               (math-mul (nth 3 (nth 2 m))
X                 (nth 2 (nth 3 m)))))
X        (math-mul (nth 2 (nth 1 m))
X              (math-mul (nth 1 (nth 2 m))
X                (nth 3 (nth 3 m))))))
X      (t (let ((lud (math-matrix-lud m)))
X           (if lud
X           (let ((lu (car lud)))
X             (math-det-step n (nth 2 lud)))
X         0)))))
)
X
(defun math-det-step (n prod)
X  (if (> n 0)
X      (math-det-step (1- n) (math-mul prod (nth n (nth n lu))))
X    prod)
)
X
;;; This returns a list (LU index d), or NIL if not possible.
;;; Argument M must be a square matrix.
(defun math-matrix-lud (m)
X  (let ((old (assoc m math-lud-cache))
X    (context (list calc-internal-prec calc-prefer-frac)))
X    (if (and old (equal (nth 1 old) context))
X    (cdr (cdr old))
X      (let* ((lud (catch 'singular (math-do-matrix-lud m)))
X         (entry (cons context lud)))
X    (if old
X        (setcdr old entry)
X      (setq math-lud-cache (cons (cons m entry) math-lud-cache)))
X    lud)))
)
(defvar math-lud-cache nil)
X
;;; Numerical Recipes section 2.3; implicit pivoting omitted.
(defun math-do-matrix-lud (m)
X  (let* ((lu (math-copy-matrix m))
X     (n (1- (length lu)))
X     i (j 1) k imax sum big
X     (d 1) (index nil))
X    (while (<= j n)
X      (setq i 1
X        big 0
X        imax j)
X      (while (< i j)
X    (math-working "LUD step" (format "%d/%d" j i))
X    (setq sum (nth j (nth i lu))
X          k 1)
X    (while (< k i)
X      (setq sum (math-sub sum (math-mul (nth k (nth i lu))
X                        (nth j (nth k lu))))
X        k (1+ k)))
X    (setcar (nthcdr j (nth i lu)) sum)
X    (setq i (1+ i)))
X      (while (<= i n)
X    (math-working "LUD step" (format "%d/%d" j i))
X    (setq sum (nth j (nth i lu))
X          k 1)
X    (while (< k j)
X      (setq sum (math-sub sum (math-mul (nth k (nth i lu))
SHAR_EOF
true || echo 'restore of calc-mat.el failed'
fi
echo 'End of  part 20'
echo 'File calc-mat.el is continued in part 21'
echo 21 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].