daveg@csvax.caltech.edu (David Gillespie) (06/06/90)
Posting-number: Volume 13, Issue 28
Submitted-by: daveg@csvax.caltech.edu (David Gillespie)
Archive-name: gmcalc/part02
---- Cut Here and unpack ----
#!/bin/sh
# this is part 2 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc.el continued
#
CurArch=2
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.el"
sed 's/^X//' << 'SHAR_EOF' >> calc.el
X)
X
X(defun calc-record (val &optional prefix)
X (or calc-executing-macro
X (let* ((mainbuf (current-buffer))
X (buf (get-buffer-create "*Calc Trail*"))
X (calc-display-raw (eq calc-display-raw t))
X (fval (if val
X (if (stringp val)
X val
X (math-showing-full-precision
X (math-format-flat-expr val 0)))
X "")))
X (save-excursion
X (set-buffer buf)
X (if (not (eq major-mode 'calc-trail-mode))
X (calc-trail-mode mainbuf))
X (let ((aligned (calc-check-trail-aligned))
X (buffer-read-only nil))
X (goto-char (point-max))
X (cond ((null prefix) (insert " "))
X ((> (length prefix) 5) (insert (substring prefix 0 5) " "))
X (t (insert (format "%4s " prefix))))
X (insert fval "\n")
X (let ((win (get-buffer-window buf)))
X (if (and aligned win (not (memq 'hold-trail calc-command-flags)))
X (progn
X (calc-trail-here))))
X (goto-char (1- (point-max)))))))
X val
X)
X
X(defun calc-record-list (vals &optional prefix)
X (while vals
X (or (eq (car vals) 'top-of-stack)
X (progn
X (calc-record (car vals) prefix)
X (setq prefix "...")))
X (setq vals (cdr vals)))
X)
X
X(defun calc-trail-display (flag &optional no-refresh)
X "Turn the Trail display on or off.
XWith prefix argument 1, turn it on; with argument 0, turn it off."
X (interactive "P")
X (let* ((trail (get-buffer-create "*Calc Trail*"))
X (win (get-buffer-window trail)))
X (if (setq calc-display-trail
X (not (if flag (memq flag '(nil 0)) win)))
X (if (null win)
X (progn
X (if (and (boundp 'calc-trail-window-hook) calc-trail-window-hook)
X (run-hooks 'calc-trail-window-hook)
X (let ((w (split-window nil (/ (* (window-width) 2) 3) t)))
X (set-window-buffer w trail)))
X (calc-wrapper
X (or no-refresh
X (calc-refresh)))))
X (if win
X (progn
X (delete-window win)
X (calc-wrapper
X (or no-refresh
X (calc-refresh)))))
X (if (and (boundp 'overlay-arrow-position)
X (eq overlay-arrow-position calc-trail-pointer))
X (setq overlay-arrow-position nil)))
X trail)
X)
X
X(defun calc-trail-here ()
X "Move the trail pointer to the current cursor line."
X (interactive)
X (if (eq major-mode 'calc-trail-mode)
X (progn
X (beginning-of-line)
X (if (bobp)
X (forward-line 1)
X (if (eobp)
X (forward-line -1)))
X (if (or (bobp) (eobp))
X (setq overlay-arrow-position nil) ; trail is empty
X (set-marker calc-trail-pointer (point) (current-buffer))
X (setq overlay-arrow-string (concat (buffer-substring (point)
X (+ (point) 4))
X ">")
X overlay-arrow-position calc-trail-pointer)
X (forward-char 4)
X (let ((win (get-buffer-window (current-buffer))))
X (if win
X (save-excursion
X (forward-line (/ (window-height) 2))
X (forward-line (- 1 (window-height)))
X (set-window-start win (point))
X (set-window-point win (+ calc-trail-pointer 4)))))))
X (error "Not in Calc Trail buffer"))
X)
X
X
X
X
X;;;; The Undo list.
X
X(defun calc-record-undo (rec)
X (or calc-executing-macro
X (if (memq 'undo calc-command-flags)
X (setq calc-undo-list (cons (cons rec (car calc-undo-list))
X (cdr calc-undo-list)))
X (setq calc-undo-list (cons (list rec) calc-undo-list)
X calc-redo-list nil)
X (calc-set-command-flag 'undo)))
X)
X
X
X
X;;; Arithmetic commands.
X
X(defun calc-binary-op (name func arg &optional ident unary)
X (if (null arg)
X (calc-enter-result 2 name (cons func (calc-top-list-n 2)))
X (calc-extensions)
X (calc-binary-op-fancy name func arg ident unary))
X)
X
X(defun calc-unary-op (name func arg)
X (if (null arg)
X (calc-enter-result 1 name (list func (calc-top-n 1)))
X (calc-extensions)
X (calc-unary-op-fancy name func arg))
X)
X
X
X(defun calc-plus (arg)
X "Add the top two elements of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "+" 'calcFunc-add arg 0))
X)
X
X(defun calc-minus (arg)
X "Subtract the top two elements of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "-" 'calcFunc-sub arg 0 'calcFunc-neg))
X)
X
X(defun calc-times (arg)
X "Multiply the top two elements of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "*" 'calcFunc-mul arg 1))
X)
X
X(defun calc-divide (arg)
X "Divide the top two elements of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "/" 'calcFunc-div arg 0 'calcFunc-inv))
X)
X
X(defun calc-power (arg)
X "Compute y^x for the top two elements of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "^" 'calcFunc-pow arg))
X)
X
X(defun calc-mod (arg)
X "Compute the modulo of the top two elements of the Calculator stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-binary-op "%" 'calcFunc-mod arg))
X)
X
X(defun calc-inv (arg)
X "Invert the number or square matrix on the top of the stack."
X (interactive "P")
X (calc-slow-wrapper
X (calc-unary-op "inv" 'calcFunc-inv arg))
X)
X
X(defun calc-change-sign (arg)
X "Change the sign of the top element of the Calculator stack."
X (interactive "P")
X (calc-wrapper
X (calc-unary-op "chs" 'calcFunc-neg arg))
X)
X
X
X
X;;; Stack management commands.
X
X(defun calc-enter (n)
X "Duplicate the top N elements of the Calculator stack.
XWith a negative argument -N, duplicate the Nth element of the stack."
X (interactive "p")
X (calc-wrapper
X (cond ((< n 0)
X (calc-push (calc-top (- n))))
X ((= n 0)
X (calc-push-list (calc-top-list (calc-stack-size))))
X (t
X (calc-push-list (calc-top-list n)))))
X)
X
X(defun calc-over (n)
X "Duplicate the Nth element of the Calculator stack.
XWith a negative argument -N, duplicate the top N elements of the stack."
X (interactive "P")
X (if n
X (calc-enter (- (prefix-numeric-value n)))
X (calc-enter -2))
X)
X
X(defun calc-pop (n)
X "Pop (and discard) the top N elements of the stack.
XWith a negative argument -N, remove the Nth element from the stack."
X (interactive "P")
X (calc-wrapper
X (let* ((nn (prefix-numeric-value n))
X (top (and (null n) (calc-top 1))))
X (cond ((and (null n)
X (eq (car-safe top) 'incomplete)
X (> (length top) (if (eq (nth 1 top) 'intv) 3 2)))
X (calc-pop-push 1 (let ((tt (copy-sequence top)))
X (setcdr (nthcdr (- (length tt) 2) tt) nil)
X tt)))
X ((< nn 0)
X (calc-pop-stack 1 (- nn)))
X ((= nn 0)
X (calc-pop-stack (calc-stack-size)))
X (t
X (calc-pop-stack nn)))))
X)
X
X(defun calc-roll-down (n)
X "Exchange the top two elements of the Calculator stack.
XWith a numeric prefix, roll down the top N elements."
X (interactive "P")
X (calc-wrapper
X (let ((nn (prefix-numeric-value n)))
X (cond ((null n)
X (calc-roll-down-stack 2))
X ((> nn 0)
X (calc-roll-down-stack nn))
X ((= nn 0)
X (calc-pop-push-list (calc-stack-size)
X (reverse
X (calc-top-list (calc-stack-size)))))
X (t
X (calc-roll-down-stack (calc-stack-size) (- nn))))))
X)
X
X(defun calc-roll-up (n)
X "Roll up the top three elements of the Calculator stack.
XWith a numeric prefix, roll up the top N elements."
X (interactive "P")
X (calc-wrapper
X (let ((nn (prefix-numeric-value n)))
X (cond ((null n)
X (calc-roll-up-stack 3))
X ((> nn 0)
X (calc-roll-up-stack nn))
X ((= nn 0)
X (calc-pop-push-list (calc-stack-size)
X (reverse
X (calc-top-list (calc-stack-size)))))
X (t
X (calc-roll-up-stack (calc-stack-size) (- nn))))))
X)
X
X
X
X
X;;; Miscellaneous commands.
X
X(defun calc-precision (n)
X "Display current float precision for Calculator, or set precision to N digits."
X (interactive "NPrecision: ")
X (calc-wrapper
X (if (< (prefix-numeric-value n) 3)
X (error "Precision must be at least 3 digits.")
X (setq calc-internal-prec (prefix-numeric-value n))
X (calc-record calc-internal-prec "prec"))
X (message "Floating-point precision is %d digits." calc-internal-prec))
X)
X
X
X(defun calc-num-prefix-name (n)
X (cond ((eq n '-) "- ")
X ((equal n '(4)) "C-u ")
X ((consp n) (format "%d " (car n)))
X ((integerp n) (format "%d " n))
X (t ""))
X)
X
X(defun calc-missing-key (n)
X "This is a placeholder for a command which needs to be loaded from calc-ext.
XWhen this key is used, calc-ext (the Calculator extensions module) will be
Xloaded and the keystroke automatically re-typed."
X (interactive "P")
X (calc-extensions)
X (if (keymapp (key-binding (char-to-string last-command-char)))
X (message "%s%c-" (calc-num-prefix-name n) last-command-char))
X (setq unread-command-char last-command-char
X prefix-arg n)
X)
X
X(defun calc-why ()
X "Explain why the last result was unusual."
X (interactive)
X (if (not (eq this-command last-command))
X (setq calc-which-why calc-why))
X (if calc-which-why
X (progn
X (calc-explain-why (car calc-which-why))
X (setq calc-which-why (cdr calc-which-why)))
X (if calc-why
X (progn
X (message "(No further explanations available)")
X (setq calc-which-why calc-why))
X (message "No explanations available")))
X)
X(setq calc-which-why nil)
X
X(defun calc-flush-caches ()
X "Clear all caches used internally by the Calculator, such as the values of
Xpi and e. These values will be recomputed next time they are requested."
X (interactive)
X (calc-wrapper
X (setq math-lud-cache nil
X math-log2-cache nil
X math-max-digits-cache nil
X math-integral-cache nil
X math-units-table nil)
X (mapcar (function (lambda (x) (set x -100))) math-cache-list)
X (message "All internal calculator caches have been reset."))
X)
X(setq math-cache-list nil)
X
X
X
X;;;; Reading an expression in algebraic form.
X
X(defun calc-algebraic-entry ()
X "Read an algebraic expression (e.g., 1+2*3) and push the result on the stack."
X (interactive)
X (calc-wrapper
X (calc-alg-entry))
X)
X
X(defun calc-auto-alg-entry ()
X "Begin entering an algebraic expression with a '$' or '\"' character."
X (interactive)
X (calc-wrapper
X (calc-alg-entry (char-to-string last-command-char)))
X)
X
X(defun calc-alg-entry (&optional initial prompt)
X (let* ((calc-dollar-values (mapcar 'car-safe
X (nthcdr calc-stack-top calc-stack)))
X (calc-dollar-used 0)
X (alg-exp (calc-do-alg-entry initial prompt t)))
X (let ((nvals (mapcar 'calc-normalize alg-exp)))
X (while alg-exp
X (calc-record (car alg-exp) "alg'")
X (calc-pop-push-record calc-dollar-used "" (car nvals))
X (setq alg-exp (cdr alg-exp)
X nvals (cdr nvals)
X calc-dollar-used 0)))
X (calc-handle-whys))
X)
X
X(defun calc-do-alg-entry (&optional initial prompt no-normalize)
X (let* ((alg-exp 'error)
X (alg (read-from-minibuffer (or prompt "Algebraic: ")
X (or initial "")
X calc-alg-ent-map nil)))
X (if (eq alg-exp 'error)
X (if (eq (car (setq alg-exp (math-read-exprs alg)))
X 'error)
X (error "Error: %s" (or (nth 2 exp) "Bad format"))))
X (or no-normalize
X (setq alg-exp (mapcar 'calc-normalize alg-exp)))
X alg-exp)
X)
X
X(defvar calc-alg-ent-map nil "Keymap for use by the calc-algebraic-entry command.")
X(if calc-alg-ent-map
X ()
X (setq calc-alg-ent-map (copy-keymap minibuffer-local-map))
X (define-key calc-alg-ent-map "'" 'calcAlg-previous)
X (define-key calc-alg-ent-map "\ep" 'calcAlg-plus-minus)
X (define-key calc-alg-ent-map "\em" 'calcAlg-mod)
X (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter)
X (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter)
X)
X
X(defun calcAlg-plus-minus ()
X (interactive)
X (if (calc-minibuffer-contains ".* \\'")
X (insert "+/- ")
X (insert " +/- "))
X)
X
X(defun calcAlg-mod ()
X (interactive)
X (if (not (calc-minibuffer-contains ".* \\'"))
X (insert " "))
X (if (calc-minibuffer-contains ".* mod +\\'")
X (if calc-previous-modulo
X (insert (math-format-flat-expr calc-previous-modulo 0))
X (beep))
X (insert "mod "))
X)
X
X(defun calcAlg-previous ()
X (interactive)
X (if (calc-minibuffer-contains "\\`\\'")
X (if calc-previous-alg-entry
X (insert calc-previous-alg-entry)
X (beep))
X (insert "'"))
X)
X
X(defun calcAlg-enter ()
X (interactive)
X (let ((exp (and (> (buffer-size) 0)
X (math-read-exprs (buffer-string)))))
X (if (eq (car-safe exp) 'error)
X (progn
X (goto-char (point-min))
X (forward-char (nth 1 exp))
X (beep)
X (calc-temp-minibuffer-message
X (concat " [" (or (nth 2 exp) "Error") "]"))
X (setq unread-command-char -1))
X (setq alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'")
X '((incomplete vec))
X exp)
X calc-previous-alg-entry (buffer-string))
X (exit-minibuffer)))
X)
X
X
X
X;;;; Reading a number using the minibuffer.
X
X(defun calcDigit-start ()
X "Begin digit entry in the Calculator."
X (interactive)
X (calc-wrapper
X (if calc-algebraic-mode
X (cond ((eq last-command-char ?e) (calc-alg-entry "1e"))
X ((eq last-command-char ?#) (calc-alg-entry
X (format "%d#" calc-number-radix)))
X ((eq last-command-char ?_) (calc-alg-entry "-"))
X ((eq last-command-char ?@) (calc-alg-entry "0@ "))
X (t (calc-alg-entry (char-to-string last-command-char))))
X (let ((calc-digit-value 'yow)
X (calc-prev-char nil)
X (calc-prev-prev-char nil))
X (setq unread-command-char last-command-char)
X (let ((str (read-from-minibuffer "Calc: " ""
X calc-digit-map)))
X (if (eq calc-digit-value 'yow)
X (setq calc-digit-value (math-read-number str))))
X (if (stringp calc-digit-value)
X (calc-alg-entry calc-digit-value)
X (if calc-digit-value
X (calc-push (calc-record (calc-normalize calc-digit-value)))))
X (if (eq calc-prev-char 'dots)
X (progn
X (calc-extensions)
X (calc-dots))))))
X)
X
X(defun calcDigit-nondigit ()
X (interactive)
X (setq calc-digit-value (math-read-number (buffer-string)))
X (if (and (null calc-digit-value) (> (buffer-size) 0))
X (progn
X (beep)
X (calc-temp-minibuffer-message " [Bad format]"))
X (or (memq last-command-char '(32 10 13))
X (setq prefix-arg current-prefix-arg
X unread-command-char last-command-char))
X (exit-minibuffer))
X)
X
X(defun calcDigit-algebraic ()
X (interactive)
X (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'")
X (calcDigit-key)
X (setq calc-digit-value (buffer-string))
X (exit-minibuffer))
X)
X
X(defun calc-minibuffer-contains (rex)
X (save-excursion
X (goto-char (point-min))
X (looking-at rex))
X)
X
X(defun calcDigit-key ()
X (interactive)
X (goto-char (point-max))
X (if (or (and (memq last-command-char '(?+ ?-))
X (> (buffer-size) 0)
X (/= (preceding-char) ?e))
X (and (memq last-command-char '(?m ?s))
X (not (calc-minibuffer-contains "[-+]?[0-9]+\\.?0*[@oh].*"))
X (not (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*"))))
X (calcDigit-nondigit)
X (if (calc-minibuffer-contains "\\([-+]?\\|.* \\)\\'")
X (cond ((memq last-command-char '(?. ?@)) (insert "0"))
X ((and (memq last-command-char '(?o ?h ?m))
X (not (calc-minibuffer-contains ".*#.*"))) (insert "0"))
X ((memq last-command-char '(?: ?e)) (insert "1"))
X ((eq last-command-char ?#)
X (insert (int-to-string calc-number-radix)))))
X (if (and (calc-minibuffer-contains "\\([-+]?[0-9]+#\\|[^:]*:\\)\\'")
X (eq last-command-char ?:))
X (insert "1"))
X (if (or (and (memq last-command-char '(?e ?h ?o ?m ?s ?p))
X (calc-minibuffer-contains ".*#.*"))
X (and (eq last-command-char ?n)
X (calc-minibuffer-contains "[-+]?\\(2[4-9]\\|[3-9][0-9]\\)#.*")))
X (setq last-command-char (upcase last-command-char)))
X (cond
X ((memq last-command-char '(?_ ?n))
X (goto-char (point-min))
X (if (and (search-forward " +/- " nil t)
X (not (search-forward "e" nil t)))
X (beep)
X (and (not (calc-minibuffer-contains ".*#.*"))
X (search-forward "e" nil t))
X (if (looking-at "+")
X (delete-char 1))
X (if (looking-at "-")
X (delete-char 1)
X (insert "-")))
X (goto-char (point-max)))
X ((eq last-command-char ?p)
X (if (or (calc-minibuffer-contains ".*\\+/-.*")
X (calc-minibuffer-contains ".*mod.*")
X (calc-minibuffer-contains ".*#.*")
X (calc-minibuffer-contains ".*[-+e:]\\'"))
X (beep)
X (if (not (calc-minibuffer-contains ".* \\'"))
X (insert " "))
X (insert "+/- ")))
X ((and (eq last-command-char ?M)
X (not (calc-minibuffer-contains
X "[-+]?\\(2[3-9]\\|[3-9][0-9]\\)#.*")))
X (if (or (calc-minibuffer-contains ".*\\+/-.*")
X (calc-minibuffer-contains ".*mod *[^ ]+")
X (calc-minibuffer-contains ".*[-+e:]\\'"))
X (beep)
X (if (calc-minibuffer-contains ".*mod \\'")
X (if calc-previous-modulo
X (insert (math-format-flat-expr calc-previous-modulo 0))
X (beep))
X (if (not (calc-minibuffer-contains ".* \\'"))
X (insert " "))
X (insert "mod "))))
X (t
X (insert (char-to-string last-command-char))
X (if (or (and (calc-minibuffer-contains "[-+]?\\(.*\\+/- *\\|.*mod *\\)?\\([0-9][0-9]?\\)#[0-9a-zA-Z]*\\(:[0-9a-zA-Z]*\\)?\\(:[0-9a-zA-Z]*\\)?\\'")
X (let ((radix (string-to-int
X (buffer-substring
X (match-beginning 2) (match-end 2)))))
X (and (>= radix 2)
X (<= radix 36)
X (or (memq last-command-char '(?# ?:))
X (let ((dig (math-read-radix-digit
X (upcase last-command-char))))
X (and dig
X (< dig radix)))))))
X (save-excursion
X (goto-char (point-min))
X (looking-at
X "[-+]?\\(.*\\+/- *\\|.*mod *\\)?\\([0-9]+\\.?0*[@oh] *\\)?\\([0-9]+\\.?0*['m] *\\)?[0-9]*\\(\\.?[0-9]*\\(e[-+]?[0-9]*\\)?\\|[0-9]:\\([0-9]+:\\)?[0-9]*\\)?[\"s]?\\'")))
X (if (and (memq last-command-char '(?@ ?o ?h ?\' ?m))
X (string-match " " calc-hms-format))
X (insert " "))
X (if (and (eq this-command last-command)
X (eq last-command-char ?.))
X (if (eq calc-prev-char ?.)
X (progn
X (delete-backward-char 1)
X (if (calc-minibuffer-contains ".*\\.\\'")
X (delete-backward-char 1))
X (setq calc-prev-char 'dots
X last-command-char 32)
X (if calc-prev-prev-char
X (calcDigit-nondigit)
X (setq calc-digit-value nil)
X (exit-minibuffer)))
X ;; just ignore extra decimal point, anticipating ".."
X (delete-backward-char 1))
X (delete-backward-char 1)
X (beep)
X (calc-temp-minibuffer-message " [Bad format]"))))))
X (setq calc-prev-prev-char calc-prev-char
X calc-prev-char last-command-char)
X)
X
X(defun calcDigit-letter ()
X (interactive)
X (if (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*")
X (progn
X (setq last-command-char (upcase last-command-char))
X (calcDigit-key))
X (calcDigit-nondigit))
X)
X
X(defun calcDigit-backspace ()
X (interactive)
X (goto-char (point-max))
X (cond ((calc-minibuffer-contains ".* \\+/- \\'")
X (backward-delete-char 5))
X ((calc-minibuffer-contains ".* mod \\'")
X (backward-delete-char 5))
X ((calc-minibuffer-contains ".* \\'")
X (backward-delete-char 2))
X (t (backward-delete-char 1)))
X (if (= (buffer-size) 0)
X (progn
X (setq last-command-char 10)
X (calcDigit-nondigit)))
X)
X
X(defun calc-temp-minibuffer-message (m)
X "A Lisp version of temp_minibuffer_message from minibuf.c."
X (let ((savemax (point-max)))
X (save-excursion
X (goto-char (point-max))
X (insert m))
X (let ((inhibit-quit t))
X (sit-for 2)
X (delete-region savemax (point-max))
X (if quit-flag
X (setq quit-flag nil
X unread-command-char 7))))
X)
X
X
X
X
X
X
X
X;;;; Arithmetic routines.
X;;;
X;;; An object as manipulated by one of these routines may take any of the
X;;; following forms:
X;;;
X;;; integer An integer. For normalized numbers, this format
X;;; is used only for -999999 ... 999999.
X;;;
X;;; (bigpos N0 N1 N2 ...) A big positive integer, N0 + N1*1000 + N2*10^6 ...
X;;; (bigneg N0 N1 N2 ...) A big negative integer, - N0 - N1*1000 ...
X;;; Each digit N is in the range 0 ... 999.
X;;; Normalized, always at least three N present,
X;;; and the most significant N is nonzero.
X;;;
X;;; (frac NUM DEN) A fraction. NUM and DEN are small or big integers.
X;;; Normalized, DEN > 1.
X;;;
X;;; (float NUM EXP) A floating-point number, NUM * 10^EXP;
X;;; NUM is a small or big integer, EXP is a small int.
X;;; Normalized, NUM is not a multiple of 10, and
X;;; abs(NUM) < 10^calc-internal-prec.
X;;; Normalized zero is stored as (float 0 0).
X;;;
X;;; (cplx REAL IMAG) A complex number; REAL and IMAG are any of above.
X;;; Normalized, IMAG is nonzero.
X;;;
X;;; (polar R THETA) Polar complex number. Normalized, R > 0 and THETA
X;;; is neither zero nor 180 degrees (pi radians).
X;;;
X;;; (vec A B C ...) Vector of objects A, B, C, ... A matrix is a
X;;; vector of vectors.
X;;;
X;;; (hms H M S) Angle in hours-minutes-seconds form. All three
X;;; components have the same sign; H and M must be
X;;; numerically integers; M and S are expected to
X;;; lie in the range [0,60).
X;;;
X;;; (sdev X SIGMA) Error form, X +/- SIGMA. When normalized,
X;;; SIGMA > 0. X and SIGMA are any real numbers,
X;;; or symbolic expressions which are assumed real.
X;;;
X;;; (intv MASK LO HI) Interval form. MASK is 0=(), 1=(], 2=[), or 3=[].
X;;; LO and HI are any real numbers, or symbolic
X;;; expressions which are assumed real, and LO < HI.
X;;; For [LO..HI], if LO = HI normalization produces LO,
X;;; and if LO > HI normalization produces [LO..LO).
X;;; For other intervals, if LO > HI normalization
X;;; sets HI equal to LO.
X;;;
X;;; (mod N M) Number modulo M. When normalized, 0 <= N < M.
X;;; N and M are real numbers.
X;;;
X;;; (var V S) Symbolic variable. V is a Lisp symbol which
X;;; represents the variable's visible name. S is
X;;; the symbol which actually stores the variable's
X;;; value: (var pi var-pi).
X;;;
X;;; In general, combining rational numbers in a calculation always produces
X;;; a rational result, but if either argument is a float, result is a float.
X
X;;; In the following comments, [x y z] means result is x, args must be y, z,
X;;; respectively, where the code letters are:
X;;;
X;;; O Normalized object (vector or number)
X;;; V Normalized vector
X;;; N Normalized number of any type
X;;; N Normalized complex number
X;;; R Normalized real number (float or rational)
X;;; F Normalized floating-point number
X;;; T Normalized rational number
X;;; I Normalized integer
X;;; B Normalized big integer
X;;; S Normalized small integer
X;;; D Digit (small integer, 0..999)
X;;; L Normalized bignum digit list (without "bigpos" or "bigneg" symbol)
X;;; or normalized vector element list (without "vec")
X;;; P Predicate (truth value)
X;;; X Any Lisp object
X;;; Z "nil"
X;;;
X;;; Lower-case letters signify possibly un-normalized values.
X;;; "L.D" means a cons of an L and a D.
X;;; [N N; n n] means result will be normalized if argument is.
X;;; Also, [Public] marks routines intended to be called from outside.
X;;; [This notation has been neglected in many recent routines.]
X
X;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public]
X(defun math-normalize (a)
X (cond
X ((not (consp a))
X (if (integerp a)
X (if (or (>= a 1000000) (<= a -1000000))
X (math-bignum a)
X a)
X a))
X ((eq (car a) 'bigpos)
X (if (eq (nth (1- (length a)) a) 0)
X (let* ((last (setq a (copy-sequence a))) (digs a))
X (while (setq digs (cdr digs))
X (or (eq (car digs) 0) (setq last digs)))
X (setcdr last nil)))
X (if (cdr (cdr (cdr a)))
X a
X (cond
X ((cdr (cdr a)) (+ (nth 1 a) (* (nth 2 a) 1000)))
X ((cdr a) (nth 1 a))
X (t 0))))
X ((eq (car a) 'bigneg)
X (if (eq (nth (1- (length a)) a) 0)
X (let* ((last (setq a (copy-sequence a))) (digs a))
X (while (setq digs (cdr digs))
X (or (eq (car digs) 0) (setq last digs)))
X (setcdr last nil)))
X (if (cdr (cdr (cdr a)))
X a
X (cond
X ((cdr (cdr a)) (- (+ (nth 1 a) (* (nth 2 a) 1000))))
X ((cdr a) (- (nth 1 a)))
X (t 0))))
X ((eq (car a) 'frac)
X (math-make-frac (math-normalize (nth 1 a))
X (math-normalize (nth 2 a))))
X ((eq (car a) 'float)
X (math-make-float (math-normalize (nth 1 a)) (nth 2 a)))
X ((eq (car a) 'cplx)
X (let ((real (math-normalize (nth 1 a)))
X (imag (math-normalize (nth 2 a))))
X (if (math-zerop imag) real (list 'cplx real imag))))
X ((eq (car a) 'polar)
X (calc-extensions)
X (math-normalize-polar a))
X ((eq (car a) 'hms)
X (calc-extensions)
X (math-normalize-hms a))
X ((eq (car a) 'mod)
X (calc-extensions)
X (math-normalize-mod a))
X ((eq (car a) 'sdev)
X (calc-extensions)
X (math-make-sdev (math-normalize (nth 1 a))
X (math-normalize (nth 2 a))))
X ((eq (car a) 'intv)
X (calc-extensions)
X (math-make-intv (nth 1 a)
X (math-normalize (nth 2 a))
X (math-normalize (nth 3 a))))
X ((eq (car a) 'vec)
X (cons 'vec (mapcar 'math-normalize (cdr a))))
X ((memq (car a) '(quote special-const))
X (math-normalize (nth 1 a)))
X ((eq (car a) 'var)
X a)
X ((or (integerp (car a)) (and (consp (car a))
X (not (eq (car (car a)) 'lambda))))
X (if (null (cdr a))
X (math-normalize (car a))
X (error "Can't use multi-valued function in an expression")))
X ((eq (car a) 'calcFunc-if)
X (calc-extensions)
X (math-normalize-logical-op a))
X (t
X (let ((args (mapcar 'math-normalize (cdr a))))
X (or (and calc-simplify-mode
X (symbolp (car a))
X (or (eq calc-simplify-mode 'none)
X (and (eq calc-simplify-mode 'num)
X (let ((aptr args))
X (while (and aptr (or (math-scalarp (car aptr))
X (eq (car-safe (car aptr))
X 'mod)))
X (setq aptr (cdr aptr)))
X aptr)))
X (cons (car a) args))
X (condition-case err
X (let ((func (assq (car a) '( ( + . math-add )
X ( - . math-sub )
X ( * . math-mul )
X ( / . math-div )
X ( % . math-mod )
X ( ^ . math-pow )
X ( neg . math-neg )
X ( | . math-concat ) ))))
X (if func
X (apply (cdr func) args)
X (and (or (consp (car a))
X (fboundp (car a))
X (and (not calc-extensions-loaded)
X (calc-extensions)
X (fboundp (car a))))
X (apply (car a) args))))
X (wrong-number-of-arguments
X (calc-record-why "Wrong number of arguments") nil)
X (wrong-type-argument
X (or calc-next-why (calc-record-why "Wrong type of argument"))
X nil)
X (args-out-of-range
X (calc-record-why "Argument out of range") nil)
X (inexact-result
X (calc-record-why "No exact representation for result") nil))
X (if (consp (car a))
X (math-dimension-error)
X (cons (car a) args))))))
X)
X
X(defmacro math-with-extra-prec (delta &rest body)
X (` (math-normalize
X (let ((calc-internal-prec (+ calc-internal-prec (, delta))))
X (,@ body))))
X)
X(put 'math-with-extra-prec 'lisp-indent-hook 1)
X
X;;; Define "inexact-result" as an e-lisp error symbol.
X(put 'inexact-result 'error-conditions '(error inexact-result calc-error))
X(put 'inexact-result 'error-message "Calc internal error (inexact-result)")
X
X;;; Normalize a bignum digit list by trimming high-end zeros. [L l]
X(defun math-norm-bignum (a)
X (let ((digs a) (last nil))
X (while digs
X (or (eq (car digs) 0) (setq last digs))
X (setq digs (cdr digs)))
X (and last
X (progn
X (setcdr last nil)
X a)))
X)
X
X
X;;; Concatenate two vectors, or a vector and an object. [V O O] [Public]
X(defun math-concat (v1 v2)
X (if (stringp v1)
X (concat v1 v2)
X (calc-extensions)
X (if (and (math-objvecp v1) (math-objvecp v2))
X (append (if (and (math-vectorp v1)
X (or (math-matrixp v1)
X (not (math-matrixp v2))))
X v1
X (list 'vec v1))
X (if (and (math-vectorp v2)
X (or (math-matrixp v2)
X (not (math-matrixp v1))))
X (cdr v2)
X (list v2)))
X (list '| v1 v2)))
X)
X(defun calcFunc-vconcat (a b)
X (math-normalize (list '| a b))
X)
X
X
X;;; True if A is zero. Works for un-normalized values. [P n] [Public]
X(defun math-zerop (a)
X (if (consp a)
X (cond ((memq (car a) '(bigpos bigneg))
X (while (eq (car (setq a (cdr a))) 0))
X (null a))
X ((memq (car a) '(frac float polar mod))
X (math-zerop (nth 1 a)))
X ((eq (car a) 'cplx)
X (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a))))
X ((eq (car a) 'hms)
X (and (math-zerop (nth 1 a))
X (math-zerop (nth 2 a))
X (math-zerop (nth 3 a)))))
X (eq a 0))
X)
X;;; Faster in-line version zerop, normalized values only.
X(defmacro Math-zerop (a) ; [P N]
X (` (if (consp (, a))
X (and (not (memq (car (, a)) '(bigpos bigneg)))
X (if (eq (car (, a)) 'float)
X (eq (nth 1 (, a)) 0)
X (math-zerop (, a))))
X (eq (, a) 0)))
X)
X
X(defun math-zerop-bignum (a)
X (and (eq (car a) 0)
X (progn
X (while (eq (car (setq a (cdr a))) 0))
X (null a)))
X)
X
X(defmacro Math-natnum-lessp (a b)
X (` (if (consp (, a))
X (and (consp (, b))
X (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1))
X (or (consp (, b))
X (< (, a) (, b)))))
X)
X
X(defmacro Math-integer-negp (a)
X (` (if (consp (, a))
X (eq (car (, a)) 'bigneg)
X (< (, a) 0)))
X)
X
X(defmacro Math-integer-posp (a)
X (` (if (consp (, a))
X (eq (car (, a)) 'bigpos)
X (> (, a) 0)))
X)
X
X;;; True if A is real and negative. [P n] [Public]
X(defun math-negp (a)
X (if (consp a)
X (cond ((eq (car a) 'bigpos) nil)
X ((eq (car a) 'bigneg) (cdr a))
X ((eq (car a) 'frac)
X (if (Math-integer-negp (nth 2 a))
X (Math-integer-posp (nth 1 a))
X (Math-integer-negp (nth 1 a))))
X ((eq (car a) 'float)
X (Math-integer-negp (nth 1 a)))
X ((eq (car a) 'hms)
X (if (math-zerop (nth 1 a))
X (if (math-zerop (nth 2 a))
X (math-negp (nth 3 a))
X (math-negp (nth 2 a)))
X (math-negp (nth 1 a))))
X ((eq (car a) 'intv)
X (or (math-negp (nth 3 a))
X (and (math-zerop (nth 3 a))
X (memq (nth 1 a) '(0 2))))))
X (< a 0))
X)
X(defmacro Math-negp (a)
X (` (if (consp (, a))
X (or (eq (car (, a)) 'bigneg)
X (and (not (eq (car (, a)) 'bigpos))
X (if (memq (car (, a)) '(frac float))
X (Math-integer-negp (nth 1 (, a)))
X (math-negp (, a)))))
X (< (, a) 0)))
X)
X
X;;; True if A is a negative number or an expression the starts with '-'.
X(defun math-looks-negp (a) ; [P x] [Public]
X (or (Math-negp a)
X (eq (car-safe a) 'neg)
X (and (memq (car-safe a) '(* /))
X (or (math-looks-negp (nth 1 a))
X (math-looks-negp (nth 2 a)))))
X)
X(defmacro Math-looks-negp (a) ; [P x] [Public]
X (` (or (Math-negp (, a))
X (and (consp (, a)) (or (eq (car (, a)) 'neg)
X (and (memq (car (, a)) '(* /))
X (or (math-looks-negp (nth 1 (, a)))
X (math-looks-negp (nth 2 (, a)))))))))
X)
X
X;;; True if A is real and positive. [P n] [Public]
X(defun math-posp (a)
X (if (consp a)
X (cond ((eq (car a) 'bigpos) (cdr a))
X ((eq (car a) 'bigneg) nil)
X ((eq (car a) 'frac)
X (if (Math-integer-negp (nth 2 a))
X (Math-integer-negp (nth 1 a))
X (Math-integer-posp (nth 1 a))))
X ((eq (car a) 'float)
X (Math-integer-posp (nth 1 a)))
X ((eq (car a) 'hms)
X (if (math-zerop (nth 1 a))
X (if (math-zerop (nth 2 a))
X (math-posp (nth 3 a))
X (math-posp (nth 2 a)))
X (math-posp (nth 1 a))))
X ((eq (car a) 'mod)
X (not (math-zerop (nth 1 a))))
X ((eq (car a) 'intv)
X (or (math-posp (nth 2 a))
X (and (math-zerop (nth 2 a))
X (memq (nth 1 a) '(0 1))))))
X (> a 0))
X)
X(defmacro Math-posp (a)
X (` (if (consp (, a))
X (or (eq (car (, a)) 'bigpos)
X (and (not (eq (car (, a)) 'bigneg))
X (if (memq (car (, a)) '(frac float))
X (Math-integer-posp (nth 1 (, a)))
X (math-posp (, a)))))
X (> (, a) 0)))
X)
X
X;;; True if A is a small or big integer. [P x] [Public]
X(defun math-integerp (a)
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg)))
X)
X(defmacro Math-integerp (a)
X (` (or (not (consp (, a)))
X (memq (car (, a)) '(bigpos bigneg))))
X)
X
X(fset 'math-fixnump (symbol-function 'integerp))
X(fset 'math-fixnatnump (symbol-function 'natnump))
X
X;;; True if A is (numerically) a non-negative integer. [P N] [Public]
X(defun math-natnump (a)
X (or (natnump a)
X (eq (car-safe a) 'bigpos))
X)
X(defmacro Math-natnump (a)
X (` (if (consp (, a))
X (eq (car (, a)) 'bigpos)
X (>= (, a) 0)))
X)
X
X;;; True if A is a rational (or integer). [P x] [Public]
X(defun math-ratp (a)
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac)))
X)
X(defmacro Math-ratp (a)
X (` (or (not (consp (, a)))
X (memq (car (, a)) '(bigpos bigneg frac))))
X)
X
X;;; True if A is a real (or rational). [P x] [Public]
X(defun math-realp (a)
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac float)))
X)
X(defmacro Math-realp (a)
X (` (or (not (consp (, a)))
X (memq (car (, a)) '(bigpos bigneg frac float))))
X)
X
X;;; True if A is a real or HMS form. [P x] [Public]
X(defun math-anglep (a)
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac float hms)))
X)
X(defmacro Math-anglep (a)
X (` (or (not (consp (, a)))
X (memq (car (, a)) '(bigpos bigneg frac float hms))))
X)
X
X;;; True if A is a floating-point real or complex number. [P x] [Public]
X(defun math-floatp (a)
X (or (eq (car-safe a) 'float)
X (and (memq (car-safe a) '(cplx polar mod sdev intv))
X (or (math-floatp (nth 1 a))
X (math-floatp (nth 2 a))
X (and (eq (car a) 'intv) (math-floatp (nth 3 a))))))
X)
X
X;;; True if A is a number of any kind. [P x] [Public]
X(defun math-numberp (a)
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac float cplx polar)))
X)
X(defmacro Math-numberp (a)
X (` (or (not (consp (, a)))
X (memq (car (, a)) '(bigpos bigneg frac float cplx polar))))
X)
X
X;;; True if A is a complex number or angle. [P x] [Public]
X(defun math-scalarp (a)
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac float cplx polar hms)))
X)
X(defmacro Math-scalarp (a)
X (` (or (not (consp (, a)))
X (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))
X)
X
X;;; True if A is a vector. [P x] [Public]
X(defun math-vectorp (a)
X (eq (car-safe a) 'vec)
X)
X(defmacro Math-vectorp (a)
X (` (and (consp (, a)) (eq (car (, a)) 'vec)))
X)
X
X;;; True if A is a number or a vector. [P x] [Public]
X(defun math-numvecp (a)
X (or (Math-numberp a)
X (Math-vectorp a))
X)
X
X;;; True if A is numerically (but not literally) an integer. [P x] [Public]
X(defun math-messy-integerp (a)
X (cond
X ((eq (car-safe a) 'float) (>= (nth 2 a) 0))
X ((eq (car-safe a) 'frac) (Math-integerp (math-normalize a))))
X)
X(defmacro Math-messy-integerp (a)
X (` (and (consp (, a))
X (eq (car (, a)) 'float)
X (>= (nth 2 (, a)) 0)))
X)
X
X;;; True if A is any scalar data object. [P x]
X(defun math-objectp (a) ; [Public]
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac float cplx
X polar hms sdev intv mod)))
X)
X(defmacro Math-objectp (a) ; [Public]
X (` (or (not (consp (, a)))
X (memq (car (, a))
X '(bigpos bigneg frac float cplx polar hms sdev intv mod))))
X)
X
X;;; True if A is any vector or scalar data object. [P x]
X(defun math-objvecp (a) ; [Public]
X (or (integerp a)
X (memq (car-safe a) '(bigpos bigneg frac float cplx polar
X hms sdev intv mod vec incomplete)))
X)
X(defmacro Math-objvecp (a) ; [Public]
X (` (or (not (consp (, a)))
X (memq (car (, a))
X '(bigpos bigneg frac float cplx polar hms sdev intv mod vec))))
X)
X
X
X;;; True if A is an even integer. [P R R] [Public]
X(defun math-evenp (a)
X (if (consp a)
X (and (memq (car a) '(bigpos bigneg))
X (= (% (nth 1 a) 2) 0))
X (= (% a 2) 0))
X)
X
X;;; Compute A / 2, for small or big integer A. [I i]
X;;; If A is negative, type of truncation is undefined.
X(defun math-div2 (a)
X (if (consp a)
X (if (cdr a)
X (math-normalize (cons (car a) (math-div2-bignum (cdr a))))
X 0)
X (/ a 2))
X)
X
X(defun math-div2-bignum (a) ; [l l]
X (cond
X ((null (cdr a)) (list (/ (car a) 2)))
X (t (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500))
X (math-div2-bignum (cdr a)))))
X)
X
X
X;;; Verify that A is a complete object and return A. [x x] [Public]
X(defun math-check-complete (a)
X (cond ((integerp a) a)
X ((eq (car-safe a) 'incomplete)
X (cond ((memq (nth 1 a) '(cplx polar))
X (error "Complex number is incomplete"))
X ((eq (nth 1 a) 'vec)
X (error "Vector is incomplete"))
X ((eq (nth 1 a) 'intv)
X (error "Interval form is incomplete"))
X (t (error "Object is incomplete"))))
X ((consp a) a)
X (t (error "Invalid data object encountered")))
X)
X
X;;; Reject an argument to a calculator function. [Public]
X(defun math-reject-arg (&optional a p)
X (calc-record-why p a)
X (signal 'wrong-type-argument (and a (if p (list p a) (list a))))
X)
X
X
X;;; Coerce A to be an integer (by truncation toward zero). [I N] [Public]
X(defun math-trunc (a)
X (cond ((Math-integerp a) a)
X ((Math-looks-negp a)
X (math-neg (math-trunc (math-neg a))))
X ((eq (car a) 'float) (math-scale-int (nth 1 a) (nth 2 a)))
X ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a)))
X (t (calc-extensions)
X (math-trunc-fancy a)))
X)
X(fset 'calcFunc-trunc (symbol-function 'math-trunc))
X
X;;; Coerce A to be an integer (by truncation toward minus infinity). [I N]
X(defun math-floor (a) ; [Public]
X (cond ((Math-integerp a) a)
X ((Math-messy-integerp a) (math-trunc a))
X ((Math-realp a)
X (if (Math-negp a)
X (math-add (math-trunc a) -1)
X (math-trunc a)))
X (t (calc-extensions)
X (math-floor-fancy a)))
X)
X(fset 'calcFunc-floor (symbol-function 'math-floor))
X
X
X;;; Coerce integer A to be a bignum. [B S]
X(defun math-bignum (a)
X (if (>= a 0)
X (cons 'bigpos (math-bignum-big a))
X (cons 'bigneg (math-bignum-big (- a))))
X)
X
X(defun math-bignum-big (a) ; [L s]
X (if (= a 0)
X nil
X (cons (% a 1000) (math-bignum-big (/ a 1000))))
X)
X
X
X;;; Build a normalized fraction. [R I I]
X;;; (This could probably be implemented more efficiently than using the
X;;; the plain gcd algorithm.)
X(defun math-make-frac (num den)
X (if (Math-integer-negp den)
X (setq num (math-neg num)
X den (math-neg den)))
X (let ((gcd (math-gcd num den)))
X (if (eq gcd 1)
X (if (eq den 1)
X num
X (list 'frac num den))
X (if (equal gcd den)
X (math-quotient num gcd)
X (list 'frac (math-quotient num gcd) (math-quotient den gcd)))))
X)
X
X;;; Build a normalized floating-point number. [F I S]
X(defun math-make-float (mant exp)
X (if (eq mant 0)
X '(float 0 0)
X (let* ((ldiff (- calc-internal-prec (math-numdigs mant))))
X (if (< ldiff 0)
X (setq mant (math-scale-rounding mant ldiff)
X exp (- exp ldiff))))
X (if (consp mant)
X (let ((digs (cdr mant)))
X (if (= (% (car digs) 10) 0)
X (progn
X (while (= (car digs) 0)
X (setq digs (cdr digs)
X exp (+ exp 3)))
X (while (= (% (car digs) 10) 0)
X (setq digs (math-div10-bignum digs)
X exp (1+ exp)))
X (setq mant (math-normalize (cons (car mant) digs))))))
X (while (= (% mant 10) 0)
X (setq mant (/ mant 10)
X exp (1+ exp))))
X (list 'float mant exp))
X)
X
X(defun math-div10-bignum (a) ; [l l]
X (cond
X ((null (cdr a)) (list (/ (car a) 10)))
X (t (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100))
X (math-div10-bignum (cdr a)))))
X)
X
X;;; Coerce A to be a float. [F N; V V] [Public]
X(defun math-float (a)
X (cond ((Math-integerp a) (math-make-float a 0))
X ((eq (car a) 'frac) (math-div (math-float (nth 1 a)) (nth 2 a)))
X ((eq (car a) 'float) a)
X ((memq (car a) '(cplx polar vec hms sdev intv mod))
X (cons (car a) (mapcar 'math-float (cdr a))))
X (t (math-reject-arg a 'objectp)))
X)
X(fset 'calcFunc-float (symbol-function 'math-float))
X
X
X;;; Compute the negative of A. [O O; o o] [Public]
X(defmacro Math-integer-neg (a)
X (` (if (consp (, a))
X (if (eq (car (, a)) 'bigpos)
X (cons 'bigneg (cdr (, a)))
X (cons 'bigpos (cdr (, a))))
X (- (, a))))
X)
X(defun math-neg (a)
X (cond ((not (consp a)) (- a))
X ((eq (car a) 'bigpos) (cons 'bigneg (cdr a)))
X ((eq (car a) 'bigneg) (cons 'bigpos (cdr a)))
X ((memq (car a) '(frac float))
X (list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a)))
X ((memq (car a) '(cplx vec hms))
X (cons (car a) (mapcar 'math-neg (cdr a))))
X (t (math-neg-fancy a)))
X)
X(defun calcFunc-neg (a)
X (math-normalize (list 'neg a))
X)
X
X
X;;; Compute the number of decimal digits in integer A. [S I]
X(defun math-numdigs (a)
X (if (consp a)
X (if (cdr a)
X (let* ((len (1- (length a)))
X (top (nth len a)))
X (+ (* len 3) (cond ((>= top 100) 0) ((>= top 10) -1) (t -2))))
X 0)
X (cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3))
X ((>= a 10) 2)
X ((>= a 1) 1)
X ((= a 0) 0)
X ((> a -10) 1)
X ((> a -100) 2)
X (t (math-numdigs (- a)))))
X)
X
X;;; Multiply (with truncation toward 0) the integer A by 10^N. [I i S]
X(defun math-scale-int (a n)
X (cond ((= n 0) a)
X ((> n 0) (math-scale-left a n))
X (t (math-normalize (math-scale-right a (- n)))))
X)
X
X(defun math-scale-left (a n) ; [I I S]
X (if (= n 0)
X a
X (if (consp a)
X (cons (car a) (math-scale-left-bignum (cdr a) n))
X (if (>= n 3)
X (if (or (>= a 1000) (<= a -1000))
X (math-scale-left (math-bignum a) n)
X (math-scale-left (* a 1000) (- n 3)))
X (if (= n 2)
X (if (or (>= a 10000) (<= a -10000))
X (math-scale-left (math-bignum a) 2)
X (* a 100))
X (if (or (>= a 100000) (<= a -100000))
X (math-scale-left (math-bignum a) 1)
X (* a 10))))))
X)
X
X(defun math-scale-left-bignum (a n)
X (if (>= n 3)
X (while (>= (setq a (cons 0 a)
X n (- n 3)) 3)))
X (if (> n 0)
X (math-mul-bignum-digit a (if (= n 2) 100 10) 0)
X a)
X)
X
X(defun math-scale-right (a n) ; [i i S]
X (if (= n 0)
X a
X (if (consp a)
X (cons (car a) (math-scale-right-bignum (cdr a) n))
X (if (<= a 0)
X (if (= a 0)
X 0
X (- (math-scale-right (- a) n)))
X (if (>= n 3)
X (while (and (> (setq a (/ a 1000)) 0)
X (>= (setq n (- n 3)) 3))))
X (if (= n 2)
X (/ a 100)
X (if (= n 1)
X (/ a 10)
X a)))))
X)
X
X(defun math-scale-right-bignum (a n) ; [L L S; l l S]
X (if (>= n 3)
X (setq a (nthcdr (/ n 3) a)
X n (% n 3)))
X (if (> n 0)
X (cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0))
X a)
X)
X
X;;; Multiply (with rounding) the integer A by 10^N. [I i S]
X(defun math-scale-rounding (a n)
X (cond ((>= n 0)
X (math-scale-left a n))
X ((consp a)
X (math-normalize
X (cons (car a)
X (let ((val (if (< n -3)
X (math-scale-right-bignum (cdr a) (- -3 n))
X (if (= n -2)
X (math-mul-bignum-digit (cdr a) 10 0)
X (if (= n -1)
X (math-mul-bignum-digit (cdr a) 100 0)
X (cdr a)))))) ; n = -3
X (if (and val (>= (car val) 500))
X (if (cdr val)
X (if (eq (car (cdr val)) 999)
X (math-add-bignum (cdr val) '(1))
X (cons (1+ (car (cdr val))) (cdr (cdr val))))
X '(1))
X (cdr val))))))
X (t
X (if (< a 0)
X (- (math-scale-rounding (- a) n))
X (if (= n -1)
X (/ (+ a 5) 10)
X (/ (+ (math-scale-right a (- -1 n)) 5) 10)))))
X)
X
X
X;;; Compute the sum of A and B. [O O O] [Public]
X(defun math-add (a b)
X (or
X (and (not (or (consp a) (consp b)))
X (progn
X (setq a (+ a b))
X (if (or (<= a -1000000) (>= a 1000000))
X (math-bignum a)
X a)))
X (and (Math-zerop a) (not (eq (car-safe a) 'mod))
X (if (and (math-floatp a) (Math-ratp b)) (math-float b) b))
X (and (Math-zerop b) (not (eq (car-safe b) 'mod))
X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a))
X (and (Math-objvecp a) (Math-objvecp b)
X (or
X (and (Math-integerp a) (Math-integerp b)
X (progn
X (or (consp a) (setq a (math-bignum a)))
X (or (consp b) (setq b (math-bignum b)))
X (if (eq (car a) 'bigneg)
X (if (eq (car b) 'bigneg)
X (cons 'bigneg (math-add-bignum (cdr a) (cdr b)))
X (math-normalize
X (let ((diff (math-sub-bignum (cdr b) (cdr a))))
X (if (eq diff 'neg)
X (cons 'bigneg (math-sub-bignum (cdr a) (cdr b)))
X (cons 'bigpos diff)))))
X (if (eq (car b) 'bigneg)
X (math-normalize
X (let ((diff (math-sub-bignum (cdr a) (cdr b))))
X (if (eq diff 'neg)
X (cons 'bigneg (math-sub-bignum (cdr b) (cdr a)))
X (cons 'bigpos diff))))
X (cons 'bigpos (math-add-bignum (cdr a) (cdr b)))))))
X (and (Math-ratp a) (Math-ratp b)
X (if (eq (car-safe a) 'frac)
X (if (eq (car-safe b) 'frac)
X (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b))
X (math-mul (nth 2 a) (nth 1 b)))
X (math-mul (nth 2 a) (nth 2 b)))
X (math-make-frac (math-add (nth 1 a)
X (math-mul (nth 2 a) b))
X (nth 2 a)))
X (math-make-frac (math-add (math-mul a (nth 2 b))
X (nth 1 b))
X (nth 2 b))))
X (and (Math-realp a) (Math-realp b)
X (progn
X (or (and (consp a) (eq (car a) 'float))
X (setq a (math-float a)))
X (or (and (consp b) (eq (car b) 'float))
X (setq b (math-float b)))
X (math-add-float a b)))
X (and (calc-extensions)
X (math-add-objects-fancy a b))))
X (and (calc-extensions)
X (math-add-symb-fancy a b)))
X)
X(defun calcFunc-add (&rest rest)
X (if rest
X (let ((a (car rest)))
X (while (setq rest (cdr rest))
X (setq a (list '+ a (car rest))))
X (math-normalize a))
X 0)
X)
X
X(defun math-add-bignum (a b) ; [L L L; l l l]
X (if a
X (if b
X (let* ((a (copy-sequence a)) (aa a) (carry nil) sum)
X (while (and aa b)
X (if carry
X (if (< (setq sum (+ (car aa) (car b))) 999)
X (progn
X (setcar aa (1+ sum))
X (setq carry nil))
X (setcar aa (+ sum -999)))
X (if (< (setq sum (+ (car aa) (car b))) 1000)
X (setcar aa sum)
X (setcar aa (+ sum -1000))
X (setq carry t)))
X (setq aa (cdr aa)
X b (cdr b)))
X (if carry
X (if b
X (nconc a (math-add-bignum b '(1)))
X (while (eq (car aa) 999)
X (setcar aa 0)
X (setq aa (cdr aa)))
X (if aa
X (progn
X (setcar aa (1+ (car aa)))
X a)
X (nconc a '(1))))
X (if b
X (nconc a b)
X a)))
X a)
X b)
X)
X
X(defun math-sub-bignum (a b) ; [l l l]
X (if b
X (if a
X (let* ((a (copy-sequence a)) (aa a) (borrow nil) sum)
X (while (and aa b)
X (if borrow
X (if (>= (setq diff (- (car aa) (car b))) 1)
X (progn
X (setcar aa (1- diff))
X (setq borrow nil))
X (setcar aa (+ diff 999)))
X (if (>= (setq diff (- (car aa) (car b))) 0)
X (setcar aa diff)
X (setcar aa (+ diff 1000))
X (setq borrow t)))
X (setq aa (cdr aa)
X b (cdr b)))
X (if borrow
X (progn
X (while (eq (car aa) 0)
X (setcar aa 999)
X (setq aa (cdr aa)))
X (if aa
X (progn
X (setcar aa (1- (car aa)))
X a)
X 'neg))
X (while (eq (car b) 0)
X (setq b (cdr b)))
X (if b
X 'neg
X a)))
X (while (eq (car b) 0)
X (setq b (cdr b)))
X (and b
X 'neg))
X a)
X)
X
X(defun math-add-float (a b) ; [F 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 a
X (math-make-float (math-add (nth 1 b)
X (math-scale-int (nth 1 a) ediff))
X (nth 2 b)))
X (if (>= (setq ediff (- ediff))
X (+ calc-internal-prec calc-internal-prec))
X b
X (math-make-float (math-add (nth 1 a)
X (math-scale-int (nth 1 b) ediff))
X (nth 2 a)))))
X)
X
X;;; Compute the difference of A and B. [O O O] [Public]
X(defun math-sub (a b)
X (if (or (consp a) (consp b))
X (math-add a (math-neg b))
X (setq a (- a b))
X (if (or (<= a -1000000) (>= a 1000000))
X (math-bignum a)
X a))
X)
X(defun calcFunc-sub (&rest rest)
X (if rest
X (let ((a (car rest)))
X (while (setq rest (cdr rest))
X (setq a (list '- a (car rest))))
X (math-normalize a))
X 0)
X)
X
X(defun math-sub-float (a b) ; [F 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 a
X (math-make-float (math-add (Math-integer-neg (nth 1 b))
X (math-scale-int (nth 1 a) ediff))
X (nth 2 b)))
X (if (>= (setq ediff (- ediff))
X (+ calc-internal-prec calc-internal-prec))
X b
X (math-make-float (math-add (nth 1 a)
X (Math-integer-neg
X (math-scale-int (nth 1 b) ediff)))
X (nth 2 a)))))
X)
X
X
X;;; Compute the product of A and B. [O O O] [Public]
X(defun math-mul (a b)
X (or
X (and (not (consp a)) (not (consp b))
X (< a 1000) (> a -1000) (< b 1000) (> b -1000)
X (* a b))
X (and (Math-zerop a) (not (eq (car-safe b) 'mod))
X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a))
X (and (Math-zerop b) (not (eq (car-safe a) 'mod))
X (if (and (math-floatp a) (Math-ratp b)) (math-float b) b))
X (and (Math-objvecp a) (Math-objvecp b)
X (or
X (and (Math-integerp a) (Math-integerp b)
X (progn
X (or (consp a) (setq a (math-bignum a)))
X (or (consp b) (setq b (math-bignum b)))
X (math-normalize
X (cons (if (eq (car a) (car b)) 'bigpos 'bigneg)
X (if (cdr (cdr a))
X (if (cdr (cdr b))
X (math-mul-bignum (cdr a) (cdr b))
X (math-mul-bignum-digit (cdr a) (nth 1 b) 0))
X (math-mul-bignum-digit (cdr b) (nth 1 a) 0))))))
X (and (Math-ratp a) (Math-ratp b)
X (if (eq (car-safe a) 'frac)
X (if (eq (car-safe b) 'frac)
X (math-make-frac (math-mul (nth 1 a) (nth 1 b))
X (math-mul (nth 2 a) (nth 2 b)))
X (math-make-frac (math-mul (nth 1 a) b)
X (nth 2 a)))
X (math-make-frac (math-mul a (nth 1 b))
X (nth 2 b))))
X (and (Math-realp a) (Math-realp b)
X (progn
X (or (and (consp a) (eq (car a) 'float))
X (setq a (math-float a)))
X (or (and (consp b) (eq (car b) 'float))
X (setq b (math-float b)))
X (math-make-float (math-mul (nth 1 a) (nth 1 b))
X (+ (nth 2 a) (nth 2 b)))))
X (and (calc-extensions)
X (math-mul-objects-fancy a b))))
X (and (calc-extensions)
X (math-mul-symb-fancy a b)))
X)
X
X(defun calcFunc-mul (&rest rest)
X (if rest
X (let ((a (car rest)))
X (while (setq rest (cdr rest))
X (setq a (list '* a (car rest))))
X (math-normalize a))
X 1)
X)
X
X;;; Multiply digit lists A and B. [L L L; l l l]
X(defun math-mul-bignum (a b)
X (and a b
X (let* ((sum (if (<= (car b) 1)
X (if (= (car b) 0)
X (list 0)
X (copy-sequence a))
X (math-mul-bignum-digit a (car b) 0)))
X (sump sum) c d aa prod)
X (while (setq b (cdr b))
X (setq ss (setq sump (or (cdr sump) (setcdr sump (list 0))))
X d (car b)
X c 0
X aa a)
X (while (progn
X (setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d))
X c)) 1000))
X (setq aa (cdr aa)))
X (setq c (/ prod 1000)
X ss (or (cdr ss) (setcdr ss (list 0)))))
X (if (>= prod 1000)
X (if (cdr ss)
X (setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss))))
X (setcdr ss (list (/ prod 1000))))))
X sum))
X)
X
X;;; Multiply digit list A by digit D. [L L D D; l l D D]
X(defun math-mul-bignum-digit (a d c)
X (and a
X (if (<= d 1)
X (and (= d 1) a)
X (let* ((a (copy-sequence a)) (aa a) prod)
X (while (progn
X (setcar aa (% (setq prod (+ (* (car aa) d) c)) 1000))
X (cdr aa))
X (setq aa (cdr aa)
X c (/ prod 1000)))
X (if (>= prod 1000)
X (setcdr aa (list (/ prod 1000))))
X a)))
X)
X
X
X;;; Compute the square of A. [O O] [Public]
X(defun math-sqr (a)
X (if (eq (car-safe a) 'calcFunc-sqrt)
X (nth 1 a)
X (math-mul a a))
X)
X
X
X;;; Compute the integer (quotient . remainder) of A and B, which may be
X;;; small or big integers. Type and consistency of truncation is undefined
X;;; if A or B is negative. B must be nonzero. [I.I I I] [Public]
X(defun math-idivmod (a b)
X (if (eq b 0)
X (math-reject-arg a "Division by zero"))
X (if (or (consp a) (consp b))
X (if (and (natnump b) (< b 1000))
X (let ((res (math-div-bignum-digit (cdr a) b)))
X (cons
X (math-normalize (cons (car a) (car res)))
X (cdr res)))
X (or (consp a) (setq a (math-bignum a)))
X (or (consp b) (setq b (math-bignum b)))
X (let ((res (math-div-bignum (cdr a) (cdr b))))
X (cons
X (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg)
X (car res)))
X (math-normalize (cons (car a) (cdr res))))))
X (cons (/ a b) (% a b)))
X)
X
X(defun math-quotient (a b) ; [I I I] [Public]
X (if (and (not (consp a)) (not (consp b)))
X (if (= b 0)
X (math-reject-arg a "Division by zero")
X (/ a b))
X (if (and (natnump b) (< b 1000))
X (if (= b 0)
X (math-reject-arg a "Division by zero")
X (math-normalize (cons (car a)
X (car (math-div-bignum-digit (cdr a) b)))))
X (or (consp a) (setq a (math-bignum a)))
X (or (consp b) (setq b (math-bignum b)))
X (let* ((alen (1- (length a)))
X (blen (1- (length b)))
X (d (/ 1000 (1+ (nth (1- blen) (cdr b)))))
X (res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0)
X (math-mul-bignum-digit (cdr b) d 0)
X alen blen)))
X (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg)
X (car res))))))
X)
X
X(defun math-imod (a b) ; [I I I] [Public]
X (if (and (not (consp a)) (not (consp b)))
X (if (= b 0)
X (math-reject-arg a "Division by zero")
X (% a b))
X (cdr (math-idivmod a b)))
X)
X
X;;; Divide a bignum digit list by another. [l.l l L]
X;;; The following division algorithm is borrowed from Knuth vol. II, sec. 4.3.1
X(defun math-div-bignum (a b)
X (if (null (cdr b))
X (let ((res (math-div-bignum-digit a (car b))))
X (cons (car res) (list (cdr res))))
X (let* ((alen (length a))
X (blen (length b))
X (d (/ 1000 (1+ (nth (1- blen) b))))
X (res (math-div-bignum-big (math-mul-bignum-digit a d 0)
X (math-mul-bignum-digit b d 0)
X alen blen)))
X (if (= d 1)
X res
X (cons (car res)
X (car (math-div-bignum-digit (cdr res) d))))))
X)
X
X;;; Divide a bignum digit list by a digit. [l.D l D]
X(defun math-div-bignum-digit (a b)
X (if (null a)
X '(nil . 0)
X (let* ((res (math-div-bignum-digit (cdr a) b))
X (num (+ (* (cdr res) 1000) (car a))))
X (cons
X (cons (/ num b) (car res))
X (% num b))))
X)
X
X(defun math-div-bignum-big (a b alen blen) ; [l.l l L]
X (if (< alen blen)
X (cons nil a)
X (let* ((res (math-div-bignum-big (cdr a) b (1- alen) blen))
X (num (cons (car a) (cdr res)))
X (res2 (math-div-bignum-part num b blen)))
X (cons
X (cons (car res2) (car res))
X (cdr res2))))
X)
X
X(defun math-div-bignum-part (a b blen) ; a < b*1000 [D.l l L]
X (let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0)))
X (den (nth (1- blen) b))
X (guess (min (/ num den) 999)))
X (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess))
X)
X
X(defun math-div-bignum-try (a b c guess) ; [D.l l l D]
X (let ((rem (math-sub-bignum a c)))
X (if (eq rem 'neg)
X (math-div-bignum-try a b (math-sub-bignum c b) (1- guess))
X (cons guess rem)))
X)
X
X
X;;; Compute the quotient of A and B. [O O N] [Public]
X(defun math-div (a b)
X (or
X (and (Math-zerop b)
X (math-reject-arg a "Division by zero"))
X (and (Math-zerop a) (not (eq (car-safe b) 'mod))
X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a))
X (and (Math-objvecp a) (Math-objvecp b)
X (or
X (and (Math-integerp a) (Math-integerp b)
X (if calc-prefer-frac
X (math-make-frac a b)
X (let ((q (math-idivmod a b)))
X (if (eq (cdr q) 0)
X (car q)
X (math-div-float (math-make-float a 0)
X (math-make-float b 0))))))
X (and (Math-ratp a) (Math-ratp b)
X (if (eq (car-safe a) 'frac)
X (if (eq (car-safe b) 'frac)
X (math-make-frac (math-mul (nth 1 a) (nth 2 b))
X (math-mul (nth 2 a) (nth 1 b)))
X (math-make-frac (nth 1 a)
X (math-mul (nth 2 a) b)))
X (math-make-frac (math-mul a (nth 2 b))
X (nth 1 b))))
X (and (Math-realp a) (Math-realp b)
X (progn
X (or (and (consp a) (eq (car a) 'float))
X (setq a (math-float a)))
X (or (and (consp b) (eq (car b) 'float))
X (setq b (math-float b)))
X (math-div-float a b)))
X (and (calc-extensions)
X (math-div-objects-fancy a b))))
X (and (calc-extensions)
X (math-div-symb-fancy a b)))
X)
X(defun calcFunc-div (a &rest rest)
X (while rest
X (setq a (list '/ a (car rest))
X rest (cdr rest)))
X (math-normalize a)
X)
X
X(defun math-div-float (a b) ; [F F F]
X (let ((ldiff (max (- (1+ calc-internal-prec)
X (- (math-numdigs (nth 1 a)) (math-numdigs (nth 1 b))))
SHAR_EOF
echo "End of part 2"
echo "File calc.el is continued in part 3"
echo "3" > s2_seq_.tmp
exit 0