daveg@csvax.caltech.edu (David Gillespie) (06/06/90)
Posting-number: Volume 13, Issue 32
Submitted-by: daveg@csvax.caltech.edu (David Gillespie)
Archive-name: gmcalc/part06
---- Cut Here and unpack ----
#!/bin/sh
# this is part 6 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-ext.el continued
#
CurArch=6
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
exit 1; fi
( read Scheck
if test "$Scheck" != $CurArch
then echo "Please unpack part $Scheck next!"
exit 1;
else exit 0; fi
) < s2_seq_.tmp || exit 1
echo "x - Continuing file calc-ext.el"
sed 's/^X//' << 'SHAR_EOF' >> calc-ext.el
X (setq msgs (cons buf msgs)
X buf "")
X (calc-user-function-list kmap 6))
X (if (/= flags 0)
X (setq msgs (cons buf msgs)))
X (calc-do-prefix-help (nreverse msgs) "user" ?z))
X)
X
X(defun calc-user-function-classify (key)
X (cond ((/= key (downcase key)) ; upper-case
X (if (assq (downcase key) (calc-user-key-map)) 9 1))
X ((/= key (upcase key)) 2) ; lower-case
X ((= key ??) 0)
X (t 4)) ; other
X)
X
X(defun calc-user-function-list (map flags)
X (and map
X (let* ((key (car (car map)))
X (kind (calc-user-function-classify key))
X (func (cdr (car map))))
X (if (= (logand kind flags) 0)
X ()
X (let* ((name (symbol-name func))
X (name (if (string-match "\\`calc-" name)
X (substring name 5) name))
X (pos (string-match (char-to-string key) name))
X (desc
X (if (symbolp func)
X (if (= (logand kind 3) 0)
X (format "`%c' = %s" key name)
X (if pos
X (format "%s%c%s"
X (downcase (substring name 0 pos))
X (upcase key)
X (downcase (substring name (1+ pos))))
X (format "%c = %s"
X (upcase key)
X (downcase name))))
X (char-to-string (upcase key)))))
X (if (= (length buf) 0)
X (setq buf (concat (if (= flags 1) "SHIFT + " "")
X desc))
X (if (> (+ (length buf) (length desc)) 58)
X (setq msgs (cons buf msgs)
X buf (concat (if (= flags 1) "SHIFT + " "")
X desc))
X (setq buf (concat buf ", " desc))))))
X (calc-user-function-list (cdr map) flags)))
X)
X
X
X
X(defun calc-shift-Z-prefix-help ()
X (interactive)
X (calc-do-prefix-help
X '("Define, Undefine, Formula, Kbd-macro, Edit, Get-defn"
X "Permanent; Var-perm"
X "kbd-macros: [ (if), : (else), | (else-if), ] (end-if)"
X "kbd-macros: < > (repeat), ( ) (for), { } (loop)"
X "kbd-macros: / (break)"
X "kbd-macros: ` (save), ' (restore)")
X "user" ?Z)
X)
X
X(defun calc-user-define ()
X "Bind a Calculator command to a key sequence using the z prefix."
X (interactive)
X (message "Define user key: z-")
X (let ((key (read-char)))
X (if (= (calc-user-function-classify key) 0)
X (error "Can't redefine \"?\" key"))
X (let ((func (intern (completing-read (concat "Set key z "
X (char-to-string key)
X " to command: ")
X obarray
X 'commandp
X t
X "calc-"))))
X (let* ((kmap (calc-user-key-map))
X (old (assq key kmap)))
X (if old
X (setcdr old func)
X (setcdr kmap (cons (cons key func) (cdr kmap)))))))
X)
X
X(defun calc-user-undefine ()
X "Remove the definition on a Calculator z prefix key."
X (interactive)
X (message "Undefine user key: z-")
X (let ((key (read-char)))
X (if (= (calc-user-function-classify key) 0)
X (error "Can't undefine \"?\" key"))
X (let* ((kmap (calc-user-key-map)))
X (delq (or (assq key kmap)
X (assq (upcase key) kmap)
X (assq (downcase key) kmap)
X (error "No such user key is defined"))
X kmap)))
X)
X
X(defun calc-user-define-formula ()
X "Define a new Calculator z-prefix command using formula at top of stack."
X (interactive)
X (calc-wrapper
X (let* ((form (calc-top 1))
X (arglist nil)
X odef key keyname cmd cmd-base func alist is-symb)
X (calc-default-formula-arglist form)
X (setq arglist (sort arglist 'string-lessp))
X (message "Define user key: z-")
X (setq key (read-char))
X (if (= (calc-user-function-classify key) 0)
X (error "Can't redefine \"?\" key"))
X (setq key (and (not (memq key '(13 32))) key)
X keyname (and key
X (if (or (and (<= ?0 key) (<= key ?9))
X (and (<= ?a key) (<= key ?z))
X (and (<= ?A key) (<= key ?Z)))
X (char-to-string key)
X (format "%03d" key)))
X odef (assq key (calc-user-key-map)))
X (while
X (progn
X (setq cmd (completing-read "Define M-x command name: "
X obarray 'commandp nil
X (if (and odef (symbolp (cdr odef)))
X (symbol-name (cdr odef))
X "calc-"))
X cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
X (math-match-substring cmd 1))
X cmd (and (not (or (string-equal cmd "")
X (string-equal cmd "calc-")))
X (intern cmd)))
X (and cmd
X (fboundp cmd)
X odef
X (not
X (y-or-n-p
X (if (get cmd 'calc-user-defn)
X (concat "Replace previous definition for "
X (symbol-name cmd) "? ")
X "That name conflicts with a built-in Emacs function. Replace this function? "))))))
X (if (and key (not cmd))
X (setq cmd (intern (concat "calc-User-" keyname))))
X (while
X (progn
X (setq func (completing-read "Define algebraic function name: "
X obarray 'fboundp nil
X (concat "calcFunc-"
X (if cmd-base
X (if (string-match
X "\\`User-.+" cmd-base)
X (concat
X "User"
X (substring cmd-base 5))
X cmd-base)
X "")))
X func (and (not (or (string-equal func "")
X (string-equal func "calcFunc-")))
X (intern func)))
X (and func
X (fboundp func)
X (not (fboundp cmd))
X odef
X (not
X (y-or-n-p
X (if (get func 'calc-user-defn)
X (concat "Replace previous definition for "
X (symbol-name func) "? ")
X "That name conflicts with a built-in Emacs function. Replace this function? "))))))
X (if (not func)
X (setq func (intern (concat "calcFunc-User"
X (or keyname
X (and cmd (symbol-name cmd))
X (format "%05d" (% (random) 10000)))))))
X (while
X (progn
X (setq alist (read-from-minibuffer "Function argument list: "
X (if arglist
X (prin1-to-string arglist)
X "()")
X minibuffer-local-map
X t))
X (and (not (calc-subsetp alist arglist))
X (y-or-n-p
X "Okay for arguments that don't appear in formula to be ignored? "))))
X (setq is-symb (and alist
X func
X (y-or-n-p
X "Leave it symbolic for non-constant arguments? ")))
X (if cmd
X (progn
X (fset cmd
X (list 'lambda
X '()
X "User-defined Calculator function."
X '(interactive)
X (list 'calc-wrapper
X (list 'calc-enter-result
X (length alist)
X (let ((name (symbol-name (or func cmd))))
X (and (string-match
X "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
X name)
X (math-match-substring name 1)))
X (list 'cons
X (list 'quote func)
X (list 'calc-top-list-n
X (length alist)))))))
X (put cmd 'calc-user-defn t)))
X (let ((body (list 'math-normalize (calc-fix-user-formula form))))
X (fset func
X (append
X (list 'lambda alist)
X (and is-symb
X (mapcar (function (lambda (v)
X (list 'math-check-const v)))
X alist))
X (list body))))
X (put func 'calc-user-defn form)
X (if key
X (let* ((kmap (calc-user-key-map))
X (old (assq key kmap)))
X (if old
X (setcdr old cmd)
X (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
X (message ""))
X)
X
X(defun calc-default-formula-arglist (form)
X (if (consp form)
X (if (eq (car form) 'var)
X (if (or (memq (nth 1 form) arglist)
X (boundp (nth 2 form)))
X ()
X (setq arglist (cons (nth 1 form) arglist)))
X (calc-default-formula-arglist-step (cdr form))))
X)
X
X(defun calc-default-formula-arglist-step (l)
X (and l
X (progn
X (calc-default-formula-arglist (car l))
X (calc-default-formula-arglist-step (cdr l))))
X)
X
X(defun calc-subsetp (a b)
X (or (null a)
X (and (memq (car a) b)
X (calc-subsetp (cdr a) b)))
X)
X
X(defun calc-fix-user-formula (f)
X (if (consp f)
X (cond ((and (eq (car f) 'var)
X (memq (nth 1 f) alist))
X (nth 1 f))
X ((math-constp f)
X (list 'quote f))
X (t
X (cons 'list
X (cons (list 'quote (car f))
X (mapcar 'calc-fix-user-formula (cdr f))))))
X f)
X)
X
X
X(defun calc-user-define-kbd-macro (arg)
X "Bind the most recent keyboard macro to a key sequence using the z prefix."
X (interactive "P")
X (or last-kbd-macro
X (error "No keyboard macro defined"))
X (message "Define last kbd macro on user key: z-")
X (let ((key (read-char)))
X (if (= (calc-user-function-classify key) 0)
X (error "Can't redefine \"?\" key"))
X (let ((cmd (intern (completing-read "Full name for new command: "
X obarray
X 'commandp
X nil
X (concat "calc-User-"
X (if (or (and (>= key ?a)
X (<= key ?z))
X (and (>= key ?A)
X (<= key ?Z))
X (and (>= key ?0)
X (<= key ?9)))
X (char-to-string key)
X (format "%03d" key)))))))
X (and (fboundp cmd)
X (not (let ((f (symbol-function cmd)))
X (or (stringp f)
X (and (consp f)
X (eq (car-safe (nth 3 f))
X 'calc-execute-kbd-macro)))))
X (error "Function %s is already defined and not a keyboard macro"
X cmd))
X (put cmd 'calc-user-defn t)
X (fset cmd (if (< (prefix-numeric-value arg) 0)
X last-kbd-macro
X (list 'lambda
X '(arg)
X '(interactive "P")
X (list 'calc-execute-kbd-macro
X last-kbd-macro
X 'arg))))
X (let* ((kmap (calc-user-key-map))
X (old (assq key kmap)))
X (if old
X (setcdr old cmd)
X (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
X)
X
X
X(defun calc-user-define-edit (prefix)
X "Edit the definition of a z-prefix command."
X (interactive "P") ; but no calc-wrapper!
X (message "Edit definition of command: z-")
X (let* ((key (read-char))
X (def (or (assq key (calc-user-key-map))
X (assq (upcase key) (calc-user-key-map))
X (assq (downcase key) (calc-user-key-map))
X (error "No command defined for that key")))
X (cmd (cdr def)))
X (if (symbolp cmd)
X (setq cmd (symbol-function cmd)))
X (cond ((or (stringp cmd)
X (and (consp cmd)
X (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
X (if (and (>= (prefix-numeric-value prefix) 0)
X (fboundp 'edit-kbd-macro)
X (symbolp (cdr def))
X (eq major-mode 'calc-mode))
X (progn
X (if (and (< (window-width) (screen-width))
X calc-display-trail)
X (let* ((trail (get-buffer-create "*Calc Trail*"))
X (win (get-buffer-window trail)))
X (if win
X (delete-window win))))
X (edit-kbd-macro (cdr def) prefix nil
X (function
X (lambda (x)
X (and calc-display-trail
X (calc-wrapper
X (calc-trail-display 1 t)))))
X (function
X (lambda (cmd)
X (if (stringp (symbol-function cmd))
X (symbol-function cmd)
X (nth 1 (nth 3 (symbol-function cmd))))))
X (function
X (lambda (new cmd)
X (if (stringp (symbol-function cmd))
X (fset cmd new)
X (setcar (cdr (nth 3 (symbol-function
X cmd)))
X new))))))
X (calc-wrapper
X (calc-edit-mode (list 'calc-finish-macro-edit
X (list 'quote def)))
X (insert (if (stringp cmd)
X cmd
X (nth 1 (nth 3 cmd)))))
X (calc-show-edit-buffer)))
X (t (let* ((func (calc-stack-command-p cmd))
X (defn (and func
X (symbolp func)
X (get func 'calc-user-defn))))
X (if (and defn (calc-valid-formula-func func))
X (progn
X (calc-wrapper
X (calc-edit-mode (list 'calc-finish-formula-edit
X (list 'quote func)))
X (insert (math-format-flat-expr defn 0) "\n"))
X (calc-show-edit-buffer))
X (error "That command's definition cannot be edited"))))))
X)
X
X(defun calc-finish-macro-edit (def)
X (let ((str (buffer-substring (point) (point-max))))
X (if (symbolp (cdr def))
X (if (stringp (symbol-function (cdr def)))
X (fset (cdr def) str)
X (setcar (cdr (nth 3 (symbol-function (cdr def)))) str))
X (setcdr def str)))
X)
X
X;;; The following are hooks into the MacEdit package from macedit.el.
X(put 'calc-execute-extended-command 'MacEdit-print
X (function (lambda ()
X (setq macro-str (concat "\excalc-" macro-str))))
X)
X
X(put 'calcDigit-start 'MacEdit-print
X (function (lambda ()
X (if calc-algebraic-mode
X (calc-macro-edit-algebraic)
X (MacEdit-unread-chars key-last)
X (let ((str "")
X (min-bsp 0)
X ch last)
X (while (and (setq ch (MacEdit-read-char))
X (or (and (>= ch ?0) (<= ch ?9))
X (memq ch '(?\. ?e ?\_ ?n ?\: ?\# ?M
X ?o ?h ?\@ ?\"))
X (and (memq ch '(?\' ?m ?s))
X (string-match "[@oh]" str))
X (and (or (and (>= ch ?a) (<= ch ?z))
X (and (>= ch ?A) (<= ch ?Z)))
X (string-match
X "^[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#"
X str))
X (and (memq ch '(?\177 ?\C-h))
X (> (length str) 0))
X (and (memq ch '(?+ ?-))
X (> (length str) 0)
X (eq (aref str (1- (length str)))
X ?e))))
X (if (or (and (>= ch ?0) (<= ch ?9))
X (and (or (not (memq ch '(?\177 ?\C-h)))
X (<= (length str) min-bsp))
X (setq min-bsp (1+ (length str)))))
X (setq str (concat str (char-to-string ch)))
X (setq str (substring str 0 -1))))
X (if (memq ch '(32 10 13))
X (setq str (concat str (char-to-string ch)))
X (MacEdit-unread-chars ch))
X (insert "type \"")
X (MacEdit-insert-string str)
X (insert "\"\n")))))
X)
X
X(defun calc-macro-edit-algebraic ()
X (MacEdit-unread-chars key-last)
X (let ((str "")
X (min-bsp 0))
X (while (progn
X (MacEdit-lookup-key calc-alg-ent-map)
X (or (and (memq key-symbol '(self-insert-command
X calcAlg-previous))
X (< (length str) 60))
X (memq key-symbol
X '(backward-delete-char
X delete-backward-char
X backward-delete-char-untabify))
X (eq key-last 9)))
X (setq macro-str (substring macro-str (length key-str)))
X (if (or (eq key-symbol 'self-insert-command)
X (and (or (not (memq key-symbol '(backward-delete-char
X delete-backward-char
X backward-delete-char-untabify)))
X (<= (length str) min-bsp))
X (setq min-bsp (+ (length str) (length key-str)))))
X (setq str (concat str key-str))
X (setq str (substring str 0 -1))))
X (if (memq key-last '(10 13))
X (setq str (concat str key-str)
X macro-str (substring macro-str (length key-str))))
X (if (> (length str) 0)
X (progn
X (insert "type \"")
X (MacEdit-insert-string str)
X (insert "\"\n"))))
X)
X(put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
X(put 'calc-dollar-sign 'MacEdit-print 'calc-macro-edit-algebraic)
X
X(defun calc-macro-edit-variable ()
X (let ((str "") ch)
X (insert (symbol-name key-symbol) "\n")
X (if (memq (MacEdit-peek-char) '(?\+ ?\- ?\* ?\/ ?\^ ?\|))
X (setq str (char-to-string (MacEdit-read-char))))
X (if (and (setq ch (MacEdit-peek-char))
X (>= ch ?0) (<= ch ?9))
X (insert "type \"" str
X (char-to-string (MacEdit-read-char)) "\"\n")
X (if (> (length str) 0)
X (insert "type \"" str "\"\n"))
X (MacEdit-read-argument)))
X)
X(put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)
X(put 'calc-recall 'MacEdit-print 'calc-macro-edit-variable)
X(put 'calc-let 'MacEdit-print 'calc-macro-edit-variable)
X
X
X(defun calc-finish-formula-edit (func)
X (let ((buf (current-buffer))
X (str (buffer-substring (point) (point-max)))
X (start (point))
X (body (calc-valid-formula-func func)))
X (set-buffer calc-original-buffer)
X (let ((val (math-read-expr str)))
X (if (eq (car-safe val) 'error)
X (progn
X (set-buffer buf)
X (goto-char (+ start (nth 1 val)))
X (error (nth 2 val))))
X (setcar (cdr body)
X (let ((alist (nth 1 (symbol-function func))))
X (calc-fix-user-formula val)))
X (put func 'calc-user-defn val)))
X)
X
X(defun calc-valid-formula-func (func)
X (let ((def (symbol-function func)))
X (and (consp def)
X (eq (car def) 'lambda)
X (progn
X (setq def (cdr (cdr def)))
X (while (and def
X (not (eq (car (car def)) 'math-normalize)))
X (setq def (cdr def)))
X (car def))))
X)
X
X
X(defun calc-get-user-defn ()
X "Extract the definition from a z-prefix command as a formula."
X (interactive)
X (calc-wrapper
X (message "Get definition of command: z-")
X (let* ((key (read-char))
X (def (or (assq key (calc-user-key-map))
X (assq (upcase key) (calc-user-key-map))
X (assq (downcase key) (calc-user-key-map))
X (error "No command defined for that key")))
X (cmd (cdr def)))
X (if (symbolp cmd)
X (setq cmd (symbol-function cmd)))
X (cond ((stringp cmd)
X (message "Keyboard macro: %s" cmd))
X (t (let* ((func (calc-stack-command-p cmd))
X (defn (and func
X (symbolp func)
X (get func 'calc-user-defn))))
X (if defn
X (calc-enter-result 0 "gdef" defn)
X (error "That command is not defined by a formula")))))))
X)
X
X
X(defun calc-user-define-permanent ()
X "Make a user definition permanent by storing it in your .emacs file."
X (interactive)
X (calc-wrapper
X (message "Record in %s the command: z-" calc-settings-file)
X (let* ((key (read-char))
X (def (or (assq key (calc-user-key-map))
X (assq (upcase key) (calc-user-key-map))
X (assq (downcase key) (calc-user-key-map))
X (error "No command defined for that key"))))
X (set-buffer (find-file-noselect (substitute-in-file-name
X calc-settings-file)))
X (goto-char (point-max))
X (insert "\n;;; Definition stored by Calc on " (current-time-string)
X "\n(setq calc-defs (append '(\n")
X (let* ((cmd (cdr def))
X (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
X (pt (point))
X (fill-column 70))
X (if (and fcmd
X (eq (car-safe fcmd) 'lambda)
X (get cmd 'calc-user-defn))
X (progn
X (insert (prin1-to-string
X (cons 'defun (cons cmd (cdr fcmd))))
X "\n")
X (fill-region pt (point))
X (indent-rigidly pt (point) 3)
X (delete-region pt (1+ pt))
X (let* ((func (calc-stack-command-p cmd))
X (ffunc (and func (symbolp func) (symbol-function func)))
X (pt (point)))
X (and ffunc
X (eq (car-safe ffunc) 'lambda)
X (get func 'calc-user-defn)
X (progn
X (insert (prin1-to-string
X (cons 'defun (cons func (cdr ffunc))))
X "\n")
X (fill-region pt (point))
X (indent-rigidly pt (point) 3)
X (delete-region pt (1+ pt))))))
X (and (stringp fcmd)
X (insert " (fset '" (prin1-to-string cmd)
X " " (prin1-to-string fcmd) ")\n")))
X (insert " (define-key calc-mode-map "
X (prin1-to-string (concat "z" (char-to-string key)))
X " '"
X (prin1-to-string cmd)
X "))\n"))
X (insert " (and (boundp 'calc-defs) calc-defs)))\n")
X (save-buffer)))
X)
X
X(defun calc-stack-command-p (cmd)
X (if (and cmd (symbolp cmd))
X (and (fboundp cmd)
X (calc-stack-command-p (symbol-function cmd)))
X (and (consp cmd)
X (eq (car cmd) 'lambda)
X (setq cmd (or (assq 'calc-wrapper cmd)
X (assq 'calc-slow-wrapper cmd)))
X (setq cmd (assq 'calc-enter-result cmd))
X (memq (car (nth 3 cmd)) '(cons list))
X (eq (car (nth 1 (nth 3 cmd))) 'quote)
X (nth 1 (nth 1 (nth 3 cmd)))))
X)
X
X(defun calc-permanent-variable ()
X "Save a variable's value in your .emacs file."
X (interactive)
X (calc-wrapper
X (let ((var (let ((minibuffer-completion-table obarray)
X (minibuffer-completion-predicate 'boundp)
X (minibuffer-completion-confirm t)
X (oper "r"))
X (read-from-minibuffer
X "Save variable: " "var-" calc-store-var-map nil)))
X pos)
X (if (equal var "")
X ()
X (or (and (boundp (intern var)) (intern var))
X (error "No such variable"))
X (set-buffer (find-file-noselect (substitute-in-file-name
X calc-settings-file)))
X (goto-char (point-min))
X (if (search-forward (concat "(setq " var " '") nil t)
X (progn
X (setq pos (point-marker))
X (forward-line -1)
X (if (looking-at ";;; Variable .* stored by Calc on ")
X (progn
X (delete-region (match-end 0) (progn (end-of-line) (point)))
X (insert (current-time-string))))
X (goto-char (- pos 8 (length var)))
X (forward-sexp 1)
X (backward-char 1)
X (delete-region pos (point)))
X (goto-char (point-max))
X (insert "\n;;; Variable \""
X var
X "\" stored by Calc on "
X (current-time-string)
X "\n(setq "
X var
X " ')\n")
X (backward-char 2))
X (insert (prin1-to-string (symbol-value (intern var))))
X (forward-line 1)
X (save-buffer))))
X)
X
X
X
X(defun calc-call-last-kbd-macro (arg)
X "Execute the most recent keyboard macro."
X (interactive "P")
X (and defining-kbd-macro
X (error "Can't execute anonymous macro while defining one"))
X (or last-kbd-macro
X (error "No kbd macro has been defined"))
X (calc-execute-kbd-macro last-kbd-macro arg)
X)
X
X(defun calc-execute-kbd-macro (mac arg)
X (if (< (prefix-numeric-value arg) 0)
X (execute-kbd-macro mac (- (prefix-numeric-value arg)))
X (if calc-executing-macro
X (execute-kbd-macro mac arg)
X (calc-slow-wrapper
X (let ((old-stack-whole (copy-sequence calc-stack))
X (old-stack-top calc-stack-top)
X (old-buffer-size (buffer-size))
X (old-refresh-count calc-refresh-count))
X (unwind-protect
X (let ((calc-executing-macro mac))
X (execute-kbd-macro mac arg))
X (calc-select-buffer)
X (let ((new-stack (reverse calc-stack))
X (old-stack (reverse old-stack-whole)))
X (while (and new-stack old-stack
X (equal (car new-stack) (car old-stack)))
X (setq new-stack (cdr new-stack)
X old-stack (cdr old-stack)))
X (calc-record-list (mapcar 'car new-stack) "kmac")
X (calc-record-undo (list 'set 'saved-stack-top old-stack-top))
X (and old-stack
X (calc-record-undo (list 'pop 1 (mapcar 'car old-stack))))
X (let ((calc-stack old-stack-whole)
X (calc-stack-top 0))
X (calc-cursor-stack-index (length old-stack)))
X (if (and (= old-buffer-size (buffer-size))
X (= old-refresh-count calc-refresh-count))
X (let ((buffer-read-only nil))
X (delete-region (point) (point-max))
X (while new-stack
X (calc-record-undo (list 'push 1))
X (let ((fmt (math-format-stack-value
X (car (car new-stack)))))
X (setcar (cdr (car new-stack)) (calc-count-lines fmt))
X (insert fmt "\n"))
X (setq new-stack (cdr new-stack)))
X (calc-renumber-stack))
X (calc-refresh))
X (calc-record-undo (list 'set 'saved-stack-top 0))))))))
X)
X
X
X(defun calc-kbd-if ()
X "An \"if\" statement in a Calc keyboard macro.
XUsage: cond Z[ then-part Z: cond Z| else-if-part ... Z: else-part Z]"
X (interactive)
X (calc-wrapper
X (let ((cond (calc-top-n 1)))
X (calc-pop-stack 1)
X (if (math-is-true cond)
X (if defining-kbd-macro
X (message "If true..."))
X (if defining-kbd-macro
X (message "Condition is false; skipping to Z: or Z] ..."))
X (calc-kbd-skip-to-else-if t))))
X)
X
X(defun calc-kbd-else-if ()
X (interactive)
X (calc-kbd-if)
X)
X
X(defun calc-kbd-skip-to-else-if (else-okay)
X (let ((count 0)
X ch)
X (while (>= count 0)
X (setq ch (read-char))
X (if (= ch -1)
X (error "Unterminated Z[ in keyboard macro"))
X (if (= ch ?Z)
X (progn
X (setq ch (read-char))
X (cond ((= ch ?\[)
X (setq count (1+ count)))
X ((= ch ?\])
X (setq count (1- count)))
X ((= ch ?\:)
X (and (= count 0)
X else-okay
X (setq count -1)))
X ((eq ch 7)
X (keyboard-quit))))))
X (and defining-kbd-macro
X (if (= ch ?\:)
X (message "Else...")
X (message "End-if..."))))
X)
X
X(defun calc-kbd-end-if ()
X (interactive)
X (if defining-kbd-macro
X (message "End-if..."))
X)
X
X(defun calc-kbd-else ()
X (interactive)
X (if defining-kbd-macro
X (message "Else; skipping to Z] ..."))
X (calc-kbd-skip-to-else-if nil)
X)
X
X
X(defun calc-kbd-repeat ()
X "A counted loop in a Calc keyboard macro.
XUsage: count Z< body Z>
X
XAny number of break-commands may be embedded in the body:
X cond Z/ stops the loop prematurely if cond is true."
X (interactive)
X (let (count)
X (calc-wrapper
X (setq count (math-trunc (calc-top-n 1)))
X (or (Math-integerp count)
X (error "Count must be an integer"))
X (if (Math-integer-negp count)
X (setq count 0))
X (or (integerp count)
X (setq count 1000000))
X (calc-pop-stack 1))
X (calc-kbd-loop count))
X)
X
X(defun calc-kbd-for (dir)
X "A counted loop in a Calc keyboard macro.
XUsage: initial final Z( body step Z)
X
XDuring the loop, an internal counter is incremented from INITIAL to FINAL
Xin steps of STEP. The Z( command pops INITIAL and FINAL, and pushes the
Xcurrent counter value each time through the loop. The Z) command pops
XSTEP. If INITIAL < FINAL, the loop terminates as soon as the counter
Xexceeds FINAL. If INITIAL > FINAL, the loop terminates as soon as the
Xcounter becomes less than FINAL. If INITIAL = FINAL, the loop executes
Xonce. If INITIAL and FINAL cannot be compared (say because at least one
Xis a symbolic formula), the loop continues until it is halted with Z/.
XNo matter what the relationship between INITIAL and FINAL, the body
Xalways executes at least once.
X
XA numeric prefix argument specifies a forced direction: If 1, the loop
Xterminates when the counter exceeds FINAL, and will execute zero times
Xif INITIAL > FINAL. Likewise, -1 forces a downward-counting loop.
X
XAny number of break-commands may be embedded in the body:
X cond Z/ stops the loop prematurely if cond is true."
X (interactive "P")
X (let (init final)
X (calc-wrapper
X (setq init (calc-top-n 2)
X final (calc-top-n 1))
X (or (and (math-anglep init) (math-anglep final))
X (error "Initial and final values must be real numbers"))
X (calc-pop-stack 2))
X (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir))))
X)
X
X(defun calc-kbd-loop (rpt-count &optional initial final dir)
X "A conditional loop in a Calc keyboard macro.
XUsage: Z{ body Z}
X
XAt least one break-command is normally present in the body:
X cond Z/ stops the loop if cond is true.
X
XWith a numeric prefix argument, loops at most that many times."
X (interactive "P")
X (setq rpt-count (if rpt-count (prefix-numeric-value rpt-count) 1000000))
X (let* ((count 0)
X (parts nil)
X (body "")
X (open last-command-char)
X (counter initial)
X ch)
X (or executing-macro
X (message "Reading loop body..."))
X (while (>= count 0)
X (setq ch (read-char))
X (if (= ch -1)
X (error "Unterminated Z%c in keyboard macro" open))
X (if (= ch ?Z)
X (progn
X (setq ch (read-char)
X body (concat body "Z" (char-to-string ch)))
X (cond ((memq ch '(?\< ?\( ?\{))
X (setq count (1+ count)))
X ((memq ch '(?\> ?\) ?\}))
X (setq count (1- count)))
X ((and (= ch ?/)
X (= count 0))
X (setq parts (nconc parts (list (substring body 0 -2)))
X body ""))
X ((eq ch 7)
X (keyboard-quit))))
X (setq body (concat body (char-to-string ch)))))
X (if (/= ch (cdr (assq open '( (?\< . ?\>) (?\( . ?\)) (?\{ . ?\}) ))))
X (error "Mismatched Z%c and Z%c in keyboard macro" open ch))
X (or executing-macro
X (message "Looping..."))
X (setq body (substring body 0 -2))
X (and (not executing-macro)
X (= rpt-count 1000000)
X (null parts)
X (null counter)
X (progn
X (message "Warning: Infinite loop! Not executing.")
X (setq rpt-count 0)))
X (or (not initial) dir
X (setq dir (math-compare final initial)))
X (calc-wrapper
X (while (> rpt-count 0)
X (let ((part parts))
X (if counter
X (if (cond ((eq dir 0) (math-equal final counter))
X ((eq dir 1) (math-lessp final counter))
X ((eq dir -1) (math-lessp counter final)))
X (setq rpt-count 0)
X (calc-push counter)))
X (while (and part (> rpt-count 0))
X (execute-kbd-macro (car part))
X (if (math-is-true (calc-top-n 1))
X (setq rpt-count 0)
X (setq part (cdr part)))
X (calc-pop-stack 1))
X (if (> rpt-count 0)
X (progn
X (execute-kbd-macro body)
X (if counter
X (let ((step (calc-top-n 1)))
X (calc-pop-stack 1)
X (setq counter (calcFunc-add counter step)))
X (setq rpt-count (1- rpt-count))))))))
X (or executing-macro
X (message "Looping...done")))
X)
X
X(defun calc-kbd-end-repeat ()
X (interactive)
X (error "Unbalanced Z> in keyboard macro")
X)
X
X(defun calc-kbd-end-for ()
X (interactive)
X (error "Unbalanced Z) in keyboard macro")
X)
X
X(defun calc-kbd-end-loop ()
X (interactive)
X (error "Unbalanced Z} in keyboard macro")
X)
X
X(defun calc-kbd-break ()
X "Break out of a keyboard macro, or out of a Z< Z> or Z{ Z} loop in a macro.
XUsage: cond Z/ breaks only if cond is true. Use \"1 Z/\" to break always."
X (interactive)
X (calc-wrapper
X (let ((cond (calc-top-n 1)))
X (calc-pop-stack 1)
X (if (math-is-true cond)
X (error "Keyboard macro aborted."))))
X)
X
X
X(defun calc-kbd-push ()
X "Save modes and quick variables around a section of a keyboard macro.
X
XSaved: var-0 thru var-9, precision, word size, angular mode,
Xsimplification mode, vector mapping direction, Alg, Sym, Frac, Polar modes.
X
XValues are restored on exit, even if the macro halts with an error."
X (interactive)
X (calc-wrapper
X (let* ((var-0 (and (boundp 'var-0) var-0))
X (var-1 (and (boundp 'var-1) var-1))
X (var-2 (and (boundp 'var-2) var-2))
X (var-3 (and (boundp 'var-3) var-3))
X (var-4 (and (boundp 'var-4) var-4))
X (var-5 (and (boundp 'var-5) var-5))
X (var-6 (and (boundp 'var-6) var-6))
X (var-7 (and (boundp 'var-7) var-7))
X (var-8 (and (boundp 'var-8) var-8))
X (var-9 (and (boundp 'var-9) var-9))
X (calc-internal-prec calc-internal-prec)
X (calc-word-size calc-word-size)
X (calc-angle-mode calc-angle-mode)
X (calc-simplify-mode calc-simplify-mode)
X (calc-mapping-dir calc-mapping-dir)
X (calc-algebraic-mode calc-algebraic-mode)
X (calc-symbolic-mode calc-symbolic-mode)
X (calc-prefer-frac calc-prefer-frac)
X (calc-complex-mode calc-complex-mode)
X (count 0)
X (body "")
X ch)
X (if (or executing-macro defining-kbd-macro)
X (progn
X (if defining-kbd-macro
X (message "Reading body..."))
X (while (>= count 0)
X (setq ch (read-char))
X (if (= ch -1)
X (error "Unterminated Z` in keyboard macro"))
X (if (= ch ?Z)
X (progn
X (setq ch (read-char)
X body (concat body "Z" (char-to-string ch)))
X (cond ((eq ch ?\`)
X (setq count (1+ count)))
X ((eq ch ?\')
X (setq count (1- count)))
X ((eq ch 7)
X (keyboard-quit))))
X (setq body (concat body (char-to-string ch)))))
X (if defining-kbd-macro
X (message "Reading body...done"))
X (let ((calc-kbd-push-level 0))
X (execute-kbd-macro (substring body 0 -2))))
X (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
X (message "Saving modes; type Z' to restore")
X (recursive-edit)))))
X)
X(setq calc-kbd-push-level 0)
X
X(defun calc-kbd-pop ()
X (interactive)
X (if (> calc-kbd-push-level 0)
X (progn
X (message "Mode settings restored")
X (exit-recursive-edit))
X (error "Unbalanced Z' in keyboard macro"))
X)
X
X
X(defun calc-kbd-report (msg)
X "Display the number on the top of the stack in the echo area.
XThis will normally be used to report progress in a keyboard macro."
X (interactive "sMessage: ")
X (calc-wrapper
X (let ((executing-macro nil)
X (defining-kbd-macro nil))
X (math-working msg (calc-top-n 1))))
X)
X
X(defun calc-kbd-query (msg)
X "Pause during keyboard macro execution to do an algebraic entry."
X (interactive "sPrompt: ")
X (calc-wrapper
X (let ((executing-macro nil)
X (defining-kbd-macro nil))
X (calc-alg-entry nil (and (not (equal msg "")) msg))))
X)
X
X
X
X
X
X
X;;;; Caches.
X
X(defmacro math-defcache (name init form)
X (let ((cache-prec (intern (concat (symbol-name name) "-cache-prec")))
X (cache-val (intern (concat (symbol-name name) "-cache")))
X (last-prec (intern (concat (symbol-name name) "-last-prec")))
X (last-val (intern (concat (symbol-name name) "-last"))))
X (list 'progn
X (list 'setq cache-prec (if init (math-numdigs (nth 1 init)) -100))
X (list 'setq cache-val (list 'quote init))
X (list 'setq last-prec -100)
X (list 'setq last-val nil)
X (list 'setq 'math-cache-list
X (list 'cons
X (list 'quote cache-prec)
X (list 'cons
X (list 'quote last-prec)
X 'math-cache-list)))
X (list 'defun
X name ()
X (list 'or
X (list '= last-prec 'calc-internal-prec)
X (list 'setq
X last-val
X (list 'math-normalize
X (list 'progn
X (list 'or
X (list '>= cache-prec
X 'calc-internal-prec)
X (list 'setq
X cache-val
X (list 'let
X '((calc-internal-prec
X (+ calc-internal-prec
X 4)))
X form)
X cache-prec
X '(+ calc-internal-prec 2)))
X cache-val))
X last-prec 'calc-internal-prec))
X last-val)))
X)
X(put 'math-defcache 'lisp-indent-hook 2)
X
X;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public]
X(math-defcache math-pi (float (bigpos 463 238 793 589 653 592 141 3) -21)
X (math-add-float (math-mul-float '(float 16 0)
X (math-arctan-raw '(float 2 -1)))
X (math-mul-float '(float -4 0)
X (math-arctan-raw
X (math-float '(frac 1 239))))))
X
X(math-defcache math-two-pi nil
X (math-mul-float (math-pi) '(float 2 0)))
X
X(math-defcache math-pi-over-2 nil
X (math-mul-float (math-pi) '(float 5 -1)))
X
X(math-defcache math-pi-over-4 nil
X (math-mul-float (math-pi) '(float 25 -2)))
X
X(math-defcache math-pi-over-180 nil
X (math-div-float (math-pi) '(float 18 1)))
X
X(math-defcache math-sqrt-e (float (bigpos 849 146 128 700 270 721 648 1) -21)
X (math-add-float '(float 1 0) (math-exp-minus-1-raw '(float 5 -1))))
X
X(math-defcache math-e nil
X (math-sqr (math-sqrt-e)))
X
X
X(defun math-half-circle (symb)
X (if (eq calc-angle-mode 'rad)
X (if symb
X '(var pi var-pi)
X (math-pi))
X 180)
X)
X
X(defun math-full-circle (symb)
X (math-mul 2 (math-half-circle symb))
X)
X
X(defun math-quarter-circle (symb)
X (math-div (math-half-circle symb) 2)
X)
X
X
X
X
X;;;; Miscellaneous math routines.
X
X;;; True if A is an odd integer. [P R R] [Public]
X(defun math-oddp (a)
X (if (consp a)
X (and (memq (car a) '(bigpos bigneg))
X (= (% (nth 1 a) 2) 1))
X (/= (% a 2) 0))
X)
X
X;;; True if A is numerically an integer. [P x] [Public]
X(defun math-num-integerp (a)
X (or (Math-integerp a)
X (Math-messy-integerp a))
X)
X(defmacro Math-num-integerp (a)
X (` (or (not (consp (, a)))
X (memq (car (, a)) '(bigpos bigneg))
X (and (eq (car (, a)) 'float)
X (>= (nth 2 (, a)) 0))))
X)
X
X;;; True if A is (numerically) a non-negative integer. [P N] [Public]
X(defun math-num-natnump (a)
X (or (natnump a)
X (eq (car-safe a) 'bigpos)
X (and (eq (car-safe a) 'float)
X (Math-natnump (nth 1 a))
X (>= (nth 2 a) 0)))
X)
X
X;;; True if A is an integer or will evaluate to an integer. [P x] [Public]
X(defun math-provably-integerp (a)
X (or (Math-integerp a)
X (memq (car-safe a) '(calcFunc-trunc
X calcFunc-round
X calcFunc-floor
X calcFunc-ceil)))
X)
X
X;;; True if A is a real or will evaluate to a real. [P x] [Public]
X(defun math-provably-realp (a)
X (or (Math-realp a)
X (math-provably-integer a)
X (memq (car-safe a) '(abs arg)))
X)
X
X;;; True if A is a non-real, complex number. [P x] [Public]
X(defun math-complexp (a)
X (memq (car-safe a) '(cplx polar))
X)
X
X;;; True if A is a non-real, rectangular complex number. [P x] [Public]
X(defun math-rect-complexp (a)
X (eq (car-safe a) 'cplx)
X)
X
X;;; True if A is a non-real, polar complex number. [P x] [Public]
X(defun math-polar-complexp (a)
X (eq (car-safe a) 'polar)
X)
X
X;;; True if A is a matrix. [P x] [Public]
X(defun math-matrixp (a)
X (and (Math-vectorp a)
X (Math-vectorp (nth 1 a))
X (cdr (nth 1 a))
X (math-matrixp-step (cdr (cdr a)) (length (nth 1 a))))
X)
X
X(defun math-matrixp-step (a len) ; [P L]
X (or (null a)
X (and (Math-vectorp (car a))
X (= (length (car a)) len)
X (math-matrixp-step (cdr a) len)))
X)
X
X;;; True if A is a square matrix. [P V] [Public]
X(defun math-square-matrixp (a)
X (let ((dims (math-mat-dimens a)))
X (and (cdr dims)
X (= (car dims) (nth 1 dims))))
X)
X
X;;; True if A is any real scalar data object. [P x]
X(defun math-real-objectp (a) ; [Public]
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac float hms sdev intv mod)))
X)
X
X;;; True if A is an object not composed of sub-formulas . [P x] [Public]
X(defun math-primp (a)
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac float cplx polar
X hms mod var)))
X)
X(defmacro Math-primp (a)
X (` (or (not (consp (, a)))
X (memq (car (, a)) '(bigpos bigneg frac float cplx polar
X hms mod var))))
X)
X
X;;; True if A is a constant or vector of constants. [P x] [Public]
X(defun math-constp (a)
X (or (math-scalarp a)
X (and (memq (car-safe a) '(sdev intv vec))
X (progn
X (while (and (setq a (cdr a))
X (math-constp (car a))))
X (null a))))
X)
X
X(defmacro Math-lessp (a b)
X (` (= (math-compare (, a) (, b)) -1))
X)
X
X
X;;; Verify that A is an integer and return A in integer form. [I N; - x]
X(defun math-check-integer (a) ; [Public]
X (cond ((integerp a) a) ; for speed
X ((math-integerp a) a)
X ((math-messy-integerp a)
X (math-trunc a))
X (t (math-reject-arg a 'integerp)))
X)
X
X;;; Verify that A is a small integer and return A in integer form. [S N; - x]
X(defun math-check-fixnum (a) ; [Public]
X (cond ((integerp a) a) ; for speed
X ((Math-num-integerp a)
X (let ((a (math-trunc a)))
X (if (integerp a)
X a
X (if (or (Math-lessp (lsh -1 -1) a)
X (Math-lessp a (- (lsh -1 -1))))
X (math-reject-arg a 'fixnump)
X (math-fixnum a)))))
X (t (math-reject-arg a 'fixnump)))
X)
X
X;;; Verify that A is an integer >= 0 and return A in integer form. [I N; - x]
X(defun math-check-natnum (a) ; [Public]
X (cond ((natnump a) a)
X ((and (not (math-negp a))
X (Math-num-integerp a))
X (math-trunc a))
X (t (math-reject-arg a 'natnump)))
X)
X
X;;; Verify that A is in floating-point form, or force it to be a float. [F N]
X(defun math-check-float (a) ; [Public]
X (cond ((eq (car-safe a) 'float) a)
X ((Math-vectorp a) (math-map-vec 'math-check-float a))
X ((Math-objectp a) (math-float a))
X (t a))
X)
X
X;;; Verify that A is a constant.
X(defun math-check-const (a)
X (if (math-constp a)
X a
X (math-reject-arg a 'constp))
X)
X
X
X;;; Coerce integer A to be a small integer. [S I]
X(defun math-fixnum (a)
X (if (consp a)
X (if (cdr a)
X (if (eq (car a) 'bigneg)
X (- (math-fixnum-big (cdr a)))
X (math-fixnum-big (cdr a)))
X 0)
X a)
X)
X
X(defun math-fixnum-big (a)
X (if (cdr a)
X (+ (car a) (* (math-fixnum-big (cdr a)) 1000))
X (car a))
X)
X
X
X(defun math-bignum-test (a) ; [B N; B s; b b]
X (if (consp a)
X a
X (math-bignum a))
X)
X(defmacro Math-bignum-test (a) ; [B N; B s; b b]
X (` (if (consp (, a))
X (, a)
X (math-bignum (, a))))
X)
X
X
X;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public]
X(defun math-sign (a)
X (cond ((math-posp a) 1)
X ((math-negp a) -1)
X ((math-zerop a) 0)
X (t (calc-record-why 'realp a)
X (list 'calcFunc-sign a)))
X)
X(fset 'calcFunc-sign (symbol-function 'math-sign))
X
X;;; Return 0 if A is numerically equal to B, <0 if less, >0 if more.
X;;; Arguments must be normalized! [S N N]
X(defun math-compare (a b)
X (cond ((equal a b) 0)
X ((and (integerp a) (Math-integerp b))
X (if (consp b)
X (if (eq (car b) 'bigpos) -1 1)
X (if (< a b) -1 1)))
X ((and (eq (car-safe a) 'bigpos) (Math-integerp b))
X (if (eq (car-safe b) 'bigpos)
X (math-compare-bignum (cdr a) (cdr b))
X 1))
X ((and (eq (car-safe a) 'bigneg) (Math-integerp b))
X (if (eq (car-safe b) 'bigneg)
X (math-compare-bignum (cdr b) (cdr a))
X -1))
X ((eq (car-safe a) 'frac)
X (if (eq (car-safe b) 'frac)
X (math-compare (math-mul (nth 1 a) (nth 2 b))
X (math-mul (nth 1 b) (nth 2 a)))
X (math-compare (nth 1 a) (math-mul b (nth 2 a)))))
X ((eq (car-safe b) 'frac)
X (math-compare (math-mul a (nth 2 b)) (nth 1 b)))
X ((and (eq (car-safe a) 'float) (eq (car-safe b) 'float))
X (if (math-lessp-float a b) -1 1))
X ((and (Math-anglep a) (Math-anglep b))
X (math-sign (math-add a (math-neg b))))
X ((eq (car-safe a) 'var)
X 2)
X (t
X (if (and (consp a) (consp b)
X (eq (car a) (car b))
X (math-compare-lists (cdr a) (cdr b)))
X 0
X 2)))
X)
X
X;;; Compare two bignum digit lists, return -1 for A<B, 0 for A=B, 1 for A>B.
X(defun math-compare-bignum (a b) ; [S l l]
X (let ((res 0))
X (while (and a b)
X (if (< (car a) (car b))
X (setq res -1)
X (if (> (car a) (car b))
X (setq res 1)))
X (setq a (cdr a)
X b (cdr b)))
X (if a
X (progn
X (while (eq (car a) 0) (setq a (cdr a)))
X (if a 1 res))
X (while (eq (car b) 0) (setq b (cdr b)))
X (if b -1 res)))
X)
X
X(defun math-compare-lists (a b)
X (cond ((null a) (null b))
X ((null b) nil)
X (t (and (math-equal (car a) (car b))
X (math-compare-lists (cdr a) (cdr b)))))
X)
X
X(defun math-lessp-float (a b) ; [P F F]
X (let ((ediff (- (nth 2 a) (nth 2 b))))
X (if (>= ediff 0)
X (if (>= ediff (+ calc-internal-prec calc-internal-prec))
X (Math-integer-negp (nth 1 a))
X (Math-lessp (math-scale-int (nth 1 a) ediff)
X (nth 1 b)))
X (if (>= (setq ediff (- ediff))
X (+ calc-internal-prec calc-internal-prec))
X (Math-integer-posp (nth 1 b))
X (Math-lessp (nth 1 a)
X (math-scale-int (nth 1 b) ediff)))))
X)
X
X;;; True if A is numerically equal to B. [P N N] [Public]
X(defun math-equal (a b)
X (= (math-compare a b) 0)
X)
X
X;;; True if A is numerically less than B. [P R R] [Public]
X(defun math-lessp (a b)
X (= (math-compare a b) -1)
X)
X
X;;; True if A is numerically equal to the integer B. [P N S] [Public]
X;;; B must not be a multiple of 10.
X(defun math-equal-int (a b)
X (or (eq a b)
X (and (eq (car-safe a) 'float)
X (eq (nth 1 a) b)
X (= (nth 2 a) 0)))
X)
X(defmacro Math-equal-int (a b)
X (` (or (eq (, a) (, b))
X (and (consp (, a))
X (eq (car (, a)) 'float)
X (eq (nth 1 (, a)) (, b))
X (= (nth 2 (, a)) 0))))
X)
X
X
X;;; Convert a variable name (as a formula) into a like-looking function name.
X(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)
X
X;;; Convert a function name into a like-looking variable name formula.
X(defun math-calcFunc-to-var (f)
X (if (symbolp f)
X (let ((base (if (string-match "\\`calcFunc-\\(.+\\)\\'" (symbol-name f))
X (math-match-substring (symbol-name f) 1)
X (symbol-name f))))
X (list 'var
X (intern base)
X (intern (concat "var-" base))))
X f)
X)
X
X;;; Expand a function call using "lambda" notation.
X(defun math-build-call (f args)
X (if (eq (car-safe f) 'calcFunc-lambda)
X (if (= (length args) (- (length f) 2))
X (let ((argnames (cdr f))
X (argvals args)
X (res (nth (1- (length f)) f)))
X (while argvals
X (setq res (math-expr-subst res (car argnames) (car argvals))
X argnames (cdr argnames)
X argvals (cdr argvals)))
X res)
X (cons 'calcFunc-call (cons (math-calcFunc-to-var f) args)))
X (cons f args))
X)
X
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)
X
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
X;;;; Vectors.
X
X;;; Return the dimensions of a matrix as a list. [l x] [Public]
X(defun math-mat-dimens (m)
X (if (math-vectorp m)
X (if (math-matrixp m)
X (cons (1- (length m))
X (math-mat-dimens (nth 1 m)))
X (list (1- (length m))))
X nil)
X)
X
X
X;;; Apply a function elementwise to vector A. [V X V; N X N] [Public]
X(defun math-map-vec (f a)
X (if (math-vectorp a)
X (cons 'vec (mapcar f (cdr a)))
X (funcall f a))
X)
X
X(defun math-dimension-error ()
X (calc-record-why "Dimension error")
X (signal 'wrong-type-argument nil)
X)
X
X
X;;; Build a vector out of a list of objects. [Public]
X(defun math-build-vector (&rest objs)
X (cons 'vec objs)
X)
X(fset 'calcFunc-vec (symbol-function 'math-build-vector))
X
X
X;;; Build a constant vector or matrix. [Public]
X(defun math-make-vec (obj &rest dims)
X (math-make-vec-dimen obj dims)
X)
X(fset 'calcFunc-cvec (symbol-function 'math-make-vec))
X
X(defun math-make-vec-dimen (obj dims)
X (if dims
X (if (natnump (car dims))
X (if (or (cdr dims)
X (not (math-numberp obj)))
X (cons 'vec (copy-sequence
X (make-list (car dims)
X (math-make-vec-dimen obj (cdr dims)))))
X (cons 'vec (make-list (car dims) obj)))
X (math-reject-arg (car dims) 'natnump))
X obj)
X)
X
X
X;;; Coerce row vector A to be a matrix. [V V]
X(defun math-row-matrix (a)
X (if (and (Math-vectorp a)
X (not (math-matrixp a)))
X (list 'vec a)
X a)
X)
X
X;;; Coerce column vector A to be a matrix. [V V]
X(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
X(defun calc-binary-op-fancy (name func arg ident unary)
X (let ((n (prefix-numeric-value arg)))
X (cond ((> n 1)
X (calc-enter-result n
X name
X (list 'calcFunc-reduce
X (math-calcFunc-to-var func)
X (cons 'vec (calc-top-list-n n)))))
X ((= n 1)
X (if unary
X (calc-enter-result 1 name (list unary (calc-top-n 1)))))
X ((= n 0)
X (if ident
X (calc-enter-result 0 name ident)
X (error "Argument must be nonzero")))
X (t
X (let ((rhs (calc-top-n 1)))
X (calc-enter-result (- 1 n)
X name
X (mapcar (function
X (lambda (x)
X (list func x rhs)))
X (calc-top-list-n (- n) 2)))))))
X)
X
X(defun calc-unary-op-fancy (name func arg)
X (let ((n (prefix-numeric-value arg)))
X (cond ((> n 0)
X (calc-enter-result n
X name
X (mapcar (function
X (lambda (x)
X (list func x)))
X (calc-top-list-n n))))
X ((= n 0))
X (t
X (error "Argument must be positive"))))
X)
X
X
X;;; Apply a function elementwise to vectors A and B. [O X O O] [Public]
X(defun math-map-vec-2 (f a b)
X (if (math-vectorp a)
X (if (math-vectorp b)
X (cons 'vec (math-map-vec-2-step f (cdr a) (cdr b)))
X (cons 'vec (math-map-vec-2-left f (cdr a) b)))
X (if (math-vectorp b)
X (cons 'vec (math-map-vec-2-right f a (cdr b)))
X (funcall f a b)))
X)
X
X(defun math-map-vec-2-step (f a b) ; [L X L L]
X (cond
X ((null a) (if b (math-dimension-error)))
X ((null b) (math-dimension-error))
X (t (cons (funcall f (car a) (car b))
X (math-map-vec-2-step f (cdr a) (cdr b)))))
X)
X
X(defun math-map-vec-2-left (f a b) ; [L X L N]
X (and a
X (cons (funcall f (car a) b)
X (math-map-vec-2-left f (cdr a) b)))
X)
X
X(defun math-map-vec-2-right (f a b) ; [L X N L]
X (and b
X (cons (funcall f a (car b))
X (math-map-vec-2-right f a (cdr b))))
X)
X
X
X;;; Map a function over a vector symbolically. [Public]
X(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 (vec nil)
X (i -1)
X len cols obj expr)
X (if (eq mode 'rows)
X ()
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 (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 (eq (car-safe obj) 'vec)
X (or (eq mode 'elems)
X (math-matrixp obj)))
X (progn
X (aset vflags i t)
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 "At least one argument must be a vector")))
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 vec (cons (math-build-call func expr) vec)))
X (if (eq mode 'cols)
X (math-transpose (math-normalize (cons 'vec (nreverse vec))))
X (math-normalize (cons 'vec (nreverse vec)))))
X)
X
X(defun calcFunc-map (func &rest args)
X (math-symb-map func 'elems args)
X)
X
X(defun calcFunc-mapr (func &rest args)
X (math-symb-map func 'rows args)
X)
X
X(defun calcFunc-mapc (func &rest args)
X (math-symb-map func 'cols args)
X)
X
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)
X
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)
X
X
X;;; "Reduce" a function over a vector (left-associatively). [O X V] [Public]
X(defun math-reduce-vec (f a)
X (if (math-vectorp a)
X (if (cdr a)
X (math-reduce-vec-step f (car (cdr a)) (cdr (cdr a)))
X 0)
X a)
X)
X
X(defun math-reduce-vec-step (f tot a) ; [O X O L]
X (if a
X (math-reduce-vec-step f
X (funcall f tot (car a))
X (cdr a))
X tot)
X)
X
X;;; Reduce a function over the columns of matrix A. [V X V] [Public]
X(defun math-reduce-cols (f a)
X (if (math-matrixp a)
X (cons 'vec (math-reduce-cols-col-step f (cdr a) 1 (length (nth 1 a))))
X a)
X)
X
X(defun math-reduce-cols-col-step (f a col cols)
X (and (< col cols)
X (cons (math-reduce-cols-row-step f (nth col (car a)) col (cdr a))
X (math-reduce-cols-col-step f a (1+ col) cols)))
X)
X
X(defun math-reduce-cols-row-step (f tot col a)
X (if a
X (math-reduce-cols-row-step f
X (funcall f tot (nth col (car a)))
X col
X (cdr a))
X tot)
X)
X
X
X;;; Reduce a function over a vector symbolically. [Public]
X(defun calcFunc-reduce (func vec)
X (if (math-matrixp vec)
X (let (expr row)
X (setq func (math-var-to-calcFunc func))
X (or (math-vectorp vec)
X (math-reject-arg vec 'vectorp))
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)
X
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 (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 (math-normalize expr))
X)
X
X(defun calcFunc-reducec (func vec)
X (if (math-matrixp vec)
X (calcFunc-reducer func (math-transpose vec))
X (calcFunc-reducer func vec))
X)
X
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)
X
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)
X
X
X;;; Multiply matrix vector element lists A and B. [L L L]
X(defun math-mul-mats (a b)
X (and a
X (cons (cons 'vec (math-mul-mat-row (car a) b))
X (math-mul-mats (cdr a) b)))
X)
X
X(defun math-mul-mat-row (a b) ; [L L L]
X (if (math-no-empty-rows b)
X (cons
X (math-reduce-vec 'math-add
X (math-map-vec-2 'math-mul
X a
X (cons 'vec (mapcar 'car b))))
X (math-mul-mat-row a (mapcar 'cdr b)))
X (if (math-list-all-nil b)
X nil
X (math-dimension-error)))
X)
X
X(defun math-no-empty-rows (a) ; [P L]
X (or (null a)
X (and (consp (car a))
X (math-no-empty-rows (cdr a))))
X)
X
X(defun math-list-all-nil (a) ; [P L]
X (or (null a)
X (and (null (car a))
X (math-list-all-nil (cdr a))))
X)
X
X
X;;; Return the number of elements in vector V. [Public]
X(defun math-vec-length (v)
X (if (math-vectorp v)
X (1- (length v))
X 0)
X)
X(fset 'calcFunc-vlen (symbol-function 'math-vec-length))
X
X;;; Get the Nth row of a matrix.
X(defun math-mat-row (mat n)
X (elt mat n)
X)
X
X(defun calcFunc-mrow (mat n) ; [Public]
X (and (integerp (setq n (math-check-integer n)))
X (> n 0)
X (math-vectorp mat)
X (nth n mat))
X)
X
X;;; Get the Nth column of a matrix.
X(defun math-mat-col (mat n)
X (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat)))
X)
X
X(defun calcFunc-mcol (mat n) ; [Public]
X (and (integerp (setq n (math-check-integer n)))
X (> n 0)
X (math-vectorp mat)
X (if (math-matrixp mat)
X (and (< n (length (nth 1 mat)))
X (math-mat-col mat n))
X (nth n mat)))
X)
X
X;;; Remove the Nth row from a matrix.
X(defun math-mat-less-row (mat n)
X (if (<= n 0)
X (cdr mat)
X (cons (car mat)
X (math-mat-less-row (cdr mat) (1- n))))
X)
X
X(defun calcFunc-mrrow (mat n) ; [Public]
X (and (integerp (setq n (math-check-integer n)))
X (> n 0)
X (< n (length mat))
X (math-mat-less-row mat n))
X)
X
X;;; Remove the Nth column from a matrix.
X(defun math-mat-less-col (mat n)
X (cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n)))
X (cdr mat)))
X)
X
X(defun calcFunc-mrcol (mat n) ; [Public]
X (and (integerp (setq n (math-check-integer n)))
X (> n 0)
X (if (math-matrixp mat)
X (and (< n (length (nth 1 mat)))
X (math-mat-less-col mat n))
X (math-mat-less-row mat n)))
X)
X
X(defun math-get-diag (mat) ; [Public]
X (if (math-square-matrixp mat)
X (cons 'vec (math-get-diag-step (cdr mat) 1))
X (calc-record-why 'math-square-matrixp mat)
X (list 'calcFunc-getdiag mat))
X)
X(fset 'calcFunc-getdiag (symbol-function 'math-get-diag))
X
X(defun math-get-diag-step (row n)
X (and row
X (cons (nth n (car row))
X (math-get-diag-step (cdr row) (1+ n))))
X)
X
X(defun math-transpose (mat) ; [Public]
X (if (math-vectorp mat)
X (if (math-matrixp mat)
X (cons 'vec
X (math-trn-step mat 1 (length (nth 1 mat))))
X (math-col-matrix mat))
X (and (math-numberp mat)
X mat))
X)
X(fset 'calcFunc-trn (symbol-function 'math-transpose))
X
X(defun calcFunc-ctrn (mat)
X (let ((trn (math-transpose mat)))
X (and trn
X (math-conj trn)))
X)
X
X(defun math-trn-step (mat col cols)
X (and (< col cols)
X (cons (math-mat-col mat col)
X (math-trn-step mat (1+ col) cols)))
X)
X
X(defun math-arrange-vector (vec cols) ; [Public]
X (if (and (math-vectorp vec) (integerp cols))
X (let* ((flat (math-flatten-vector vec))
X (mat (list 'vec))
X next)
X (if (<= cols 0)
X (nconc mat flat)
X (while (>= (length flat) cols)
X (setq next (nthcdr cols flat))
X (setcdr (nthcdr (1- cols) flat) nil)
X (setq mat (nconc mat (list (cons 'vec flat)))
X flat next))
X (if flat
X (setq mat (nconc mat (list (cons 'vec flat)))))
X mat)))
X)
X(fset 'calcFunc-arrange (symbol-function 'math-arrange-vector))
X
X(defun math-flatten-vector (vec) ; [L V]
X (if (math-vectorp vec)
X (apply 'append (mapcar 'math-flatten-vector (cdr vec)))
X (list vec))
X)
X
X
X;;; Copy a matrix. [Public]
X(defun math-copy-matrix (m)
X (if (math-vectorp (nth 1 m))
X (cons 'vec (mapcar 'copy-sequence (cdr m)))
X (copy-sequence m))
X)
X
X;;; Convert a scalar or vector into an NxN diagonal matrix. [Public]
X(defun math-diag-matrix (a &optional n)
X (and n (not (integerp n))
X (setq n (math-check-fixnum n)))
X (if (math-vectorp a)
X (if (and n (/= (length a) (1+ n)))
X (list 'calcFunc-diag a n)
X (if (math-matrixp a)
X (if (and n (/= (length (elt a 1)) (1+ n)))
X (list 'calcFunc-diag a n)
X a)
X (cons 'vec (math-diag-step (cdr a) 0 (1- (length a))))))
X (if n
X (cons 'vec (math-diag-step (make-list n a) 0 n))
X (list 'calcFunc-diag a)))
X)
X(fset 'calcFunc-diag (symbol-function 'math-diag-matrix))
X
X(defun math-diag-step (a n m)
X (if (< n m)
X (cons (cons 'vec
X (nconc (make-list n 0)
X (cons (car a)
X (make-list (1- (- m n)) 0))))
X (math-diag-step (cdr a) (1+ n) m))
X nil)
X)
SHAR_EOF
echo "End of part 6"
echo "File calc-ext.el is continued in part 7"
echo "7" > s2_seq_.tmp
exit 0