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

Text File | 1991-10-31 | 55.3 KB | 1,905 lines

Newsgroups: comp.sources.misc
From: [e-mail] (David Gillespie)
Subject:  v24i072:  gnucalc - GNU Emacs Calculator, v2.00, Part24/56
Message-ID: <[e-mail]>
X-Md4-Signature: 73e94080579af1b29e16619cb5083d9d
Date: Thu, 31 Oct 1991 07:27:39 GMT
Approved: [e-mail]

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

---- Cut Here and unpack ----
#!/bin/sh
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-prog.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 24; then
    echo Please unpack part "$Scheck" next!
    exit 1
 else
    exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
    echo 'x - still skipping calc-prog.el'
else
echo 'x - continuing file calc-prog.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-prog.el' &&
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            (progn
X              (and (calc-valid-formula-func func)
X               (setq defn (append '(calcFunc-lambda)
X                          (mapcar 'math-build-var-name
X                              (nth 1 (symbol-function
X                                  func)))
X                          (list defn))))
X              (calc-enter-result 0 "gdef" defn))
X          (error "That command is not defined by a formula")))))))
)
X
X
(defun calc-user-define-permanent ()
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           (and (eq key ?\')
X            (cons nil
X                  (intern (completing-read
X                       (format "Record in %s the function: "
X                           calc-settings-file)
X                       obarray 'fboundp nil "calcFunc-"))))
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     (let* ((cmd (cdr def))
X        (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
X        (func nil)
X        (pt (point))
X        (fill-column 70)
X        (fill-prefix nil)
X        str q-ok)
X       (insert "\n;;; Definition stored by Calc on " (current-time-string)
X           "\n(put 'calc-define '"
X           (if (symbolp cmd) (symbol-name cmd) (format "key%d" key))
X           " '(progn\n")
X       (if (and fcmd
X        (eq (car-safe fcmd) 'lambda)
X        (get cmd 'calc-user-defn))
X       (let ((pt (point)))
X         (and (eq (car-safe (nth 3 fcmd)) 'calc-execute-kbd-macro)
X          (vectorp (nth 1 (nth 3 fcmd)))
X          (progn (and (fboundp 'edit-kbd-macro)
X                  (edit-kbd-macro nil))
X             (fboundp 'MacEdit-parse-keys))
X          (setq q-ok t)
X          (aset (nth 1 (nth 3 fcmd)) 1 nil))
X         (insert (setq str (prin1-to-string
X                (cons 'defun (cons cmd (cdr fcmd)))))
X             "\n")
X         (or (and (string-match "\"" str) (not q-ok))
X         (fill-region pt (point)))
X         (indent-rigidly pt (point) 2)
X         (delete-region pt (1+ pt))
X         (insert " (put '" (symbol-name cmd)
X             " 'calc-user-defn '"
X             (prin1-to-string (get cmd 'calc-user-defn))
X             ")\n")
X         (setq func (calc-stack-command-p cmd))
X         (let ((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 (setq str (prin1-to-string
X                     (cons 'defun (cons func
X                                (cdr ffunc)))))
X                  "\n")
X              (or (and (string-match "\"" str) (not q-ok))
X              (fill-region pt (point)))
X              (indent-rigidly pt (point) 2)
X              (delete-region pt (1+ pt))
X              (setq pt (point))
X              (insert "(put '" (symbol-name func)
X                  " 'calc-user-defn '"
X                  (prin1-to-string (get func 'calc-user-defn))
X                  ")\n")
X              (fill-region pt (point))
X              (indent-rigidly pt (point) 2)
X              (delete-region pt (1+ pt))))))
X     (and (stringp fcmd)
X          (insert " (fset '" (prin1-to-string cmd)
X              " " (prin1-to-string fcmd) ")\n")))
X       (or func (setq func (and cmd (symbolp cmd) (fboundp cmd) cmd)))
X       (if (get func 'math-compose-forms)
X       (let ((pt (point)))
X         (insert "(put '" (symbol-name cmd)
X             " 'math-compose-forms '"
X             (prin1-to-string (get func 'math-compose-forms))
X             ")\n")
X         (fill-region pt (point))
X         (indent-rigidly pt (point) 2)
X         (delete-region pt (1+ pt))))
X       (if (car def)
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 "))\n")
X     (save-buffer)))
)
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
(defun calc-call-last-kbd-macro (arg)
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
(defun calc-execute-kbd-macro (mac arg &rest prefix)
X  (if (vectorp mac)
X      (setq mac (or (aref mac 1)
X            (aset mac 1 (progn (and (fboundp 'edit-kbd-macro)
X                        (edit-kbd-macro nil))
X                       (MacEdit-parse-keys (aref mac 0)))))))
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         (or (equal prefix '(nil))
X         (calc-record-list (if (> (length new-stack) 1)
X                       (mapcar 'car new-stack)
X                     '(""))
X                   (or (car prefix) "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             (insert (math-format-stack-value (car new-stack)) "\n")
X             (setq new-stack (cdr new-stack)))
X           (calc-renumber-stack))
X           (while new-stack
X         (calc-record-undo (list 'push 1))
X         (setq new-stack (cdr new-stack)))
X           (calc-refresh))
X         (calc-record-undo (list 'set 'saved-stack-top 0))))))))
)
X
(defun calc-push-list-in-macro (vals m sels)
X  (let ((entry (list (car vals) 1 (car sels)))
X    (mm (+ (or m 1) calc-stack-top)))
X    (if (> mm 1)
X    (setcdr (nthcdr (- mm 2) calc-stack)
X        (cons entry (nthcdr (1- mm) calc-stack)))
X      (setq calc-stack (cons entry calc-stack))))
)
X
(defun calc-pop-stack-in-macro (n mm)
X  (if (> mm 1)
X      (setcdr (nthcdr (- mm 2) calc-stack)
X          (nthcdr (+ n mm -1) calc-stack))
X    (setq calc-stack (nthcdr n calc-stack)))
)
X
X
(defun calc-kbd-if ()
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
(defun calc-kbd-else-if ()
X  (interactive)
X  (calc-kbd-if)
)
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
(defun calc-kbd-end-if ()
X  (interactive)
X  (if defining-kbd-macro
X      (message "End-if..."))
)
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
(defun calc-kbd-repeat ()
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
(defun calc-kbd-for (dir)
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
(defun calc-kbd-loop (rpt-count &optional initial final dir)
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
(defun calc-kbd-end-repeat ()
X  (interactive)
X  (error "Unbalanced Z> in keyboard macro")
)
X
(defun calc-kbd-end-for ()
X  (interactive)
X  (error "Unbalanced Z) in keyboard macro")
)
X
(defun calc-kbd-end-loop ()
X  (interactive)
X  (error "Unbalanced Z} in keyboard macro")
)
X
(defun calc-kbd-break ()
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
(defun calc-kbd-push (arg)
X  (interactive "P")
X  (calc-wrapper
X   (let* ((defs (and arg (> (prefix-numeric-value arg) 0)))
X      (var-q0 (and (boundp 'var-q0) var-q0))
X      (var-q1 (and (boundp 'var-q1) var-q1))
X      (var-q2 (and (boundp 'var-q2) var-q2))
X      (var-q3 (and (boundp 'var-q3) var-q3))
X      (var-q4 (and (boundp 'var-q4) var-q4))
X      (var-q5 (and (boundp 'var-q5) var-q5))
X      (var-q6 (and (boundp 'var-q6) var-q6))
X      (var-q7 (and (boundp 'var-q7) var-q7))
X      (var-q8 (and (boundp 'var-q8) var-q8))
X      (var-q9 (and (boundp 'var-q9) var-q9))
X      (calc-internal-prec (if defs 12 calc-internal-prec))
X      (calc-word-size (if defs 32 calc-word-size))
X      (calc-angle-mode (if defs 'deg calc-angle-mode))
X      (calc-simplify-mode (if defs nil calc-simplify-mode))
X      (calc-algebraic-mode (if arg nil calc-algebraic-mode))
X      (calc-incomplete-algebraic-mode (if arg nil
X                        calc-incomplete-algebraic-mode))
X      (calc-symbolic-mode (if defs nil calc-symbolic-mode))
X      (calc-matrix-mode (if defs nil calc-matrix-mode))
X      (calc-prefer-frac (if defs nil calc-prefer-frac))
X      (calc-complex-mode (if defs nil calc-complex-mode))
X      (calc-infinite-mode (if defs nil calc-infinite-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)))))
)
(setq calc-kbd-push-level 0)
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
(defun calc-kbd-report (msg)
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
(defun calc-kbd-query (msg)
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
;;;; Logical operations.
X
(defun calcFunc-eq (a b &rest more)
X  (if more
X      (let* ((args (cons a (cons b (copy-sequence more))))
X         (res 1)
X         (p args)
X         p2)
X    (while (and (cdr p) (not (eq res 0)))
X      (setq p2 p)
X      (while (and (setq p2 (cdr p2)) (not (eq res 0)))
X        (setq res (math-two-eq (car p) (car p2)))
X        (if (eq res 1)
X        (setcdr p (delq (car p2) (cdr p)))))
X      (setq p (cdr p)))
X    (if (eq res 0)
X        0
X      (if (cdr args)
X          (cons 'calcFunc-eq args)
X        1)))
X    (or (math-two-eq a b)
X    (if (and (or (math-looks-negp a) (math-zerop a))
X         (or (math-looks-negp b) (math-zerop b)))
X        (list 'calcFunc-eq (math-neg a) (math-neg b))
X      (list 'calcFunc-eq a b))))
)
X
(defun calcFunc-neq (a b &rest more)
X  (if more
X      (let* ((args (cons a (cons b more)))
X         (res 0)
X         (all t)
X         (p args)
X         p2)
X    (while (and (cdr p) (not (eq res 1)))
X      (setq p2 p)
X      (while (and (setq p2 (cdr p2)) (not (eq res 1)))
X        (setq res (math-two-eq (car p) (car p2)))
X        (or res (setq all nil)))
X      (setq p (cdr p)))
X    (if (eq res 1)
X        0
X      (if all
X          1
X        (cons 'calcFunc-neq args))))
X    (or (cdr (assq (math-two-eq a b) '((0 . 1) (1 . 0))))
X    (if (and (or (math-looks-negp a) (math-zerop a))
X         (or (math-looks-negp b) (math-zerop b)))
X        (list 'calcFunc-neq (math-neg a) (math-neg b))
X      (list 'calcFunc-neq a b))))
)
X
(defun math-two-eq (a b)
X  (if (eq (car-safe a) 'vec)
X      (if (eq (car-safe b) 'vec)
X      (if (= (length a) (length b))
X          (let ((res 1))
X        (while (and (setq a (cdr a) b (cdr b)) (not (eq res 0)))
X          (if res
X              (setq res (math-two-eq (car a) (car b)))
X            (if (eq (math-two-eq (car a) (car b)) 0)
X            (setq res 0))))
X        res)
X        0)
X    (if (Math-objectp b)
X        0
X      nil))
X    (if (eq (car-safe b) 'vec)
X    (if (Math-objectp a)
X        0
X      nil)
X      (let ((res (math-compare a b)))
X    (if (= res 0)
X        1
X      (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
X          nil
X        0)))))
)
X
(defun calcFunc-lt (a b)
X  (let ((res (math-compare a b)))
X    (if (= res -1)
X    1
X      (if (= res 2)
X      (if (and (or (math-looks-negp a) (math-zerop a))
X           (or (math-looks-negp b) (math-zerop b)))
X          (list 'calcFunc-gt (math-neg a) (math-neg b))
X        (list 'calcFunc-lt a b))
X    0)))
)
X
(defun calcFunc-gt (a b)
X  (let ((res (math-compare a b)))
X    (if (= res 1)
X    1
X      (if (= res 2)
X      (if (and (or (math-looks-negp a) (math-zerop a))
X           (or (math-looks-negp b) (math-zerop b)))
X          (list 'calcFunc-lt (math-neg a) (math-neg b))
X        (list 'calcFunc-gt a b))
X    0)))
)
X
(defun calcFunc-leq (a b)
X  (let ((res (math-compare a b)))
X    (if (= res 1)
X    0
X      (if (= res 2)
X      (if (and (or (math-looks-negp a) (math-zerop a))
X           (or (math-looks-negp b) (math-zerop b)))
X          (list 'calcFunc-geq (math-neg a) (math-neg b))
X        (list 'calcFunc-leq a b))
X    1)))
)
X
(defun calcFunc-geq (a b)
X  (let ((res (math-compare a b)))
X    (if (= res -1)
X    0
X      (if (= res 2)
X      (if (and (or (math-looks-negp a) (math-zerop a))
X           (or (math-looks-negp b) (math-zerop b)))
X          (list 'calcFunc-leq (math-neg a) (math-neg b))
X        (list 'calcFunc-geq a b))
X    1)))
)
X
(defun calcFunc-rmeq (a)
X  (if (math-vectorp a)
X      (math-map-vec 'calcFunc-rmeq a)
X    (if (assq (car-safe a) calc-tweak-eqn-table)
X    (if (and (eq (car-safe (nth 2 a)) 'var)
X         (math-objectp (nth 1 a)))
X        (nth 1 a)
X      (nth 2 a))
X      (if (eq (car-safe a) 'calcFunc-assign)
X      (nth 2 a)
X    (if (eq (car-safe a) 'calcFunc-evalto)
X        (nth 1 a)
X      (list 'calcFunc-rmeq a)))))
)
X
(defun calcFunc-land (a b)
X  (cond ((Math-zerop a)
X     a)
X    ((Math-zerop b)
X     b)
X    ((math-is-true a)
X     b)
X    ((math-is-true b)
X     a)
X    (t (list 'calcFunc-land a b)))
)
X
(defun calcFunc-lor (a b)
X  (cond ((Math-zerop a)
X     b)
X    ((Math-zerop b)
X     a)
X    ((math-is-true a)
X     a)
X    ((math-is-true b)
X     b)
X    (t (list 'calcFunc-lor a b)))
)
X
(defun calcFunc-lnot (a)
X  (if (Math-zerop a)
X      1
X    (if (math-is-true a)
X    0
X      (let ((op (and (= (length a) 3)
X             (assq (car a) calc-tweak-eqn-table))))
X    (if op
X        (cons (nth 2 op) (cdr a))
X      (list 'calcFunc-lnot a)))))
)
X
(defun calcFunc-if (c e1 e2)
X  (if (Math-zerop c)
X      e2
X    (if (and (math-is-true c) (not (Math-vectorp c)))
X    e1
X      (or (and (Math-vectorp c)
X           (math-constp c)
X           (let ((ee1 (if (Math-vectorp e1)
X                  (if (= (length c) (length e1))
X                  (cdr e1)
X                (calc-record-why "*Dimension error" e1))
X                (list e1)))
X             (ee2 (if (Math-vectorp e2)
X                  (if (= (length c) (length e2))
X                  (cdr e2)
X                (calc-record-why "*Dimension error" e2))
X                (list e2))))
X         (and ee1 ee2
X              (cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
X      (list 'calcFunc-if c e1 e2))))
)
X
(defun math-if-vector (c e1 e2)
X  (and c
X       (cons (if (Math-zerop (car c)) (car e2) (car e1))
X         (math-if-vector (cdr c)
X                 (or (cdr e1) e1)
X                 (or (cdr e2) e2))))
)
X
(defun math-normalize-logical-op (a)
X  (or (and (eq (car a) 'calcFunc-if)
X       (= (length a) 4)
X       (let ((a1 (math-normalize (nth 1 a))))
X         (if (Math-zerop a1)
X         (math-normalize (nth 3 a))
X           (if (Math-numberp a1)
X           (math-normalize (nth 2 a))
X         (if (and (Math-vectorp (nth 1 a))
X              (math-constp (nth 1 a)))
X             (calcFunc-if (nth 1 a)
X                  (math-normalize (nth 2 a))
X                  (math-normalize (nth 3 a)))
X           (let ((calc-simplify-mode 'none))
X             (list 'calcFunc-if a1
X               (math-normalize (nth 2 a))
X               (math-normalize (nth 3 a)))))))))
X      a)
)
X
(defun calcFunc-in (a b)
X  (or (and (eq (car-safe b) 'vec)
X       (let ((bb b))
X         (while (and (setq bb (cdr bb))
X             (not (if (memq (car-safe (car bb)) '(vec intv))
X                  (eq (calcFunc-in a (car bb)) 1)
X                (Math-equal a (car bb))))))
X         (if bb 1 (and (math-constp a) (math-constp bb) 0))))
X      (and (eq (car-safe b) 'intv)
X       (let ((res (math-compare a (nth 2 b))) res2)
X         (cond ((= res -1)
X            0)
X           ((and (= res 0)
X             (or (/= (nth 1 b) 2)
X                 (Math-lessp (nth 2 b) (nth 3 b))))
X            (if (memq (nth 1 b) '(2 3)) 1 0))
X           ((= (setq res2 (math-compare a (nth 3 b))) 1)
X            0)
X           ((and (= res2 0)
X             (or (/= (nth 1 b) 1)
X                 (Math-lessp (nth 2 b) (nth 3 b))))
X            (if (memq (nth 1 b) '(1 3)) 1 0))
X           ((/= res 1)
X            nil)
X           ((/= res2 -1)
X            nil)
X           (t 1))))
X      (and (Math-equal a b)
X       1)
X      (and (math-constp a) (math-constp b)
X       0)
X      (list 'calcFunc-in a b))
)
X
(defun calcFunc-typeof (a)
X  (cond ((Math-integerp a) 1)
X    ((eq (car a) 'frac) 2)
X    ((eq (car a) 'float) 3)
X    ((eq (car a) 'hms) 4)
X    ((eq (car a) 'cplx) 5)
X    ((eq (car a) 'polar) 6)
X    ((eq (car a) 'sdev) 7)
X    ((eq (car a) 'intv) 8)
X    ((eq (car a) 'mod) 9)
X    ((eq (car a) 'date) (if (Math-integerp (nth 1 a)) 10 11))
X    ((eq (car a) 'var)
X     (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
X    ((eq (car a) 'vec) (if (math-matrixp a) 102 101))
X    (t (math-calcFunc-to-var func)))
)
X
(defun calcFunc-integer (a)
X  (if (Math-integerp a)
X      1
X    (if (Math-objvecp a)
X    0
X      (list 'calcFunc-integer a)))
)
X
(defun calcFunc-real (a)
X  (if (Math-realp a)
X      1
X    (if (Math-objvecp a)
X    0
X      (list 'calcFunc-real a)))
)
X
(defun calcFunc-constant (a)
X  (if (math-constp a)
X      1
X    (if (Math-objvecp a)
X    0
X      (list 'calcFunc-constant a)))
)
X
(defun calcFunc-refers (a b)
X  (if (math-expr-contains a b)
X      1
X    (if (eq (car-safe a) 'var)
X    (list 'calcFunc-refers a b)
X      0))
)
X
(defun calcFunc-negative (a)
X  (if (math-looks-negp a)
X      1
X    (if (or (math-zerop a)
X        (math-posp a))
X    0
X      (list 'calcFunc-negative a)))
)
X
(defun calcFunc-variable (a)
X  (if (eq (car-safe a) 'var)
X      1
X    (if (Math-objvecp a)
X    0
X      (list 'calcFunc-variable a)))
)
X
(defun calcFunc-nonvar (a)
X  (if (eq (car-safe a) 'var)
X      (list 'calcFunc-nonvar a)
X    1)
)
X
(defun calcFunc-istrue (a)
X  (if (math-is-true a)
X      1
X    0)
)
X
X
X
X
;;;; User-programmability.
X
;;; Compiling Lisp-like forms to use the math library.
X
(defun math-do-defmath (func args body)
X  (calc-need-macros)
X  (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
X     (doc (if (stringp (car body)) (list (car body))))
X     (clargs (mapcar 'math-clean-arg args))
X     (body (math-define-function-body
X        (if (stringp (car body)) (cdr body) body)
X        clargs)))
X    (list 'progn
X      (if (and (consp (car body))
X           (eq (car (car body)) 'interactive))
X          (let ((inter (car body)))
X        (setq body (cdr body))
X        (if (or (> (length inter) 2)
X            (integerp (nth 1 inter)))
X            (let ((hasprefix nil) (hasmulti nil))
X              (if (stringp (nth 1 inter))
X              (progn
X                (cond ((equal (nth 1 inter) "p")
X                   (setq hasprefix t))
X                  ((equal (nth 1 inter) "m")
X                   (setq hasmulti t))
X                  (t (error
X                      "Can't handle interactive code string \"%s\""
X                      (nth 1 inter))))
X                (setq inter (cdr inter))))
X              (if (not (integerp (nth 1 inter)))
X              (error
X               "Expected an integer in interactive specification"))
X              (append (list 'defun
X                    (intern (concat "calc-"
X                            (symbol-name func)))
X                    (if (or hasprefix hasmulti)
X                    '(&optional n)
X                      ()))
X                  doc
X                  (if (or hasprefix hasmulti)
X                  '((interactive "P"))
X                '((interactive)))
X                  (list
X                   (append
X                '(calc-slow-wrapper)
X                (and hasmulti
X                     (list
X                      (list 'setq
X                        'n
X                        (list 'if
X                          'n
X                          (list 'prefix-numeric-value
X                            'n)
X                          (nth 1 inter)))))
X                (list
X                 (list 'calc-enter-result
X                       (if hasmulti 'n (nth 1 inter))
X                       (nth 2 inter)
X                       (if hasprefix
X                       (list 'append
X                         (list 'quote (list fname))
X                         (list 'calc-top-list-n
X                               (nth 1 inter))
X                         (list 'and
X                               'n
X                               (list
X                            'list
X                            (list
X                             'math-normalize
X                             (list
X                              'prefix-numeric-value
X                              'n)))))
X                     (list 'cons
X                           (list 'quote fname)
X                           (list 'calc-top-list-n
X                             (if hasmulti
X                             'n
X                               (nth 1 inter)))))))))))
X          (append (list 'defun
X                (intern (concat "calc-" (symbol-name func)))
X                args)
X              doc
X              (list
X               inter
X               (cons 'calc-wrapper body))))))
X      (append (list 'defun fname clargs)
X          doc
X          (math-do-arg-list-check args nil nil)
X          body)))
)
X
(defun math-clean-arg (arg)
X  (if (consp arg)
X      (math-clean-arg (nth 1 arg))
X    arg)
)
X
(defun math-do-arg-check (arg var is-opt is-rest)
X  (if is-opt
X      (let ((chk (math-do-arg-check arg var nil nil)))
X    (list (cons 'and
X            (cons var
X              (if (cdr chk)
X                  (setq chk (list (cons 'progn chk)))
X                chk)))))
X    (and (consp arg)
X     (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
X        (qual (car arg))
X        (qqual (list 'quote qual))
X        (qual-name (symbol-name qual))
X        (chk (intern (concat "math-check-" qual-name))))
X       (if (fboundp chk)
X           (append rest
X               (list
X            (if is-rest
X                (list 'setq var
X                  (list 'mapcar (list 'quote chk) var))
X              (list 'setq var (list chk var)))))
X         (if (fboundp (setq chk (intern (concat "math-" qual-name))))
X         (append rest
X             (list
X              (if is-rest
X                  (list 'mapcar
X                    (list 'function
X                      (list 'lambda '(x)
X                        (list 'or
X                              (list chk 'x)
X                              (list 'math-reject-arg
X                                'x qqual))))
X                    var)
X                (list 'or
X                  (list chk var)
X                  (list 'math-reject-arg var qqual)))))
X           (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
X            (fboundp (setq chk (intern
X                        (concat "math-"
X                            (math-match-substring
X                             qual-name 1))))))
X           (append rest
X               (list
X                (if is-rest
X                (list 'mapcar
X                      (list 'function
X                        (list 'lambda '(x)
X                          (list 'and
X                            (list chk 'x)
X                            (list 'math-reject-arg
X                                  'x qqual))))
X                      var)
X                  (list 'and
X                    (list chk var)
X                    (list 'math-reject-arg var qqual)))))
X         (error "Unknown qualifier `%s'" qual-name)))))))
)
X
(defun math-do-arg-list-check (args is-opt is-rest)
X  (cond ((null args) nil)
X    ((consp (car args))
X     (append (math-do-arg-check (car args)
X                    (math-clean-arg (car args))
X                    is-opt is-rest)
X         (math-do-arg-list-check (cdr args) is-opt is-rest)))
X    ((eq (car args) '&optional)
X     (math-do-arg-list-check (cdr args) t nil))
X    ((eq (car args) '&rest)
X     (math-do-arg-list-check (cdr args) nil t))
X    (t (math-do-arg-list-check (cdr args) is-opt is-rest)))
)
X
(defconst math-prim-funcs
X  '( (~= . math-nearly-equal)
X     (% . math-mod)
X     (lsh . calcFunc-lsh)
X     (ash . calcFunc-ash)
X     (logand . calcFunc-and)
X     (logandc2 . calcFunc-diff)
X     (logior . calcFunc-or)
X     (logxor . calcFunc-xor)
X     (lognot . calcFunc-not)
X     (equal . equal)   ; need to leave these ones alone!
X     (eq . eq)
X     (and . and)
X     (or . or)
X     (if . if)
X     (^ . math-pow)
X     (expt . math-pow)
X   )
)
X
(defconst math-prim-vars
X  '( (nil . nil)
X     (t . t)
X     (&optional . &optional)
X     (&rest . &rest)
X   )
)
X
(defun math-define-function-body (body env)
X  (let ((body (math-define-body body env)))
X    (if (math-body-refers-to body 'math-return)
X    (list (cons 'catch (cons '(quote math-return) body)))
X      body))
)
X
(defun math-define-body (body exp-env)
X  (math-define-list body)
)
X
(defun math-define-list (body &optional quote)
X  (cond ((null body)
X     nil)
X    ((and (eq (car body) ':)
X          (stringp (nth 1 body)))
X     (cons (let* ((math-read-expr-quotes t)
X              (exp (math-read-plain-expr (nth 1 body) t)))
X         (math-define-exp exp))
X           (math-define-list (cdr (cdr body)))))
X    (quote
X     (cons (cond ((consp (car body))
X              (math-define-list (cdr body) t))
X             (t
X              (car body)))
X           (math-define-list (cdr body))))
X    (t
X     (cons (math-define-exp (car body))
X           (math-define-list (cdr body)))))
)
X
(defun math-define-exp (exp)
X  (cond ((consp exp)
X     (let ((func (car exp)))
X       (cond ((memq func '(quote function))
X          (if (and (consp (nth 1 exp))
X               (eq (car (nth 1 exp)) 'lambda))
X              (cons 'quote
X                (math-define-lambda (nth 1 exp) exp-env))
X            exp))
X         ((memq func '(let let* for foreach))
X          (let ((head (nth 1 exp))
X            (body (cdr (cdr exp))))
X            (if (memq func '(let let*))
X            ()
X              (setq func (cdr (assq func '((for . math-for)
X                           (foreach . math-foreach)))))
X              (if (not (listp (car head)))
X              (setq head (list head))))
X            (macroexpand
X             (cons func
X               (cons (math-define-let head)
X                 (math-define-body body
X                           (nconc
X                            (math-define-let-env head)
X                            exp-env)))))))
X         ((and (memq func '(setq setf))
X               (math-complicated-lhs (cdr exp)))
X          (if (> (length exp) 3)
X              (cons 'progn (math-define-setf-list (cdr exp)))
X            (math-define-setf (nth 1 exp) (nth 2 exp))))
X         ((eq func 'condition-case)
X          (cons func
X            (cons (nth 1 exp)
X                  (math-define-body (cdr (cdr exp))
X                        (cons (nth 1 exp)
X                              exp-env)))))
X         ((eq func 'cond)
X          (cons func
X            (math-define-cond (cdr exp))))
X         ((and (consp func)   ; ('spam a b) == force use of plain spam
X               (eq (car func) 'quote))
X          (cons func (math-define-list (cdr exp))))
X         ((symbolp func)
X          (let ((args (math-define-list (cdr exp)))
X            (prim (assq func math-prim-funcs)))
X            (cond (prim
X               (cons (cdr prim) args))
X              ((eq func 'floatp)
X               (list 'eq (car args) '(quote float)))
X              ((eq func '+)
X               (math-define-binop 'math-add 0
X                          (car args) (cdr args)))
X              ((eq func '-)
X               (if (= (length args) 1)
X                   (cons 'math-neg args)
X                 (math-define-binop 'math-sub 0
X                        (car args) (cdr args))))
X              ((eq func '*)
X               (math-define-binop 'math-mul 1
X                          (car args) (cdr args)))
X              ((eq func '/)
X               (math-define-binop 'math-div 1
X                          (car args) (cdr args)))
X              ((eq func 'min)
X               (math-define-binop 'math-min 0
X                          (car args) (cdr args)))
X              ((eq func 'max)
X               (math-define-binop 'math-max 0
X                          (car args) (cdr args)))
X              ((eq func '<)
X               (if (and (math-numberp (nth 1 args))
X                    (math-zerop (nth 1 args)))
X                   (list 'math-negp (car args))
X                 (cons 'math-lessp args)))
X              ((eq func '>)
X               (if (and (math-numberp (nth 1 args))
X                    (math-zerop (nth 1 args)))
X                   (list 'math-posp (car args))
X                 (list 'math-lessp (nth 1 args) (nth 0 args))))
X              ((eq func '<=)
X               (list 'not
X                 (if (and (math-numberp (nth 1 args))
X                      (math-zerop (nth 1 args)))
X                     (list 'math-posp (car args))
X                   (cons 'math-lessp args))))
X              ((eq func '>=)
X               (list 'not
X                 (if (and (math-numberp (nth 1 args))
X                      (math-zerop (nth 1 args)))
X                     (list 'math-negp (car args))
X                   (list 'math-lessp
X                     (nth 1 args) (nth 0 args)))))
X              ((eq func '=)
X               (if (and (math-numberp (nth 1 args))
X                    (math-zerop (nth 1 args)))
X                   (list 'math-zerop (nth 0 args))
X                 (if (and (integerp (nth 1 args))
X                      (/= (% (nth 1 args) 10) 0))
X                 (cons 'math-equal-int args)
X                   (cons 'math-equal args))))
X              ((eq func '/=)
X               (list 'not
X                 (if (and (math-numberp (nth 1 args))
X                      (math-zerop (nth 1 args)))
X                     (list 'math-zerop (nth 0 args))
X                   (if (and (integerp (nth 1 args))
X                        (/= (% (nth 1 args) 10) 0))
X                       (cons 'math-equal-int args)
X                     (cons 'math-equal args)))))
X              ((eq func '1+)
X               (list 'math-add (car args) 1))
X              ((eq func '1-)
X               (list 'math-add (car args) -1))
X              ((eq func 'not)   ; optimize (not (not x)) => x
X               (if (eq (car-safe args) func)
X                   (car (nth 1 args))
X                 (cons func args)))
X              ((and (eq func 'elt) (cdr (cdr args)))
X               (math-define-elt (car args) (cdr args)))
X              (t
X               (macroexpand
X                (let* ((name (symbol-name func))
X                   (cfunc (intern (concat "calcFunc-" name)))
X                   (mfunc (intern (concat "math-" name))))
X                  (cond ((fboundp cfunc)
X                     (cons cfunc args))
X                    ((fboundp mfunc)
X                     (cons mfunc args))
X                    ((or (fboundp func)
X                     (string-match "\\`calcFunc-.*" name))
X                     (cons func args))
X                    (t
X                     (cons cfunc args)))))))))
X         (t (cons func args)))))
X    ((symbolp exp)
X     (let ((prim (assq exp math-prim-vars))
X           (name (symbol-name exp)))
X       (cond (prim
X          (cdr prim))
X         ((memq exp exp-env)
X          exp)
X         ((string-match "-" name)
X          exp)
X         (t
X          (intern (concat "var-" name))))))
X    ((integerp exp)
X     (if (or (<= exp -1000000) (>= exp 1000000))
X         (list 'quote (math-normalize exp))
X       exp))
X    (t exp))
)
X
(defun math-define-cond (forms)
X  (and forms
X       (cons (math-define-list (car forms))
X         (math-define-cond (cdr forms))))
)
X
(defun math-complicated-lhs (body)
X  (and body
X       (or (not (symbolp (car body)))
X       (math-complicated-lhs (cdr (cdr body)))))
)
X
(defun math-define-setf-list (body)
X  (and body
X       (cons (math-define-setf (nth 0 body) (nth 1 body))
X         (math-define-setf-list (cdr (cdr body)))))
)
X
(defun math-define-setf (place value)
X  (setq place (math-define-exp place)
X    value (math-define-exp value))
X  (cond ((symbolp place)
X     (list 'setq place value))
X    ((eq (car-safe place) 'nth)
X     (list 'setcar (list 'nthcdr (nth 1 place) (nth 2 place)) value))
X    ((eq (car-safe place) 'elt)
X     (list 'setcar (list 'nthcdr (nth 2 place) (nth 1 place)) value))
X    ((eq (car-safe place) 'car)
X     (list 'setcar (nth 1 place) value))
X    ((eq (car-safe place) 'cdr)
X     (list 'setcdr (nth 1 place) value))
X    (t
X     (error "Bad place form for setf: %s" place)))
)
X
(defun math-define-binop (op ident arg1 rest)
X  (if rest
X      (math-define-binop op ident
X             (list op arg1 (car rest))
X             (cdr rest))
X    (or arg1 ident))
)
X
(defun math-define-let (vlist)
X  (and vlist
X       (cons (if (consp (car vlist))
X         (cons (car (car vlist))
X               (math-define-list (cdr (car vlist))))
X           (car vlist))
X         (math-define-let (cdr vlist))))
)
X
(defun math-define-let-env (vlist)
X  (and vlist
X       (cons (if (consp (car vlist))
X         (car (car vlist))
X           (car vlist))
X         (math-define-let-env (cdr vlist))))
)
X
(defun math-define-lambda (exp exp-env)
X  (nconc (list (nth 0 exp)   ; 'lambda
X           (nth 1 exp))  ; arg list
X     (math-define-function-body (cdr (cdr exp))
X                    (append (nth 1 exp) exp-env)))
)
X
(defun math-define-elt (seq idx)
X  (if idx
X      (math-define-elt (list 'elt seq (car idx)) (cdr idx))
X    seq)
)
X
X
X
;;; Useful programming macros.
X
(defmacro math-while (head &rest body)
X  (let ((body (cons 'while (cons head body))))
X    (if (math-body-refers-to body 'math-break)
X    (cons 'catch (cons '(quote math-break) (list body)))
X      body))
)
X
X
(defmacro math-for (head &rest body)
X  (let ((body (if head
X          (math-handle-for head body)
X        (cons 'while (cons t body)))))
X    (if (math-body-refers-to body 'math-break)
X    (cons 'catch (cons '(quote math-break) (list body)))
X      body))
)
X
(defun math-handle-for (head body)
X  (let* ((var (nth 0 (car head)))
X     (init (nth 1 (car head)))
X     (limit (nth 2 (car head)))
X     (step (or (nth 3 (car head)) 1))
X     (body (if (cdr head)
X           (list (math-handle-for (cdr head) body))
X         body))
X     (all-ints (and (integerp init) (integerp limit) (integerp step)))
X     (const-limit (or (integerp limit)
X              (and (eq (car-safe limit) 'quote)
X                   (math-realp (nth 1 limit)))))
X     (const-step (or (integerp step)
X             (and (eq (car-safe step) 'quote)
X                  (math-realp (nth 1 step)))))
X     (save-limit (if const-limit limit (make-symbol "<limit>")))
X     (save-step (if const-step step (make-symbol "<step>"))))
X    (cons 'let
X      (cons (append (if const-limit nil (list (list save-limit limit)))
X            (if const-step nil (list (list save-step step)))
X            (list (list var init)))
X        (list
X         (cons 'while
X               (cons (if all-ints
X                 (if (> step 0)
X                     (list '<= var save-limit)
X                   (list '>= var save-limit))
X                   (list 'not
X                     (if const-step
X                     (if (or (math-posp step)
X                         (math-posp
X                          (cdr-safe step)))
X                         (list 'math-lessp
X                           save-limit
X                           var)
X                       (list 'math-lessp
X                         var
X                         save-limit))
X                       (list 'if
X                         (list 'math-posp
X                           save-step)
X                         (list 'math-lessp
X                           save-limit
X                           var)
X                         (list 'math-lessp
X                           var
X                           save-limit)))))
X                 (append body
X                     (list (list 'setq
X                         var
X                         (list (if all-ints
X                               '+
X                             'math-add)
X                               var
X                               save-step))))))))))
)
X
X
(defmacro math-foreach (head &rest body)
X  (let ((body (math-handle-foreach head body)))
X    (if (math-body-refers-to body 'math-break)
X    (cons 'catch (cons '(quote math-break) (list body)))
X      body))
)
X
X
(defun math-handle-foreach (head body)
X  (let ((var (nth 0 (car head)))
X    (data (nth 1 (car head)))
X    (body (if (cdr head)
X          (list (math-handle-foreach (cdr head) body))
X        body)))
X    (cons 'let
X      (cons (list (list var data))
X        (list
X         (cons 'while
X               (cons var
X                 (append body
X                     (list (list 'setq
X                         var
X                         (list 'cdr var))))))))))
)
X
X
(defun math-body-refers-to (body thing)
X  (or (equal body thing)
X      (and (consp body)
X       (or (math-body-refers-to (car body) thing)
X           (math-body-refers-to (cdr body) thing))))
)
X
(defun math-break (&optional value)
X  (throw 'math-break value)
)
X
(defun math-return (&optional value)
X  (throw 'math-return value)
)
X
X
X
X
X
(defun math-composite-inequalities (x op)
X  (if (memq (nth 1 op) '(calcFunc-eq calcFunc-neq))
X      (if (eq (car x) (nth 1 op))
X      (append x (list (math-read-expr-level (nth 3 op))))
X    (throw 'syntax "Syntax error"))
X    (list 'calcFunc-in
X      (nth 2 x)
X      (if (memq (nth 1 op) '(calcFunc-lt calcFunc-leq))
X          (if (memq (car x) '(calcFunc-lt calcFunc-leq))
X          (math-make-intv
X           (+ (if (eq (car x) 'calcFunc-leq) 2 0)
X              (if (eq (nth 1 op) 'calcFunc-leq) 1 0))
X           (nth 1 x) (math-read-expr-level (nth 3 op)))
X        (throw 'syntax "Syntax error"))
X        (if (memq (car x) '(calcFunc-gt calcFunc-geq))
X        (math-make-intv
X         (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
X            (if (eq (car x) 'calcFunc-geq) 1 0))
X         (math-read-expr-level (nth 3 op)) (nth 1 x))
X          (throw 'syntax "Syntax error")))))
)
X
SHAR_EOF
echo 'File calc-prog.el is complete' &&
chmod 0644 calc-prog.el ||
echo 'restore of calc-prog.el failed'
Wc_c="`wc -c < 'calc-prog.el'`"
test 60998 -eq "$Wc_c" ||
    echo 'calc-prog.el: original size 60998, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-rewr.el ==============
if test -f 'calc-rewr.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-rewr.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-rewr.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-rewr.el' &&
;; Calculator for GNU Emacs, part II [calc-rewr.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-rewr () nil)
X
X
(defun calc-rewrite-selection (rules-str &optional many prefix)
X  (interactive "sRewrite rule(s): \np")
X  (calc-slow-wrapper
X   (calc-preserve-point)
X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
X      (reselect t)
X      (pop-rules nil)
X      (entry (calc-top num 'entry))
X      (expr (car entry))
X      (sel (calc-auto-selection entry))
X      (math-rewrite-selections t)
X      (math-rewrite-default-iters 1))
X     (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
X     (if (= num 1)
X         (error "Can't use same stack entry for formula and rules.")
X       (setq rules (calc-top-n 1 t)
X         pop-rules t))
X       (setq rules (if (stringp rules-str)
X               (math-read-exprs rules-str) rules-str))
X       (if (eq (car-safe rules) 'error)
X       (error "Bad format in expression: %s" (nth 1 rules)))
X       (if (= (length rules) 1)
X       (setq rules (car rules))
X     (setq rules (cons 'vec rules)))
X       (or (memq (car-safe rules) '(vec var calcFunc-assign
X                    calcFunc-condition))
X       (let ((rhs (math-read-expr
X               (read-string (concat "Rewrite from:    " rules-str
X                        "  to: ")))))
X         (if (eq (car-safe rhs) 'error)
X         (error "Bad format in expression: %s" (nth 1 rhs)))
X         (setq rules (list 'calcFunc-assign rules rhs))))
X       (or (eq (car-safe rules) 'var)
X       (calc-record rules "rule")))
X     (if (eq many 0)
X     (setq many '(var inf var-inf))
X       (if many (setq many (prefix-numeric-value many))))
X     (if sel
X     (setq expr (calc-replace-sub-formula (car entry)
X                          sel
X                          (list 'calcFunc-select sel)))
X       (setq expr (car entry)
X         reselect nil
X         math-rewrite-selections nil))
X     (setq expr (calc-encase-atoms
X         (calc-normalize
X          (math-rewrite
X           (calc-normalize expr)
X           rules many)))
X       sel nil
X       expr (calc-locate-select-marker expr))
X     (or (consp sel) (setq sel nil))
X     (if pop-rules (calc-pop-stack 1))
X     (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
X                (- num (if pop-rules 1 0))
X                (list (and reselect sel))))
X   (calc-handle-whys))
)
X
(defun calc-locate-select-marker (expr)    ; changes "sel"
X  (if (Math-primp expr)
X      expr
X    (if (and (eq (car expr) 'calcFunc-select)
X         (= (length expr) 2))
X    (progn
X      (setq sel (if sel t (nth 1 expr)))
X      (nth 1 expr))
X      (cons (car expr)
X        (mapcar 'calc-locate-select-marker (cdr expr)))))
)
X
X
X
(defun calc-rewrite (rules-str many)
X  (interactive "sRewrite rule(s): \nP")
X  (calc-slow-wrapper
X   (let (n rules expr)
X     (if (or (null rules-str) (equal rules-str "") (equal rules-str "$"))
X     (setq expr (calc-top-n 2)
X           rules (calc-top-n 1 t)
X           n 2)
X       (setq rules (if (stringp rules-str)
X               (math-read-exprs rules-str) rules-str))
X       (if (eq (car-safe rules) 'error)
X       (error "Bad format in expression: %s" (nth 1 rules)))
X       (if (= (length rules) 1)
X       (setq rules (car rules))
X     (setq rules (cons 'vec rules)))
X       (or (memq (car-safe rules) '(vec var calcFunc-assign
X                    calcFunc-condition))
X       (let ((rhs (math-read-expr
X               (read-string (concat "Rewrite from:    " rules-str
X                        " to: ")))))
X         (if (eq (car-safe rhs) 'error)
X         (error "Bad format in expression: %s" (nth 1 rhs)))
X         (setq rules (list 'calcFunc-assign rules rhs))))
X       (or (eq (car-safe rules) 'var)
X       (calc-record rules "rule"))
X       (setq expr (calc-top-n 1)
X         n 1))
X     (if (eq many 0)
X     (setq many '(var inf var-inf))
X       (if many (setq many (prefix-numeric-value many))))
X     (setq expr (calc-normalize (math-rewrite expr rules many)))
X     (let (sel)
X       (setq expr (calc-locate-select-marker expr)))
X     (calc-pop-push-record-list n "rwrt" (list expr)))
X   (calc-handle-whys))
)
X
(defun calc-match (pat)
X  (interactive "sPattern: \n")
X  (calc-slow-wrapper
X   (let (n expr)
X     (if (or (null pat) (equal pat "") (equal pat "$"))
X     (setq expr (calc-top-n 2)
X           pat (calc-top-n 1)
X           n 2)
X       (if (interactive-p) (setq calc-previous-alg-entry pat))
X       (setq pat (if (stringp pat) (math-read-expr pat) pat))
X       (if (eq (car-safe pat) 'error)
X       (error "Bad format in expression: %s" (nth 1 pat)))
X       (if (not (eq (car-safe pat) 'var))
X       (calc-record pat "pat"))
X       (setq expr (calc-top-n 1)
X         n 1))
X     (or (math-vectorp expr) (error "Argument must be a vector"))
X     (if (calc-is-inverse)
X     (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
X       (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))
)
X
X
X
(defun math-rewrite (whole-expr rules &optional mmt-many)
X  (let ((crules (math-compile-rewrites rules))
X    (heads (math-rewrite-heads whole-expr))
X    (trace-buffer (get-buffer "*Trace*"))
X    (calc-display-just 'center)
X    (calc-display-origin 39)
X    (calc-line-breaking 78)
X    (calc-line-numbering nil)
X    (calc-show-selections t)
X    (calc-why nil)
X    (mmt-func (function
X           (lambda (x)
X             (let ((result (math-apply-rewrites x (cdr crules)
X                            heads crules)))
X               (if result
X               (progn
X                 (if trace-buffer
X                 (let ((fmt (math-format-stack-value
X                         (list result nil nil))))
X                   (save-excursion
X                     (set-buffer trace-buffer)
X                     (insert "\nrewrite to\n" fmt "\n"))))
X                 (setq heads (math-rewrite-heads result heads t))))
X               result)))))
X    (if trace-buffer
X    (let ((fmt (math-format-stack-value (list whole-expr nil nil))))
X      (save-excursion
X        (set-buffer trace-buffer)
X        (setq truncate-lines t)
X        (goto-char (point-max))
X        (insert "\n\nBegin rewriting\n" fmt "\n"))))
X    (or mmt-many (setq mmt-many (or (nth 1 (car crules))
X                    math-rewrite-default-iters)))
X    (if (equal mmt-many '(var inf var-inf)) (setq mmt-many 1000000))
X    (if (equal mmt-many '(neg (var inf var-inf))) (setq mmt-many -1000000))
X    (math-rewrite-phase (nth 3 (car crules)))
X    (if trace-buffer
X    (let ((fmt (math-format-stack-value (list whole-expr nil nil))))
X      (save-excursion
X        (set-buffer trace-buffer)
X        (insert "\nDone rewriting"
X            (if (= mmt-many 0) " (reached iteration limit)" "")
X            ":\n" fmt "\n"))))
X    whole-expr)
)
(setq math-rewrite-default-iters 100)
X
(defun math-rewrite-phase (sched)
X  (while (and sched (/= mmt-many 0))
X    (if (listp (car sched))
X    (while (let ((save-expr whole-expr))
X         (math-rewrite-phase (car sched))
X         (not (equal whole-expr save-expr))))
X      (if (symbolp (car sched))
X      (progn
X        (setq whole-expr (math-normalize (list (car sched) whole-expr)))
X        (if trace-buffer
X        (let ((fmt (math-format-stack-value
X                (list whole-expr nil nil))))
X          (save-excursion
X            (set-buffer trace-buffer)
X            (insert "\ncall "
X                (substring (symbol-name (car sched)) 9)
X                ":\n" fmt "\n")))))
X    (let ((math-rewrite-phase (car sched)))
X      (if trace-buffer
X          (save-excursion
X        (set-buffer trace-buffer)
X        (insert (format "\n(Phase %d)\n" math-rewrite-phase))))
X      (while (let ((save-expr whole-expr))
X           (setq whole-expr (math-normalize
X                     (math-map-tree-rec whole-expr)))
X           (not (equal whole-expr save-expr)))))))
X    (setq sched (cdr sched)))
)
X
(defun calcFunc-rewrite (expr rules &optional many)
X  (or (null many) (integerp many)
X      (equal many '(var inf var-inf)) (equal many '(neg (var inf var-inf)))
X      (math-reject-arg many 'fixnump))
X  (condition-case err
X      (math-rewrite expr rules (or many 1))
X    (error (math-reject-arg rules (nth 1 err))))
)
X
(defun calcFunc-match (pat vec)
X  (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
X  (condition-case err
X      (math-match-patterns pat vec nil)
X    (error (math-reject-arg pat (nth 1 err))))
)
X
(defun calcFunc-matchnot (pat vec)
X  (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
X  (condition-case err
X      (math-match-patterns pat vec t)
X    (error (math-reject-arg pat (nth 1 err))))
)
X
(defun math-match-patterns (pat vec &optional not-flag)
X  (let ((newvec nil)
X    (crules (math-compile-patterns pat)))
X    (while (setq vec (cdr vec))
X      (if (eq (not (math-apply-rewrites (car vec) crules))
X          not-flag)
X      (setq newvec (cons (car vec) newvec))))
X    (cons 'vec (nreverse newvec)))
)
X
(defun calcFunc-matches (expr pat)
X  (condition-case err
X      (if (math-apply-rewrites expr (math-compile-patterns pat))
X      1
X    0)
X    (error (math-reject-arg pat (nth 1 err))))
)
X
X
X
;;; A compiled rule set is an a-list of entries whose cars are functors,
;;; and whose cdrs are lists of rules.  If there are rules with no
;;; well-defined head functor, they are included on all lists and also
;;; on an extra list whose car is nil.
;;;
;;; The first entry in the a-list is of the form (schedule A B C ...).
;;;
;;; Rule list entries take the form (regs prog head phases), where:
;;;
;;;   regs   is a vector of match registers.
;;;
;;;   prog   is a match program (see below).
;;;
;;;   head   is a rare function name appearing in the rule body (but not the
;;;         head of the whole rule), or nil if none.
;;;
;;;   phases is a list of phase numbers for which the rule is enabled.
;;;
;;; A match program is a list of match instructions.
;;;
;;; In the following, "part" is a register number that contains the
;;; subexpression to be operated on.
;;;
;;; Register 0 is the whole expression being matched.  The others are
;;; meta-variables in the pattern, temporaries used for matching and
;;; backtracking, and constant expressions.
;;;
;;; (same part reg)
;;;         The selected part must be math-equal to the contents of "reg".
;;;
;;; (same-neg part reg)
;;;         The selected part must be math-equal to the negative of "reg".
;;;
;;; (copy part reg)
;;;        The selected part is copied into "reg".  (Rarely used.)
;;;
;;; (copy-neg part reg)
;;;        The negative of the selected part is copied into "reg".
;;;
;;; (integer part)
;;;         The selected part must be an integer.
;;;
;;; (real part)
;;;         The selected part must be a real.
;;;
;;; (constant part)
;;;         The selected part must be a constant.
;;;
;;; (negative part)
;;;        The selected part must "look" negative.
;;;
;;; (rel part op reg)
;;;         The selected part must satisfy "part op reg", where "op"
;;;        is one of the 6 relational ops, and "reg" is a register.
;;;
;;; (mod part modulo value)
;;;         The selected part must satisfy "part % modulo = value", where
;;;         "modulo" and "value" are constants.
;;;
;;; (func part head reg1 reg2 ... regn)
;;;         The selected part must be an n-ary call to function "head".
;;;         The arguments are stored in "reg1" through "regn".
;;;
;;; (func-def part head defs reg1 reg2 ... regn)
;;;        The selected part must be an n-ary call to function "head".
;;;        "Defs" is a list of value/register number pairs for default args.
;;;        If a match, assign default values to registers and then skip
;;;        immediately over any following "func-def" instructions and
;;;        the following "func" instruction.  If wrong number of arguments,
;;;        proceed to the following "func-def" or "func" instruction.
;;;
;;; (func-opt part head defs reg1)
;;;        Like func-def with "n=1", except that if the selected part is
;;;        not a call to "head", then the part itself successfully matches
;;;        "reg1" (and the defaults are assigned).
;;;
;;; (try part heads mark reg1 [def])
;;;         The selected part must be a function of the correct type which is
;;;         associative and/or commutative.  "Heads" is a list of acceptable
;;;         types.  An initial assignment of arguments to "reg1" is tried.
;;;        If the program later fails, it backtracks to this instruction
;;;        and tries other assignments of arguments to "reg1".
;;;        If "def" exists and normal matching fails, backtrack and assign
;;;        "part" to "reg1", and "def" to "reg2" in the following "try2".
;;;        The "mark" is a vector of size 5; only "mark[3-4]" are initialized.
;;;        "mark[0]" points to the argument list; "mark[1]" points to the
;;;        current argument; "mark[2]" is 0 if there are two arguments,
;;;        1 if reg1 is matching single arguments, 2 if reg2 is matching
;;;        single arguments (a+b+c+d is never split as (a+b)+(c+d)), or
;;;         3 if reg2 is matching "def"; "mark[3]" is 0 if the function must
;;;        have two arguments, 1 if phase-2 can be skipped, 2 if full
;;;        backtracking is necessary; "mark[4]" is t if the arguments have
;;;        been switched from the order given in the original pattern.
;;;
;;; (try2 try reg2)
;;;         Every "try" will be followed by a "try2" whose "try" field is
;;;        a pointer to the corresponding "try".  The arguments which were
;;;        not stored in "reg1" by that "try" are now stored in "reg2".
;;;
;;; (alt instr nil mark)
;;;        Basic backtracking.  Execute the instruction sequence "instr".
;;;        If this fails, back up and execute following the "alt" instruction.
;;;        The "mark" must be the vector "[nil nil 4]".  The "instr" sequence
;;;        should execute "end-alt" at the end.
;;;
;;; (end-alt ptr)
;;;         Register success of the first alternative of a previous "alt".
;;;        "Ptr" is a pointer to the next instruction following that "alt".
;;;
;;; (apply part reg1 reg2)
;;;         The selected part must be a function call.  The functor
;;;        (as a variable name) is stored in "reg1"; the arguments
;;;        (as a vector) are stored in "reg2".
;;;
;;; (cons part reg1 reg2)
;;;        The selected part must be a nonempty vector.  The first element
;;;        of the vector is stored in "reg1"; the rest of the vector
;;;        (as another vector) is stored in "reg2".
;;;
;;; (rcons part reg1 reg2)
;;;        The selected part must be a nonempty vector.  The last element
;;;        of the vector is stored in "reg2"; the rest of the vector
;;;        (as another vector) is stored in "reg1".
;;;
;;; (select part reg)
;;;         If the selected part is a unary call to function "select", its
SHAR_EOF
true || echo 'restore of calc-rewr.el failed'
fi
echo 'End of  part 24'
echo 'File calc-rewr.el is continued in part 25'
echo 25 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].