Newsgroups: comp.sources.misc
From: daveg@synaptics.com (David Gillespie)
Subject:  v24i072:  gnucalc - GNU Emacs Calculator, v2.00, Part24/56
Message-ID: <1991Oct31.072739.18175@sparky.imd.sterling.com>
X-Md4-Signature: 73e94080579af1b29e16619cb5083d9d
Date: Thu, 31 Oct 1991 07:27:39 GMT
Approved: kent@sparky.imd.sterling.com

Submitted-by: daveg@synaptics.com (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, daveg@csvax.cs.caltech.edu.
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: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    (402) 291-8300         FAX:      (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.