daveg@near.cs.caltech.edu (Dave Gillespie) (10/24/90)
#!/bin/sh
# this is part 2 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc.patch continued
#
CurArch=2
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
exit 1; fi
( read Scheck
if test "$Scheck" != $CurArch
then echo "Please unpack part $Scheck next!"
exit 1;
else exit 0; fi
) < s2_seq_.tmp || exit 1
sed 's/^X//' << 'SHAR_EOF' >> calc.patch
X! "Concatenate two vectors without any special cases."
X! (interactive "P")
X! (calc-hyperbolic-func)
X! (calc-concat arg)
X )
X
X ;;;; [calc-mode.el]
X***************
X*** 7733,7739 ****
X (hi (calc-top-n 1)))
X (if (and (or (math-anglep lo) (not (math-objvecp lo)))
X (or (math-anglep hi) (not (math-objvecp hi))))
X! (calc-enter-result 2 nil (math-make-intv (+ num 6) lo hi))
X (error "Components must be real"))))
X ((or (= num -2)
X (and (eq calc-complex-mode 'polar)
X--- 7862,7868 ----
X (hi (calc-top-n 1)))
X (if (and (or (math-anglep lo) (not (math-objvecp lo)))
X (or (math-anglep hi) (not (math-objvecp hi))))
X! (calc-enter-result 2 nil (math-make-intv (+ num 9) lo hi))
X (error "Components must be real"))))
X ((or (= num -2)
X (and (eq calc-complex-mode 'polar)
X***************
X*** 7804,7829 ****
X )
X
X (defun calc-cons (arg)
X! "Insert the object in stack level 2 at front of vector at top of stack."
X (interactive "P")
X (calc-wrapper
X! (calc-binary-op "cons" 'calcFunc-cons arg))
X )
X
X
X (defun calc-head (arg)
X! "Extract the first element of the vector on the top of the stack."
X (interactive "P")
X (calc-wrapper
X! (calc-unary-op "head" 'calcFunc-head arg))
X )
X
X
X (defun calc-tail (arg)
X! "Extract all but the first element of the vector on the top of the stack."
X (interactive "P")
X (calc-wrapper
X! (calc-unary-op "tail" 'calcFunc-tail arg))
X )
X
X (defun calc-vlength (arg)
X--- 7933,7968 ----
X )
X
X (defun calc-cons (arg)
X! "Insert the object in stack level 2 at front of vector at top of stack.
X! With Inverse flag, insert object at top of stack at end of vector at
X! stack level 2."
X (interactive "P")
X (calc-wrapper
X! (if (calc-is-inverse)
X! (calc-binary-op "rcns" 'calcFunc-rcons arg)
X! (calc-binary-op "cons" 'calcFunc-cons arg)))
X )
X
X
X (defun calc-head (arg)
X! "Extract the first element of the vector on the top of the stack.
X! With Inverse flag, extract all but the last element of the vector."
X (interactive "P")
X (calc-wrapper
X! (if (calc-is-inverse)
X! (calc-unary-op "rhed" 'calcFunc-rhead arg)
X! (calc-unary-op "head" 'calcFunc-head arg)))
X )
X
X
X (defun calc-tail (arg)
X! "Extract all but the first element of the vector on the top of the stack.
X! With Inverse flag, extract the last element of the vector."
X (interactive "P")
X (calc-wrapper
X! (if (calc-is-inverse)
X! (calc-unary-op "rtai" 'calcFunc-rtail arg)
X! (calc-unary-op "tail" 'calcFunc-tail arg)))
X )
X
X (defun calc-vlength (arg)
X***************
X*** 7855,7864 ****
X "Extract a subvector of a vector: subvec(vec,start,end).
X If start is zero or negative, it is interpreted as length(vec) + start + 1.
X Same for end. If end is omitted in the algebraic form, it is taken as zero.
X! Elements from start, inclusive, to end, exclusive, are taken."
X (interactive)
X (calc-wrapper
X! (calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3))))
X )
X
X (defun calc-reverse-vector (arg)
X--- 7994,8007 ----
X "Extract a subvector of a vector: subvec(vec,start,end).
X If start is zero or negative, it is interpreted as length(vec) + start + 1.
X Same for end. If end is omitted in the algebraic form, it is taken as zero.
X! Elements from start, inclusive, to end, exclusive, are taken.
X! With Inverse flag, remove the indicated subvector from a vector."
X (interactive)
X (calc-wrapper
X! (if (calc-is-inverse)
X! (calc-enter-result 3 "rsvc" (cons 'calcFunc-rsubvec
X! (calc-top-list-n 3)))
X! (calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3)))))
X )
X
X (defun calc-reverse-vector (arg)
X***************
X*** 7956,7961 ****
X--- 8099,8139 ----
X (calc-binary-op "cros" 'calcFunc-cross arg))
X )
X
X+ (defun calc-remove-duplicates (arg)
X+ "Sort a vector and remove duplicates."
X+ (interactive "P")
X+ (calc-wrapper
X+ (calc-unary-op "rdup" 'calcFunc-rdup arg))
X+ )
X+
X+ (defun calc-set-union (arg)
X+ "Compute the union of two sets expressed as vector."
X+ (interactive "P")
X+ (calc-wrapper
X+ (calc-binary-op "unio" 'calcFunc-vunion arg '(vec) 'calcFunc-rdup))
X+ )
X+
X+ (defun calc-set-intersect (arg)
X+ "Compute the intersect of two sets expressed as vector."
X+ (interactive "P")
X+ (calc-wrapper
X+ (calc-binary-op "intr" 'calcFunc-vint arg '(vec) 'calcFunc-rdup))
X+ )
X+
X+ (defun calc-set-difference (arg)
X+ "Compute the difference of two sets expressed as vector."
X+ (interactive "P")
X+ (calc-wrapper
X+ (calc-binary-op "diff" 'calcFunc-vdiff arg '(vec) 'calcFunc-rdup))
X+ )
X+
X+ (defun calc-set-xor (arg)
X+ "Compute the exclusive-or (symmetric diff) of two sets expressed as vector."
X+ (interactive "P")
X+ (calc-wrapper
X+ (calc-binary-op "xor" 'calcFunc-vxor arg '(vec) 'calcFunc-rdup))
X+ )
X+
X ;;;; [calc-mat.el]
X
X (defun calc-mdet (arg)
X***************
X*** 8071,8080 ****
X (calc-wrapper
X (let* ((sel-mode nil)
X (accum (calc-is-hyperbolic))
X (calc-dollar-values (mapcar 'calc-get-stack-element
X (nthcdr calc-stack-top calc-stack)))
X (calc-dollar-used 0)
X! (oper (or oper (calc-get-operator (if accum "Accumulate" "Reduce")
X 2))))
X (message "Working...")
X (calc-set-command-flag 'clear-message)
X--- 8249,8261 ----
X (calc-wrapper
X (let* ((sel-mode nil)
X (accum (calc-is-hyperbolic))
X+ (rev (calc-is-inverse))
X (calc-dollar-values (mapcar 'calc-get-stack-element
X (nthcdr calc-stack-top calc-stack)))
X (calc-dollar-used 0)
X! (oper (or oper (calc-get-operator (concat
X! (if rev "Inv " "")
X! (if accum "Accumulate" "Reduce"))
X 2))))
X (message "Working...")
X (calc-set-command-flag 'clear-message)
X***************
X*** 8083,8095 ****
X 0 (- 4 (length (nth 2 oper))))
X (nth 2 oper))
X (list (if accum
X! 'calcFunc-accum
X! (intern (concat "calcFunc-reduce"
X (or calc-mapping-dir ""))))
X (math-calcFunc-to-var (nth 1 oper))
X (calc-top-n (1+ calc-dollar-used))))))
X )
X
X (defun calc-map (&optional oper)
X "Apply an operator elementwise to one or two vectors.
X For example, applying * computes a vector of products."
X--- 8264,8286 ----
X 0 (- 4 (length (nth 2 oper))))
X (nth 2 oper))
X (list (if accum
X! (if rev 'calcFunc-raccum 'calcFunc-accum)
X! (intern (concat "calcFunc-"
X! (if rev "r" "")
X! "reduce"
X (or calc-mapping-dir ""))))
X (math-calcFunc-to-var (nth 1 oper))
X (calc-top-n (1+ calc-dollar-used))))))
X )
X
X+ (defun calc-accumulate (&optional oper)
X+ "Apply a binary operator across all vector elements, accumulating results.
X+ For example, accumulating + computes a list of \"triangular numbers.\""
X+ (interactive)
X+ (calc-hyperbolic-func)
X+ (calc-reduce oper)
X+ )
X+
X (defun calc-map (&optional oper)
X "Apply an operator elementwise to one or two vectors.
X For example, applying * computes a vector of products."
X***************
X*** 8164,8169 ****
X--- 8355,8361 ----
X
X ;;; Return a list of the form (nargs func name)
X (defun calc-get-operator (msg &optional nargs)
X+ (setq calc-aborted-prefix nil)
X (let ((inv nil) (hyp nil) (prefix nil)
X done key oper (which 0)
X (msgs '( "(Press ? for help)"
X***************
X*** 8341,8347 ****
X ( ?L 1 calcFunc-exp )
X ( ?E 1 calcFunc-ln )
X ( ?B 2 calcFunc-alog )
X! ( ?^ 2 calcFunc-nroot ) )
X ( ( ?F 1 calcFunc-ffloor ) ; hyperbolic
X ( ?R 1 calcFunc-fround )
X ( ?S 1 calcFunc-sinh )
X--- 8533,8540 ----
X ( ?L 1 calcFunc-exp )
X ( ?E 1 calcFunc-ln )
X ( ?B 2 calcFunc-alog )
X! ( ?^ 2 calcFunc-nroot )
X! ( ?| 2 calcFunc-vconcat ) )
X ( ( ?F 1 calcFunc-ffloor ) ; hyperbolic
X ( ?R 1 calcFunc-fround )
X ( ?S 1 calcFunc-sinh )
X***************
X*** 8477,8484 ****
X ( ?H 2 calcFunc-histogram )
X ( ?N 1 calcFunc-cnorm )
X ( ?S 1 calcFunc-sort )
X! ( ?T 1 calcFunc-tr ) )
X! ( ( ?G 1 calcFunc-rgrade )
X ( ?S 1 calcFunc-rsort ) )
X ( ( ?e 3 calcFunc-vexp )
X ( ?H 3 calcFunc-histogram ) )
X--- 8670,8682 ----
X ( ?H 2 calcFunc-histogram )
X ( ?N 1 calcFunc-cnorm )
X ( ?S 1 calcFunc-sort )
X! ( ?T 1 calcFunc-tr )
X! ( ?V 1 calcFunc-vunion )
X! ( ?X 1 calcFunc-vxor )
X! ( ?- 1 calcFunc-vdiff )
X! ( ?^ 1 calcFunc-vint ) )
X! ( ( ?s 3 calcFunc-rsubvec )
X! ( ?G 1 calcFunc-rgrade )
X ( ?S 1 calcFunc-rsort ) )
X ( ( ?e 3 calcFunc-vexp )
X ( ?H 3 calcFunc-histogram ) )
X***************
X*** 9114,9120 ****
X calc-settings-file)))
X (goto-char (point-max))
X (insert "\n;;; Definition stored by Calc on " (current-time-string)
X! "\n(setq calc-defs (append '(\n")
X (let* ((cmd (cdr def))
X (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
X (pt (point))
X--- 9312,9318 ----
X calc-settings-file)))
X (goto-char (point-max))
X (insert "\n;;; Definition stored by Calc on " (current-time-string)
X! "\n(setq calc-ext-defs (append '(\n")
X (let* ((cmd (cdr def))
X (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
X (pt (point))
X***************
X*** 9136,9143 ****
X (cons 'defun (cons cmd (cdr fcmd)))))
X "\n")
X (or (and (string-match "\"" str) (not q-ok))
X! (progn (fill-region pt (point))
X! (indent-rigidly pt (point) 3)))
X (delete-region pt (1+ pt))
X (let* ((func (calc-stack-command-p cmd))
X (ffunc (and func (symbolp func) (symbol-function func)))
X--- 9334,9341 ----
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) 3)
X (delete-region pt (1+ pt))
X (let* ((func (calc-stack-command-p cmd))
X (ffunc (and func (symbolp func) (symbol-function func)))
X***************
X*** 9151,9158 ****
X (cdr ffunc)))))
X "\n")
X (or (and (string-match "\"" str) (not q-ok))
X! (progn (fill-region pt (point))
X! (indent-rigidly pt (point) 3)))
X (delete-region pt (1+ pt))))))
X (and (stringp fcmd)
X (insert " (fset '" (prin1-to-string cmd)
X--- 9349,9356 ----
X (cdr ffunc)))))
X "\n")
X (or (and (string-match "\"" str) (not q-ok))
X! (fill-region pt (point)))
X! (indent-rigidly pt (point) 3)
X (delete-region pt (1+ pt))))))
X (and (stringp fcmd)
X (insert " (fset '" (prin1-to-string cmd)
X***************
X*** 9162,9168 ****
X " '"
X (prin1-to-string cmd)
X "))\n"))
X! (insert " (and (boundp 'calc-defs) calc-defs)))\n")
X (save-buffer)))
X )
X
X--- 9360,9366 ----
X " '"
X (prin1-to-string cmd)
X "))\n"))
X! (insert " (and (boundp 'calc-ext-defs) calc-ext-defs)))\n")
X (save-buffer)))
X )
X
X***************
X*** 9268,9274 ****
X (calc-execute-kbd-macro last-kbd-macro arg)
X )
X
X! (defun calc-execute-kbd-macro (mac arg)
X (if (vectorp mac)
X (setq mac (or (aref mac 1)
X (aset mac 1 (progn (and (fboundp 'edit-kbd-macro)
X--- 9466,9472 ----
X (calc-execute-kbd-macro last-kbd-macro arg)
X )
X
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***************
X*** 9293,9299 ****
X (equal (car new-stack) (car old-stack)))
X (setq new-stack (cdr new-stack)
X old-stack (cdr old-stack)))
X! (calc-record-list (mapcar 'car new-stack) "kmac")
X (calc-record-undo (list 'set 'saved-stack-top old-stack-top))
X (and old-stack
X (calc-record-undo (list 'pop 1 (mapcar 'car old-stack))))
X--- 9491,9501 ----
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***************
X*** 9999,10005 ****
X ((eq (car a) 'cplx)
X (let ((real (math-normalize (nth 1 a)))
X (imag (math-normalize (nth 2 a))))
X! (if (math-zerop imag) real (list 'cplx real imag))))
X ((eq (car a) 'polar)
X (math-normalize-polar a))
X ((eq (car a) 'hms)
X--- 10201,10210 ----
X ((eq (car a) 'cplx)
X (let ((real (math-normalize (nth 1 a)))
X (imag (math-normalize (nth 2 a))))
X! (if (and (math-zerop imag)
X! (not math-simplify-only)) ; oh, what a kludge!
X! real
X! (list 'cplx real imag))))
X ((eq (car a) 'polar)
X (math-normalize-polar a))
X ((eq (car a) 'hms)
X***************
X*** 10041,10057 ****
X (error "Can't use multi-valued function in an expression"))))
X )
X
X! (defun math-normalize-nonstandard (a)
X! (and (symbolp (car a))
X! (or (eq calc-simplify-mode 'none)
X! (and (eq calc-simplify-mode 'num)
X! (let ((aptr args))
X! (while (and aptr (or (math-scalarp (car aptr))
X! (eq (car-safe (car aptr))
X! 'mod)))
X! (setq aptr (cdr aptr)))
X! aptr)))
X! (cons (car a) args))
X )
X
X
X--- 10246,10269 ----
X (error "Can't use multi-valued function in an expression"))))
X )
X
X! (defun math-normalize-nonstandard () ; uses "a"
X! (if (consp calc-simplify-mode)
X! (progn
X! (setq calc-simplify-mode 'none
X! math-simplify-only (car-safe (cdr-safe a)))
X! nil)
X! (and (symbolp (car a))
X! (or (eq calc-simplify-mode 'none)
X! (and (eq calc-simplify-mode 'num)
X! (let ((aptr (setq a (cons
X! (car a)
X! (mapcar 'math-normalize (cdr a))))))
X! (while (and aptr (or (math-scalarp (car aptr))
X! (eq (car-safe (car aptr))
X! 'mod)))
X! (setq aptr (cdr aptr)))
X! aptr)))
X! (cons (car a) (mapcar 'math-normalize (cdr a)))))
X )
X
X
X***************
X*** 10080,10091 ****
X
X
X ;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public]
X! (defun math-sign (a)
X! (cond ((math-posp a) 1)
X! ((math-negp a) -1)
X ((math-zerop a) 0)
X (t (calc-record-why 'realp a)
X! (list 'calcFunc-sign a)))
X )
X (fset 'calcFunc-sign (symbol-function 'math-sign))
X
X--- 10292,10305 ----
X
X
X ;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public]
X! (defun math-sign (a &optional x)
X! (cond ((math-posp a) (or x 1))
X! ((math-negp a) (if x (math-neg x) -1))
X ((math-zerop a) 0)
X (t (calc-record-why 'realp a)
X! (if x
X! (list 'calcFunc-sign a x)
X! (list 'calcFunc-sign a))))
X )
X (fset 'calcFunc-sign (symbol-function 'math-sign))
X
X***************
X*** 10392,10400 ****
X
X (defun math-vector-head (vec)
X (if (and (Math-vectorp vec)
X! (cdr (cdr vec)))
X (nth 1 vec)
X! (math-record-why 'vectorp vec)
X (list 'calcFunc-head vec))
X )
X (fset 'calcFunc-head (symbol-function 'math-vector-head))
X--- 10606,10614 ----
X
X (defun math-vector-head (vec)
X (if (and (Math-vectorp vec)
X! (cdr vec))
X (nth 1 vec)
X! (calc-record-why 'vectorp vec)
X (list 'calcFunc-head vec))
X )
X (fset 'calcFunc-head (symbol-function 'math-vector-head))
X***************
X*** 10401,10409 ****
X
X (defun math-vector-tail (vec)
X (if (and (Math-vectorp vec)
X! (cdr (cdr vec)))
X! (cdr (cdr vec))
X! (math-record-why 'vectorp vec)
X (list 'calcFunc-tail vec))
X )
X (fset 'calcFunc-tail (symbol-function 'math-vector-tail))
X--- 10615,10623 ----
X
X (defun math-vector-tail (vec)
X (if (and (Math-vectorp vec)
X! (cdr vec))
X! (cons 'vec (cdr (cdr vec)))
X! (calc-record-why 'vectorp vec)
X (list 'calcFunc-tail vec))
X )
X (fset 'calcFunc-tail (symbol-function 'math-vector-tail))
X***************
X*** 10411,10421 ****
X (defun math-cons-vec (head tail)
X (if (Math-vectorp tail)
X (cons 'vec (cons head (cdr tail)))
X! (math-record-why 'vectorp tail)
X (list 'calcFunc-cons head tail))
X )
X (fset 'calcFunc-cons (symbol-function 'math-cons-vec))
X
X
X ;;;; [calc-mat.el]
X
X--- 10625,10663 ----
X (defun math-cons-vec (head tail)
X (if (Math-vectorp tail)
X (cons 'vec (cons head (cdr tail)))
X! (calc-record-why 'vectorp tail)
X (list 'calcFunc-cons head tail))
X )
X (fset 'calcFunc-cons (symbol-function 'math-cons-vec))
X
X+ (defun math-vector-head-rev (vec)
X+ (if (and (Math-vectorp vec)
X+ (cdr vec))
X+ (let ((vec (copy-sequence vec)))
X+ (setcdr (nthcdr (- (length vec) 2) vec) nil)
X+ vec)
X+ (calc-record-why 'vectorp vec)
X+ (list 'calcFunc-rhead vec))
X+ )
X+ (fset 'calcFunc-rhead (symbol-function 'math-vector-head-rev))
X+
X+ (defun math-vector-tail-rev (vec)
X+ (if (and (Math-vectorp vec)
X+ (cdr vec))
X+ (nth (1- (length vec)) vec)
X+ (calc-record-why 'vectorp vec)
X+ (list 'calcFunc-rtail vec))
X+ )
X+ (fset 'calcFunc-rtail (symbol-function 'math-vector-tail-rev))
X+
X+ (defun math-cons-rev-vec (head tail)
X+ (if (Math-vectorp head)
X+ (append head (list tail))
X+ (calc-record-why 'vectorp head)
X+ (list 'calcFunc-rcons head tail))
X+ )
X+ (fset 'calcFunc-rcons (symbol-function 'math-cons-rev-vec))
X+
X
X ;;;; [calc-mat.el]
X
X***************
X*** 10642,10649 ****
X (if (math-matrixp vec)
X (let (expr row)
X (setq func (math-var-to-calcFunc func))
X- (or (math-vectorp vec)
X- (math-reject-arg vec 'vectorp))
X (while (setq vec (cdr vec))
X (setq row (car vec))
X (while (setq row (cdr row))
X--- 10884,10889 ----
X***************
X*** 10654,10659 ****
X--- 10894,10916 ----
X (calcFunc-reducer func vec))
X )
X
X+ (defun calcFunc-rreduce (func vec)
X+ (if (math-matrixp vec)
X+ (let (expr row)
X+ (setq func (math-var-to-calcFunc func)
X+ vec (reverse (cdr vec)))
X+ (while vec
X+ (setq row (reverse (cdr (car vec))))
X+ (while row
X+ (setq expr (if expr
X+ (math-build-call func (list (car row) expr))
X+ (car row))
X+ row (cdr row)))
X+ (setq vec (cdr vec)))
X+ (math-normalize expr))
X+ (calcFunc-rreducer func vec))
X+ )
X+
X (defun calcFunc-reducer (func vec)
X (setq func (math-var-to-calcFunc func))
X (or (math-vectorp vec)
X***************
X*** 10666,10671 ****
X--- 10923,10949 ----
X (math-normalize expr))
X )
X
X+ (defun calcFunc-rreducer (func vec)
X+ (setq func (math-var-to-calcFunc func))
X+ (or (math-vectorp vec)
X+ (math-reject-arg vec 'vectorp))
X+ (if (eq func 'calcFunc-sub) ; do this in a way that looks nicer
X+ (let ((expr (car (setq vec (cdr vec)))))
X+ (or expr
X+ (math-reject-arg vec "Vector is empty"))
X+ (while (setq vec (cdr vec))
X+ (setq expr (math-build-call func (list expr (car vec)))
X+ func (if (eq func 'calcFunc-sub)
X+ 'calcFunc-add 'calcFunc-sub)))
X+ (math-normalize expr))
X+ (let ((expr (car (setq vec (reverse (cdr vec))))))
X+ (or expr
X+ (math-reject-arg vec "Vector is empty"))
X+ (while (setq vec (cdr vec))
X+ (setq expr (math-build-call func (list (car vec) expr))))
X+ (math-normalize expr)))
X+ )
X+
X (defun calcFunc-reducec (func vec)
X (if (math-matrixp vec)
X (calcFunc-reducer func (math-transpose vec))
X***************
X*** 10672,10677 ****
X--- 10950,10961 ----
X (calcFunc-reducer func vec))
X )
X
X+ (defun calcFunc-rreducec (func vec)
X+ (if (math-matrixp vec)
X+ (calcFunc-rreducer func (math-transpose vec))
X+ (calcFunc-rreducer func vec))
X+ )
X+
X (defun calcFunc-reducea (func vec)
X (if (math-matrixp vec)
X (cons 'vec
X***************
X*** 10680,10685 ****
X--- 10964,10977 ----
X (calcFunc-reducer func vec))
X )
X
X+ (defun calcFunc-rreducea (func vec)
X+ (if (math-matrixp vec)
X+ (cons 'vec
X+ (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
X+ (cdr vec)))
X+ (calcFunc-rreducer func vec))
X+ )
X+
X (defun calcFunc-reduced (func vec)
X (if (math-matrixp vec)
X (cons 'vec
X***************
X*** 10688,10693 ****
X--- 10980,10993 ----
X (calcFunc-reducer func vec))
X )
X
X+ (defun calcFunc-rreduced (func vec)
X+ (if (math-matrixp vec)
X+ (cons 'vec
X+ (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
X+ (cdr (math-transpose vec))))
X+ (calcFunc-rreducer func vec))
X+ )
X+
X (defun calcFunc-accum (func vec)
X (setq func (math-var-to-calcFunc func))
X (or (math-vectorp vec)
X***************
X*** 10702,10708 ****
X--- 11002,11022 ----
X (math-normalize res))
X )
X
X+ (defun calcFunc-raccum (func vec)
X+ (setq func (math-var-to-calcFunc func))
X+ (or (math-vectorp vec)
X+ (math-reject-arg vec 'vectorp))
X+ (let* ((expr (car (setq vec (reverse (cdr vec)))))
X+ (res (list expr)))
X+ (or expr
X+ (math-reject-arg vec "Vector is empty"))
X+ (while (setq vec (cdr vec))
X+ (setq expr (math-build-call func (list (car vec) expr))
X+ res (cons (list expr) res)))
X+ (math-normalize (cons 'vec res)))
X+ )
X
X+
X (defun calcFunc-outer (func a b)
X (or (math-vectorp a) (math-reject-arg a 'vectorp))
X (or (math-vectorp b) (math-reject-arg b 'vectorp))
X***************
X*** 10935,10940 ****
X--- 11249,11260 ----
X (list vec))
X )
X
X+ (defun calcFunc-append (v1 v2)
X+ (if (and (math-vectorp v1) (math-vectorp v2))
X+ (append v1 (cdr v2))
X+ (list 'calcFunc-append v1 v2))
X+ )
X+
X
X ;;; Copy a matrix. [Public]
X (defun math-copy-matrix (m)
X***************
X*** 10974,10980 ****
X ;;; Create a vector of consecutive integers. [Public]
X (defun math-vec-index (n &optional start incr)
X (if (math-messy-integerp n)
X! (math-float (math-vec-index (math-trunc n)))
X (and (not (integerp n))
X (setq n (math-check-fixnum n)))
X (let ((vec nil))
X--- 11294,11300 ----
X ;;; Create a vector of consecutive integers. [Public]
X (defun math-vec-index (n &optional start incr)
X (if (math-messy-integerp n)
X! (math-float (math-vec-index (math-trunc n) start incr))
X (and (not (integerp n))
X (setq n (math-check-fixnum n)))
X (let ((vec nil))
X***************
X*** 11034,11039 ****
X--- 11354,11379 ----
X )
X (fset 'calcFunc-subvec (symbol-function 'math-subvector))
X
X+ ;;; Remove a subvector from a vector.
X+ (defun math-rsubvector (vec start &optional end)
X+ (setq start (math-check-fixnum start)
X+ end (math-check-fixnum (or end 0)))
X+ (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
X+ (let ((len (1- (length vec))))
X+ (if (<= start 0)
X+ (setq start (+ len start 1)))
X+ (if (<= end 0)
X+ (setq end (+ len end 1)))
X+ (if (or (> start len)
X+ (<= end start))
X+ vec
X+ (let ((tail (nthcdr end vec))
X+ (chop (nthcdr (1- start) (setq vec (copy-sequence vec)))))
X+ (setcdr chop nil)
X+ (append vec tail))))
X+ )
X+ (fset 'calcFunc-rsubvec 'math-rsubvector)
X+
X ;;; Reverse the order of the elements of a vector.
X (defun math-reverse-vector (vec)
X (if (math-vectorp vec)
X***************
X*** 11171,11176 ****
X--- 11511,11593 ----
X (fset 'calcFunc-histogram (symbol-function 'math-histogram))
X
X
X+ (defun calcFunc-vunion (a b)
X+ (setq a (cdr (calcFunc-rdup a)))
X+ (setq b (cdr (calcFunc-rdup b)))
X+ (let ((vec (list 'vec)))
X+ (while (or a b)
X+ (if (and a
X+ (or (not b)
X+ (math-beforep (car a) (car b))))
X+ (setq vec (cons (car a) vec)
X+ a (cdr a))
X+ (and a (math-equal (car a) (car b))
X+ (setq a (cdr a)))
X+ (setq vec (cons (car b) vec)
X+ b (cdr b))))
X+ (nreverse vec))
X+ )
X+
X+ (defun calcFunc-vint (a b)
X+ (setq a (cdr (calcFunc-rdup a)))
X+ (setq b (cdr (calcFunc-rdup b)))
X+ (let ((vec (list 'vec)))
X+ (while (and a b)
X+ (if (math-equal (car a) (car b))
X+ (setq vec (cons (car a) vec)
X+ a (cdr a)
X+ b (cdr b))
X+ (if (math-beforep (car a) (car b))
X+ (setq a (cdr a))
X+ (setq b (cdr b)))))
X+ (nreverse vec))
X+ )
X+
X+ (defun calcFunc-vdiff (a b)
X+ (setq a (cdr (calcFunc-rdup a)))
X+ (setq b (cdr (calcFunc-rdup b)))
X+ (let ((vec (list 'vec)))
X+ (while a
X+ (while (and b (math-beforep (car b) (car a)))
X+ (setq b (cdr b)))
X+ (if (and b (math-equal (car a) (car b)))
X+ (setq a (cdr a)
X+ b (cdr b))
X+ (setq vec (cons (car a) vec)
X+ a (cdr a))))
X+ (nreverse vec))
X+ )
X+
X+ (defun calcFunc-vxor (a b)
X+ (setq a (cdr (calcFunc-rdup a)))
X+ (setq b (cdr (calcFunc-rdup b)))
X+ (let ((vec (list 'vec)))
X+ (while (or a b)
X+ (if (and a
X+ (or (not b)
X+ (math-beforep (car a) (car b))))
X+ (setq vec (cons (car a) vec)
X+ a (cdr a))
X+ (if (and a (math-equal (car a) (car b)))
X+ (setq a (cdr a))
X+ (setq vec (cons (car b) vec)))
X+ (setq b (cdr b))))
X+ (nreverse vec))
X+ )
X+
X+ (defun calcFunc-rdup (a)
X+ (or (math-vectorp a) (math-reject-arg a 'vectorp))
X+ (setq a (sort (copy-sequence (cdr a)) 'math-beforep))
X+ (let ((p a))
X+ (while (cdr p)
X+ (if (math-equal (car p) (nth 1 p))
X+ (setcdr p (cdr (cdr p)))
X+ (setq p (cdr p)))))
X+ (cons 'vec a)
X+ )
X+
X+
X+
X ;;;; [calc-mat.el]
X
X (defun math-matrix-trace (mat) ; [Public]
X***************
X*** 11768,11773 ****
X--- 12185,12193 ----
X (math-make-intv (aref [0 2 1 3] (nth 1 a))
X (math-neg (nth 3 a))
X (math-neg (nth 2 a))))
X+ ((and math-simplify-only
X+ (not (equal a math-simplify-only)))
X+ (list 'neg a))
X ((eq (car a) '-)
X (math-sub (nth 2 a) (nth 1 a)))
X ((and (memq (car a) '(* /))
X***************
X*** 11875,11881 ****
X )
X
X (defun math-add-symb-fancy (a b)
X! (or (and (eq (car-safe b) '+)
X (math-add (math-add a (nth 1 b))
X (nth 2 b)))
X (and (eq (car-safe b) '-)
X--- 12295,12304 ----
X )
X
X (defun math-add-symb-fancy (a b)
X! (or (and math-simplify-only
X! (not (equal a math-simplify-only))
X! (list '+ a b))
X! (and (eq (car-safe b) '+)
X (math-add (math-add a (nth 1 b))
X (nth 2 b)))
X (and (eq (car-safe b) '-)
X***************
X*** 12035,12041 ****
X ;;;; [calc-arith.el]
X
X (defun math-mul-symb-fancy (a b)
X! (or (and (Math-equal-int a 1)
X b)
X (and (Math-equal-int a -1)
X (math-neg b))
X--- 12458,12467 ----
X ;;;; [calc-arith.el]
X
X (defun math-mul-symb-fancy (a b)
X! (or (and math-simplify-only
X! (not (equal a math-simplify-only))
X! (list '* a b))
X! (and (Math-equal-int a 1)
X b)
X (and (Math-equal-int a -1)
X (math-neg b))
X***************
X*** 12270,12276 ****
X )
X
X (defun math-div-symb-fancy (a b)
X! (or (and (Math-equal-int b 1) a)
X (and (Math-equal-int b -1) (math-neg a))
X (and (eq (car-safe b) '^)
X (or (Math-looks-negp (nth 2 b)) (Math-equal-int a 1))
X--- 12696,12705 ----
X )
X
X (defun math-div-symb-fancy (a b)
X! (or (and math-simplify-only
X! (not (equal a math-simplify-only))
X! (list '/ a b))
X! (and (Math-equal-int b 1) a)
X (and (Math-equal-int b -1) (math-neg a))
X (and (eq (car-safe b) '^)
X (or (Math-looks-negp (nth 2 b)) (Math-equal-int a 1))
X***************
X*** 12380,12386 ****
X (math-float (math-mul b (math-ln-raw (math-float a)))))))))
X ((or (not (Math-objvecp a))
X (not (Math-objectp b)))
X! (cond ((and (eq (car-safe a) 'calcFunc-sqrt)
X (math-evenp b))
X (math-pow (nth 1 a) (math-div2 b)))
X ((eq (car-safe a) '*)
X--- 12809,12818 ----
X (math-float (math-mul b (math-ln-raw (math-float a)))))))))
X ((or (not (Math-objvecp a))
X (not (Math-objectp b)))
X! (cond ((and math-simplify-only
X! (not (equal a math-simplify-only)))
X! (list '^ a b))
X! ((and (eq (car-safe a) 'calcFunc-sqrt)
X (math-evenp b))
X (math-pow (nth 1 a) (math-div2 b)))
X ((eq (car-safe a) '*)
X***************
X*** 12671,12676 ****
X--- 13103,13110 ----
X
X ;;;; [calc-ext.el]
X
X+ (setq math-simplify-only nil)
X+
X (defun math-inexact-result ()
X (and calc-symbolic-mode
X (signal 'inexact-result nil))
X***************
X*** 13798,13804 ****
X ;;; Sine, cosine, and tangent.
X
X (defun math-sin (x) ; [N N] [Public]
X! (cond ((Math-scalarp x)
X (math-with-extra-prec 2
X (math-sin-raw (math-to-radians (math-float x)))))
X ((eq (car x) 'sdev)
X--- 14232,14239 ----
X ;;; Sine, cosine, and tangent.
X
X (defun math-sin (x) ; [N N] [Public]
X! (cond ((eq x 0) 0)
X! ((Math-scalarp x)
X (math-with-extra-prec 2
X (math-sin-raw (math-to-radians (math-float x)))))
X ((eq (car x) 'sdev)
X***************
X*** 13820,13826 ****
X (fset 'calcFunc-sin (symbol-function 'math-sin))
X
X (defun math-cos (x) ; [N N] [Public]
X! (cond ((Math-scalarp x)
X (math-with-extra-prec 2
X (math-cos-raw (math-to-radians (math-float x)))))
X ((eq (car x) 'sdev)
X--- 14255,14262 ----
X (fset 'calcFunc-sin (symbol-function 'math-sin))
X
X (defun math-cos (x) ; [N N] [Public]
X! (cond ((eq x 0) 1)
X! ((Math-scalarp x)
X (math-with-extra-prec 2
X (math-cos-raw (math-to-radians (math-float x)))))
X ((eq (car x) 'sdev)
X***************
X*** 13869,13875 ****
X (fset 'calcFunc-sincos (symbol-function 'math-sin-cos))
X
X (defun math-tan (x) ; [N N] [Public]
X! (cond ((Math-scalarp x)
X (math-with-extra-prec 2
X (math-tan-raw (math-to-radians (math-float x)))))
X ((eq (car x) 'sdev)
X--- 14305,14312 ----
X (fset 'calcFunc-sincos (symbol-function 'math-sin-cos))
X
X (defun math-tan (x) ; [N N] [Public]
X! (cond ((eq x 0) 0)
X! ((Math-scalarp x)
X (math-with-extra-prec 2
X (math-tan-raw (math-to-radians (math-float x)))))
X ((eq (car x) 'sdev)
X***************
X*** 14005,14011 ****
X ;;; Inverse sine, cosine, tangent.
X
X (defun math-arcsin (x) ; [N N] [Public]
X! (cond ((Math-numberp x)
X (math-with-extra-prec 2
X (math-from-radians (math-arcsin-raw (math-float x)))))
X ((and (eq (car x) 'sdev)
X--- 14442,14449 ----
X ;;; Inverse sine, cosine, tangent.
X
X (defun math-arcsin (x) ; [N N] [Public]
X! (cond ((eq x 0) 0)
X! ((Math-numberp x)
X (math-with-extra-prec 2
X (math-from-radians (math-arcsin-raw (math-float x)))))
X ((and (eq (car x) 'sdev)
X***************
X*** 14026,14032 ****
X (fset 'calcFunc-arcsin (symbol-function 'math-arcsin))
X
X (defun math-arccos (x) ; [N N] [Public]
X! (cond ((Math-numberp x)
X (math-with-extra-prec 2
X (math-from-radians (math-arccos-raw (math-float x)))))
X ((and (eq (car x) 'sdev)
X--- 14464,14471 ----
X (fset 'calcFunc-arcsin (symbol-function 'math-arcsin))
X
X (defun math-arccos (x) ; [N N] [Public]
X! (cond ((eq x 1) 0)
X! ((Math-numberp x)
X (math-with-extra-prec 2
X (math-from-radians (math-arccos-raw (math-float x)))))
X ((and (eq (car x) 'sdev)
X***************
X*** 14047,14053 ****
X (fset 'calcFunc-arccos (symbol-function 'math-arccos))
X
X (defun math-arctan (x) ; [N N] [Public]
X! (cond ((Math-numberp x)
X (math-with-extra-prec 2
X (math-from-radians (math-arctan-raw (math-float x)))))
X ((eq (car x) 'sdev)
X--- 14486,14493 ----
X (fset 'calcFunc-arccos (symbol-function 'math-arccos))
X
X (defun math-arctan (x) ; [N N] [Public]
X! (cond ((eq x 0) 0)
X! ((Math-numberp x)
X (math-with-extra-prec 2
X (math-from-radians (math-arctan-raw (math-float x)))))
X ((eq (car x) 'sdev)
X***************
X*** 14157,14163 ****
X ;;; Exponential function.
X
X (defun math-exp (x) ; [N N] [Public]
X! (cond ((Math-numberp x)
X (math-with-extra-prec 2 (math-exp-raw (math-float x))))
X ((eq (car-safe x) 'sdev)
X (let ((ex (math-exp (nth 1 x))))
X--- 14597,14604 ----
X ;;; Exponential function.
X
X (defun math-exp (x) ; [N N] [Public]
X! (cond ((eq x 0) 1)
X! ((Math-numberp x)
X (math-with-extra-prec 2 (math-exp-raw (math-float x))))
X ((eq (car-safe x) 'sdev)
X (let ((ex (math-exp (nth 1 x))))
X***************
X*** 14170,14176 ****
X (fset 'calcFunc-exp (symbol-function 'math-exp))
X
X (defun math-exp-minus-1 (x) ; [N N] [Public]
X! (cond ((math-zerop x) '(float 0 0))
X (calc-symbolic-mode (signal 'inexact-result nil))
X ((Math-numberp x)
X (math-with-extra-prec 2
X--- 14611,14618 ----
X (fset 'calcFunc-exp (symbol-function 'math-exp))
X
X (defun math-exp-minus-1 (x) ; [N N] [Public]
X! (cond ((eq x 0) 0)
X! ((math-zerop x) '(float 0 0))
X (calc-symbolic-mode (signal 'inexact-result nil))
X ((Math-numberp x)
X (math-with-extra-prec 2
X***************
X*** 14196,14202 ****
X (fset 'calcFunc-expm1 (symbol-function 'math-exp-minus-1))
X
X (defun math-exp10 (x) ; [N N] [Public]
X! (math-pow '(float 1 1) x)
X )
X (fset 'calcFunc-exp10 (symbol-function 'math-exp10))
X
X--- 14638,14646 ----
X (fset 'calcFunc-expm1 (symbol-function 'math-exp-minus-1))
X
X (defun math-exp10 (x) ; [N N] [Public]
X! (if (eq x 0)
X! 1
X! (math-pow '(float 1 1) x))
X )
X (fset 'calcFunc-exp10 (symbol-function 'math-exp10))
X
X***************
X*** 14247,14252 ****
X--- 14691,14697 ----
X (defun math-ln (x) ; [N N] [Public]
X (cond ((math-zerop x)
X (math-reject-arg x "Logarithm of zero"))
X+ ((eq x 1) 0)
X ((Math-numberp x)
X (math-with-extra-prec 2 (math-ln-raw (math-float x))))
X ((and (eq (car-safe x) 'sdev)
X***************
X*** 14432,14437 ****
X--- 14877,14883 ----
X
X (defun math-ln-plus-1 (x) ; [N N] [Public]
X (cond ((Math-equal-int x -1) (math-reject-arg x "Logarithm of zero"))
X+ ((eq x 0) 0)
X ((math-zerop x) '(float 0 0))
X (calc-symbolic-mode (signal 'inexact-result nil))
X ((Math-numberp x)
X***************
X*** 16778,16789 ****
X (fset 'calcFunc-esimplify (symbol-function 'math-simplify-extended))
X
X (defun math-simplify (top-expr)
X! (calc-with-default-simplification
X! (let ((math-simplify-symbolic-powers t)
X! res)
X! (while (not (equal top-expr (setq res (math-simplify-step
X! (math-normalize top-expr)))))
X! (setq top-expr res))))
X top-expr
X )
X (fset 'calcFunc-simplify (symbol-function 'math-simplify))
X--- 17224,17240 ----
X (fset 'calcFunc-esimplify (symbol-function 'math-simplify-extended))
X
X (defun math-simplify (top-expr)
X! (let ((math-simplify-symbolic-powers t)
X! (top-only (consp calc-simplify-mode))
X! res)
X! (if top-only
X! (setq res (math-simplify-step (math-normalize top-expr))
X! calc-simplify-mode '(nil)
X! top-expr (math-normalize res))
X! (calc-with-default-simplification
X! (while (not (equal top-expr (setq res (math-simplify-step
X! (math-normalize top-expr)))))
X! (setq top-expr res)))))
X top-expr
X )
X (fset 'calcFunc-simplify (symbol-function 'math-simplify))
X***************
X*** 16794,16800 ****
X (defun math-simplify-step (a)
X (if (Math-primp a)
X a
X! (let ((aa (cons (car a) (mapcar 'math-simplify-step (cdr a)))))
X (and (symbolp (car aa))
X (let ((handler (get (car aa) 'math-simplify)))
X (and handler
X--- 17245,17253 ----
X (defun math-simplify-step (a)
X (if (Math-primp a)
X a
X! (let ((aa (if top-only
X! a
X! (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
X (and (symbolp (car aa))
X (let ((handler (get (car aa) 'math-simplify)))
X (and handler
X***************
X*** 17431,17440 ****
X ;;; (as a vector) are stored in "reg2".
X ;;;
X ;;; (cons part reg1 reg2)
X! ;;; The selected part must be a vector. The first element of
X! ;;; the vector is stored in "reg1"; the rest of the vector
X ;;; (as another vector) is stored in "reg2".
X ;;;
X ;;; (select part reg)
X ;;; If the selected part is a unary call to function "select", its
X ;;; argument is stored in "reg"; otherwise (provided this is an `a r'
X--- 17884,17898 ----
X ;;; (as a vector) are stored in "reg2".
X ;;;
X ;;; (cons part reg1 reg2)
X! ;;; The selected part must be a nonempty vector. The first element
X! ;;; of the vector is stored in "reg1"; the rest of the vector
X ;;; (as another vector) is stored in "reg2".
X ;;;
X+ ;;; (rcons part reg1 reg2)
X+ ;;; The selected part must be a nonempty vector. The last element
X+ ;;; of the vector is stored in "reg2"; the rest of the vector
X+ ;;; (as another vector) is stored in "reg1".
X+ ;;;
X ;;; (select part reg)
X ;;; If the selected part is a unary call to function "select", its
X ;;; argument is stored in "reg"; otherwise (provided this is an `a r'
X***************
X*** 17444,17449 ****
X--- 17902,17910 ----
X ;;; The "expr", with registers substituted, must simplify to
X ;;; a non-zero value.
X ;;;
X+ ;;; (let reg expr)
X+ ;;; Evaluate "expr" and store the result in "reg". Always succeeds.
X+ ;;;
X ;;; (done rhs)
X ;;; Rewrite the expression to "rhs", with register substituted.
X ;;; Normalize; if the result is different from the original
X***************
X*** 17452,17459 ****
X ;;;
X
X ;;; Pseudo-functions related to rewrites:
X ;;; In patterns: quote, plain, condition, opt, apply, cons, select
X! ;;; In righthand sides: quote, plain, eval, evalsimp, apply, cons, select
X
X ;;; Some optimizations that would be nice to have:
X ;;;
X--- 17913,17925 ----
X ;;;
X
X ;;; Pseudo-functions related to rewrites:
X+ ;;;
X ;;; In patterns: quote, plain, condition, opt, apply, cons, select
X! ;;;
X! ;;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
X! ;;; apply, cons, select
X! ;;;
X! ;;; In conditions: let + same as for righthand sides
X
X ;;; Some optimizations that would be nice to have:
X ;;;
X***************
X*** 17470,17475 ****
X--- 17936,17944 ----
X ;;; (Currently rules like this go on the "nil" list.)
X ;;; Same for "func-opt" functions. (Though not urgent for these.)
X ;;;
X+ ;;; * Shouldn't evaluate a "let" condition until the end, or until it
X+ ;;; would enable another condition to be evaluated.
X+ ;;;
X
X ;;; Some additional features to add / things to think about:
X ;;;
X***************
X*** 17615,17621 ****
X (setq all-heads (cons (cons (car heads) 1) all-heads)))
X (setq heads (cdr heads))))
X (if (eq head '-) (setq head '+))
X! (if (eq head 'calcFunc-cons) (setq head 'vec))
X (if head
X (nconc (or (assq head rule-set)
X (car (setq rule-set (cons (cons head
X--- 18084,18090 ----
X (setq all-heads (cons (cons (car heads) 1) all-heads)))
X (setq heads (cdr heads))))
X (if (eq head '-) (setq head '+))
X! (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
X (if head
X (nconc (or (assq head rule-set)
X (car (setq rule-set (cons (cons head
X***************
X*** 17667,17673 ****
X (or (memq (car expr) heads)
X (memq (car expr) '(calcFunc-quote calcFunc-plain calcFunc-opt
X calcFunc-select calcFunc-apply
X! calcFunc-cons calcFunc-condition))
X (memq 'algebraic (get (car expr) 'math-rewrite-props))
X (setq heads (cons (car expr) heads)))
X (while (setq expr (cdr expr))
X--- 18136,18143 ----
X (or (memq (car expr) heads)
X (memq (car expr) '(calcFunc-quote calcFunc-plain calcFunc-opt
X calcFunc-select calcFunc-apply
X! calcFunc-cons calcFunc-rcons
X! calcFunc-condition))
X (memq 'algebraic (get (car expr) 'math-rewrite-props))
X (setq heads (cons (car expr) heads)))
X (while (setq expr (cdr expr))
X***************
X*** 17732,17741 ****
X math-prog))
X )
X
X (defun math-rwcomp-cond-instr (expr)
X (setq expr (math-rwcomp-match-vars expr))
X (let (op arg)
X! (cond ((and (setq op (cdr (assq (car-safe expr)
X '( (calcFunc-integer . integer)
X (calcFunc-real . real)
X (calcFunc-constant . constant)
X--- 18202,18232 ----
X math-prog))
X )
X
X+ (defun math-rwcomp-bind-var (reg var)
X+ (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
X+ (let ((cond math-conds))
X+ (while cond
X+ (if (math-rwcomp-all-regs-done (car cond))
X+ (let ((expr (car cond)))
X+ (setq math-conds (delq (car cond) math-conds))
X+ (setcar cond 1)
X+ (math-rwcomp-cond-instr expr)))
X+ (setq cond (cdr cond))))
X+ )
X+
X (defun math-rwcomp-cond-instr (expr)
X (setq expr (math-rwcomp-match-vars expr))
X (let (op arg)
X! (cond ((eq expr 1))
X! ((and (eq (car expr) 'calcFunc-let)
X! (= (length expr) 3)
X! (memq (car-safe (nth 1 expr)) '(var calcFunc-register)))
X! (let ((reg (math-rwcomp-reg)))
X! (math-rwcomp-instr 'let reg (nth 2 expr))
X! (if (eq (car (nth 1 expr)) 'var)
X! (math-rwcomp-bind-var reg (nth 1 expr))
X! (math-rwcomp-same-instr reg (nth 1 (nth 1 expr)) nil))))
X! ((and (setq op (cdr (assq (car-safe expr)
X '( (calcFunc-integer . integer)
X (calcFunc-real . real)
X (calcFunc-constant . constant)
X***************
X*** 17802,17815 ****
X (let ((entry (assq (nth 2 expr) math-regs)))
X (if entry
X (math-rwcomp-same-instr part (nth 1 entry) nil)
X! (setcar (math-rwcomp-reg-entry part) (nth 2 expr))
X! (let ((cond math-conds))
X! (while cond
X! (if (math-rwcomp-all-regs-done (car cond))
X! (progn
X! (math-rwcomp-cond-instr (car cond))
X! (setq math-conds (delq (car cond) math-conds))))
X! (setq cond (cdr cond)))))))
X ((and (eq (car expr) 'calcFunc-select)
X (= (length expr) 2))
X (let ((reg (math-rwcomp-reg)))
X--- 18293,18299 ----
X (let ((entry (assq (nth 2 expr) math-regs)))
X (if entry
X (math-rwcomp-same-instr part (nth 1 entry) nil)
X! (math-rwcomp-bind-var part expr))))
X ((and (eq (car expr) 'calcFunc-select)
X (= (length expr) 2))
X (let ((reg (math-rwcomp-reg)))
X***************
X*** 17846,17851 ****
X--- 18330,18342 ----
X (math-rwcomp-instr 'cons part reg1 reg2)
X (math-rwcomp-pattern (nth 1 expr) reg1)
X (math-rwcomp-pattern (nth 2 expr) reg2)))
X+ ((and (eq (car expr) 'calcFunc-rcons)
X+ (= (length expr) 3))
X+ (let ((reg1 (math-rwcomp-reg))
X+ (reg2 (math-rwcomp-reg)))
X+ (math-rwcomp-instr 'rcons part reg1 reg2)
X+ (math-rwcomp-pattern (nth 1 expr) reg1)
X+ (math-rwcomp-pattern (nth 2 expr) reg2)))
X ((and (eq (car expr) 'calcFunc-condition)
X (>= (length expr) 3))
X (math-rwcomp-pattern (nth 1 expr) part)
X***************
X*** 17962,17970 ****
X (if (Math-primp expr)
X (or (not (eq (car-safe expr) 'var))
X (assq (nth 2 expr) math-regs))
X! (while (and (setq expr (cdr expr))
X! (math-rwcomp-all-regs-done (car expr))))
X! (null expr))
X )
X
X (defun math-rwcomp-no-vars (expr)
X--- 18453,18466 ----
X (if (Math-primp expr)
X (or (not (eq (car-safe expr) 'var))
X (assq (nth 2 expr) math-regs))
X! (or (and (eq (car expr) 'calcFunc-let)
X! (= (length expr) 3)
X! (eq (car-safe (nth 1 expr)) 'var)
X! (math-rwcomp-all-regs-done (nth 2 expr)))
X! (progn
X! (while (and (setq expr (cdr expr))
X! (math-rwcomp-all-regs-done (car expr))))
X! (null expr))))
X )
X
X (defun math-rwcomp-no-vars (expr)
X***************
X*** 18075,18081 ****
X ((eq (car expr) 'var)
X (if (assq (nth 2 expr) math-regs)
X 0
X! (if (= (math-expr-contains math-pattern expr) 1)
X 50
X 20)))
X (t (let ((props (get (car expr) 'math-rewrite-props)))
X--- 18571,18577 ----
X ((eq (car expr) 'var)
X (if (assq (nth 2 expr) math-regs)
X 0
X! (if (= (math-rwcomp-count-refs expr) 1)
X 50
X 20)))
X (t (let ((props (get (car expr) 'math-rewrite-props)))
X***************
X*** 18087,18092 ****
X--- 18583,18599 ----
X 10)))))
X )
X
X+ (defun math-rwcomp-count-refs (var)
X+ (let ((count (math-expr-contains math-pattern var))
X+ (p math-conds))
X+ (while p
X+ (if (and (eq (car-safe (car p)) 'calcFunc-let)
X+ (= (length (car p)) 3))
X+ (setq count (+ count (math-expr-contains (nth 2 (car p)) var))))
X+ (setq p (cdr p)))
X+ count)
X+ )
X+
X ;;; In the current implementation, all associative functions must
X ;;; also be commutative.
X
X***************
X*** 18120,18125 ****
X--- 18627,18635 ----
X (put 'calcFunc-lcm 'math-rewrite-props '(assoc commut))
X (put 'calcFunc-max 'math-rewrite-props '(algebraic assoc commut))
X (put 'calcFunc-min 'math-rewrite-props '(algebraic assoc commut))
X+ (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-vint 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-vxor 'math-rewrite-props '(assoc commut))
X
X ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
X ;;; Also, "-" is not commutative but the code tweaks things so that it is.
X***************
X*** 18131,18136 ****
X--- 18641,18650 ----
X (put '^ 'math-rewrite-default 1)
X (put 'calcFunc-land 'math-rewrite-default 1)
X (put 'calcFunc-lor 'math-rewrite-default 0)
X+ (put 'calcFunc-vunion 'math-rewrite-default '(vec))
X+ (put 'calcFunc-vint 'math-rewrite-default '(vec))
X+ (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
X+ (put 'calcFunc-vxor 'math-rewrite-default '(vec))
X
X (defmacro math-rwfail (&optional back)
X (list 'setq 'pc
X***************
X*** 18293,18305 ****
X (math-rwfail)
X (aset regs (nth 2 inst) part))))
X
X- ((eq op 'cond)
X- (if (math-is-true
X- (math-simplify
X- (math-rwapply-replace-regs (nth 1 inst))))
X- (setq pc (cdr pc))
X- (math-rwfail)))
X-
X ((eq op 'same-neg)
X (if (math-equal (aref regs (nth 1 inst))
X (math-neg (aref regs (nth 2 inst))))
X--- 18807,18812 ----
X***************
X*** 18464,18470 ****
X
X ((eq op 'apply)
X (if (and (consp (setq part (aref regs (car (cdr inst)))))
X! (not (Math-objvecp part)))
X (progn
X (aset regs (nth 2 inst)
X (math-calcFunc-to-var (car part)))
X--- 18971,18978 ----
X
X ((eq op 'apply)
X (if (and (consp (setq part (aref regs (car (cdr inst)))))
X! (not (Math-objvecp part))
X! (not (eq (car part) 'var)))
X (progn
X (aset regs (nth 2 inst)
X (math-calcFunc-to-var (car part)))
X***************
X*** 18483,18488 ****
X--- 18991,19019 ----
X (setq pc (cdr pc)))
X (math-rwfail)))
X
X+ ((eq op 'rcons)
X+ (if (and (consp (setq part (aref regs (car (cdr inst)))))
X+ (eq (car part) 'vec)
X+ (cdr part))
X+ (progn
X+ (aset regs (nth 2 inst) (math-vector-head-rev part))
X+ (aset regs (nth 3 inst) (math-vector-tail-rev part))
X+ (setq pc (cdr pc)))
X+ (math-rwfail)))
X+
X+ ((eq op 'cond)
X+ (if (math-is-true
X+ (math-simplify
X+ (math-rwapply-replace-regs (nth 1 inst))))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'let)
X+ (aset regs (nth 1 inst)
X+ (math-normalize
X+ (math-rwapply-replace-regs (nth 2 inst))))
X+ (setq pc (cdr pc)))
X+
X ((eq op 'done)
X (setq result (math-rwapply-replace-regs (nth 1 inst)))
X (if (or (and (eq (car-safe result) '+)
X***************
X*** 18526,18531 ****
X--- 19057,19065 ----
X ((and (eq (car expr) 'calcFunc-evalsimp)
X (= (length expr) 2))
X (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
X+ ((and (eq (car expr) 'calcFunc-evalextsimp)
X+ (= (length expr) 2))
X+ (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
X ((and (eq (car expr) 'calcFunc-apply)
X (= (length expr) 3))
X (let ((func (math-rwapply-replace-regs (nth 1 expr)))
X***************
X*** 18545,18550 ****
X--- 19079,19091 ----
X (if (math-vectorp tail)
X (cons 'vec (cons head (cdr tail)))
X (list 'calcFunc-cons head tail))))
X+ ((and (eq (car expr) 'calcFunc-rcons)
X+ (= (length expr) 3))
X+ (let ((head (math-rwapply-replace-regs (nth 1 expr)))
X+ (tail (math-rwapply-replace-regs (nth 2 expr))))
X+ (if (math-vectorp head)
X+ (append head (list tail))
X+ (list 'calcFunc-rcons head tail))))
X ((and (eq (car expr) 'neg)
X (math-rwapply-reg-looks-negp (nth 1 expr)))
X (math-rwapply-reg-neg (nth 1 expr)))
X***************
X*** 19620,19670 ****
X ;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears
X ;;; in lhs but not in rhs or rhs'; return rhs'.
X ;;; Uses global values: solve-*.
X! (defun math-try-solve-for (lhs rhs &optional sign)
X (let (t1 t2 t3)
X (cond ((equal lhs solve-var)
X (setq math-solve-sign sign)
X! rhs)
X ((Math-primp lhs)
X nil)
X! ((setq t2 (math-polynomial-base
X! lhs
X! (function (lambda (b)
X! (and (setq t1 (math-is-polynomial lhs b 2))
X! (math-expr-depends b solve-var)
X! (not (equal b lhs)))))))
X! (if (cdr (cdr t1))
X! (math-try-solve-for
X! t2
X! (if (math-looks-evenp (nth 1 t1))
X! (let ((halfb (math-div (nth 1 t1) 2)))
X! (math-div
X! (math-add
X! (math-neg halfb)
X! (math-solve-get-sign
X! (math-normalize
X! (list 'calcFunc-sqrt
X! (math-add (math-sqr halfb)
X! (math-mul (math-sub rhs (car t1))
X! (nth 2 t1)))))))
X! (nth 2 t1)))
X! (math-div
X! (math-add
X! (math-neg (nth 1 t1))
X! (math-solve-get-sign
X! (math-normalize
X! (list 'calcFunc-sqrt
X! (math-add (math-sqr (nth 1 t1))
X! (math-mul 4
X! (math-mul (math-sub rhs
X! (car t1))
X! (nth 2 t1))))))))
X! (math-mul 2 (nth 2 t1)))))
X! (and (cdr t1)
X! (math-try-solve-for t2
X! (math-div (math-sub rhs (car t1))
X! (nth 1 t1))
X! (math-solve-sign sign (nth 1 t1))))))
X ((eq (car lhs) '+)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X--- 20161,20217 ----
X ;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears
X ;;; in lhs but not in rhs or rhs'; return rhs'.
X ;;; Uses global values: solve-*.
X! (defun math-try-solve-for (lhs rhs &optional sign no-poly)
X (let (t1 t2 t3)
X (cond ((equal lhs solve-var)
X (setq math-solve-sign sign)
X! (if (eq solve-full 'all)
X! (let ((vec (list 'vec (math-evaluate-expr rhs)))
X! newvec var p)
X! (while math-solve-ranges
X! (setq p (car math-solve-ranges)
X! var (car p)
X! newvec (list 'vec))
X! (while (setq p (cdr p))
X! (setq newvec (nconc newvec
X! (cdr (math-expr-subst
X! vec var (car p))))))
X! (setq vec newvec
X! math-solve-ranges (cdr math-solve-ranges)))
X! (math-normalize vec))
X! rhs))
X ((Math-primp lhs)
X nil)
X! ((and
X! (not no-poly)
X! (setq t3 '(1 0)
X! t2 (math-polynomial-base
X! lhs
X! (function (lambda (b)
X! (and (setq t1 (math-is-polynomial lhs b 50))
X! (setq t1 (cons (math-sub (car t1) rhs)
X! (cdr t1)))
X! (math-solve-crunch-poly 4)
X! (math-expr-depends b solve-var)
X! (not (equal b lhs))))))))
X! (setq t1 (let ((math-solve-ranges math-solve-ranges))
X! (cond
X! ((= (length t1) 5)
X! (apply 'math-solve-quartic (math-pow t2 (car t3)) t1))
X! ((= (length t1) 4)
X! (apply 'math-solve-cubic (math-pow t2 (car t3)) t1))
X! ((= (length t1) 3)
X! (apply 'math-solve-quadratic
X! (math-pow t2 (car t3)) t1))
X! ((= (length t1) 2)
X! (apply 'math-solve-linear
X! (math-pow t2 (car t3)) sign t1))
X! (t nil))))
X! (if (and (> (nth 1 t3) 0))
X! (math-solve-prod t1
X! (math-try-solve-for (math-pow t2 (nth 1 t3))
X! 0 nil t))
X! t1))
X ((eq (car lhs) '+)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X***************
X*** 19694,19700 ****
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X (math-div rhs (nth 2 lhs))
X! (math-solve-sign sign (nth 2 lhs))))))
X ((eq (car lhs) '/)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X--- 20241,20251 ----
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X (math-div rhs (nth 2 lhs))
X! (math-solve-sign sign (nth 2 lhs))))
X! ((Math-zerop rhs)
X! (math-solve-prod (let ((math-solve-ranges math-solve-ranges))
X! (math-try-solve-for (nth 2 lhs) 0))
X! (math-try-solve-for (nth 1 lhs) 0)))))
X ((eq (car lhs) '/)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X***************
X*** 19704,19727 ****
X (math-try-solve-for (nth 1 lhs)
X (math-mul rhs (nth 2 lhs))
X (math-solve-sign sign (nth 2 lhs))))
X! ((and (setq t1 (math-is-polynomial (nth 1 lhs) solve-var 2))
X! (setq t2 (math-is-polynomial (nth 2 lhs) solve-var 2)))
X! (math-try-solve-for (math-build-polynomial-expr
X! (math-poly-mix t2 rhs t1 -1)
X! solve-var)
X! 0))
X! ((setq t3 (math-polynomial-base
X! (nth 1 lhs)
X! (function (lambda (b)
X! (and (math-expr-depends b solve-var)
X! (setq t1 (math-is-polynomial
X! (nth 1 lhs) b 2))
X! (setq t2 (math-is-polynomial
X! (nth 2 lhs) b 2)))))))
X! (math-try-solve-for (math-build-polynomial-expr
X! (math-poly-mix t2 rhs t1 -1)
X! t3)
X! 0))))
X ((eq (car lhs) '^)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for
X--- 20255,20265 ----
X (math-try-solve-for (nth 1 lhs)
X (math-mul rhs (nth 2 lhs))
X (math-solve-sign sign (nth 2 lhs))))
X! ((setq t1 (math-try-solve-for (math-sub (nth 1 lhs)
X! (math-mul (nth 2 lhs)
X! rhs))
X! 0))
X! t1)))
X ((eq (car lhs) '^)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for
X***************
SHAR_EOF
echo "End of part 2, continue with part 3"
echo "3" > s2_seq_.tmp
exit 0
--
Dave Gillespie
256-80 Caltech Pasadena CA USA 91125
daveg@csvax.cs.caltech.edu, ...!cit-vax!daveg