daveg@csvax.cs.caltech.edu (David Gillespie) (10/15/90)
Posting-number: Volume 15, Issue 34
Submitted-by: daveg@csvax.cs.caltech.edu (David Gillespie)
Archive-name: calc-1.05/part07
#!/bin/sh
# this is part 7 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc.patch continued
#
CurArch=7
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+ which correspond to zeros in mask are deleted. The length of the
X+ result vector is the number of nonzero elements of the mask."
X+ (interactive "P")
X+ (calc-wrapper
X+ (calc-binary-op "vmsk" 'calcFunc-vmask arg))
X+ )
X+
X+ (defun calc-expand-vector (arg)
X+ "Expand a vector according to a mask vector.
X+ Vector is in top of stack, mask is in second-to-top.
X+ The result is a vector of the same length as mask. Each nonzero element
X+ of mask is replaced by the next element of vec. If vec has more elements
X+ than mask has nonzero elements, some are omitted. If vec has fewer
X+ elements, the last few nonzero elements of mask are left the same.
X+ With Hyperbolic flag, top-of-stack is a filler element which is used
X+ instead of zero for zero mask elements; vector and mask are in stack
X+ levels two and three."
X+ (interactive "P")
X+ (calc-wrapper
X+ (if (calc-is-hyperbolic)
X+ (calc-enter-result 3 "vexp" (cons 'calcFunc-vexp (calc-top-list-n 3)))
X+ (calc-binary-op "vexp" 'calcFunc-vexp arg)))
X+ )
X+
X (defun calc-sort ()
X "Sort the matrix at top of stack into increasing order.
X! With Inverse flag, sort into decreasing order.
X! With Hyperbolic flag, return a permutation vector which would sort the input."
X (interactive)
X (calc-slow-wrapper
X (if (calc-is-inverse)
X***************
X*** 4292,4297 ****
X--- 7907,7922 ----
X (calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1)))))
X )
X
X+ (defun calc-grade ()
X+ "Grade the matrix at top of stack into increasing order.
X+ This produces a permutation vector which would sort the input."
X+ (interactive)
X+ (calc-slow-wrapper
X+ (if (calc-is-inverse)
X+ (calc-enter-result 1 "rgrd" (list 'calcFunc-rgrade (calc-top-n 1)))
X+ (calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1)))))
X+ )
X+
X (defun calc-histogram (n)
X "Compile a histogram of a vector of integers in the range [0..N).
X N is the numeric prefix argument.
X***************
X*** 4375,4410 ****
X (calc-unary-op "cnrm" 'calcFunc-cnorm arg))
X )
X
X! (defun calc-mrow (n)
X "Replace matrix at top of stack with its Nth row.
X Numeric prefix N must be between 1 and the height of the matrix.
X If top of stack is a non-matrix vector, extract its Nth element.
X If N is negative, remove the Nth row (or element)."
X! (interactive "NRow number: ")
X (calc-wrapper
X! (setq n (prefix-numeric-value n))
X! (if (= n 0)
X! (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1)))
X! (if (< n 0)
X! (calc-enter-result 1 "rrow" (list 'calcFunc-mrrow
X! (calc-top-n 1) (- n)))
X! (calc-enter-result 1 "mrow" (list 'calcFunc-mrow (calc-top-n 1) n)))))
X )
X
X! (defun calc-mcol (n)
X "Replace matrix at top of stack with its Nth column.
X Numeric prefix N must be between 1 and the width of the matrix.
X If top of stack is a non-matrix vector, extract its Nth element.
X If N is negative, remove the Nth column (or element)."
X! (interactive "NColumn number: ")
X (calc-wrapper
X! (setq n (prefix-numeric-value n))
X! (if (= n 0)
X! (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1)))
X! (if (< n 0)
X! (calc-enter-result 1 "rcol" (list 'calcFunc-mrcol
X! (calc-top-n 1) (- n)))
X! (calc-enter-result 1 "mcol" (list 'calcFunc-mcol (calc-top-n 1) n)))))
X )
X
X ;;;; [calc-map.el]
X--- 8000,8041 ----
X (calc-unary-op "cnrm" 'calcFunc-cnorm arg))
X )
X
X! (defun calc-mrow (n &optional nn)
X "Replace matrix at top of stack with its Nth row.
X Numeric prefix N must be between 1 and the height of the matrix.
X If top of stack is a non-matrix vector, extract its Nth element.
X If N is negative, remove the Nth row (or element)."
X! (interactive "NRow number: \nP")
X (calc-wrapper
X! (if (consp nn)
X! (calc-enter-result 2 "mrow" (cons 'calcFunc-mrow (calc-top-list-n 2)))
X! (setq n (prefix-numeric-value n))
X! (if (= n 0)
X! (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1)))
X! (if (< n 0)
X! (calc-enter-result 1 "rrow" (list 'calcFunc-mrrow
X! (calc-top-n 1) (- n)))
X! (calc-enter-result 1 "mrow" (list 'calcFunc-mrow
X! (calc-top-n 1) n))))))
X )
X
X! (defun calc-mcol (n &optional nn)
X "Replace matrix at top of stack with its Nth column.
X Numeric prefix N must be between 1 and the width of the matrix.
X If top of stack is a non-matrix vector, extract its Nth element.
X If N is negative, remove the Nth column (or element)."
X! (interactive "NColumn number: \nP")
X (calc-wrapper
X! (if (consp nn)
X! (calc-enter-result 2 "mcol" (cons 'calcFunc-mcol (calc-top-list-n 2)))
X! (setq n (prefix-numeric-value n))
X! (if (= n 0)
X! (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1)))
X! (if (< n 0)
X! (calc-enter-result 1 "rcol" (list 'calcFunc-mrcol
X! (calc-top-n 1) (- n)))
X! (calc-enter-result 1 "mcol" (list 'calcFunc-mcol
X! (calc-top-n 1) n))))))
X )
X
X ;;;; [calc-map.el]
X***************
X*** 4414,4420 ****
X For example, applying f to [1, 2, 3] produces f(1, 2, 3)."
X (interactive)
X (calc-wrapper
X! (let* ((calc-dollar-values (mapcar 'car-safe
X (nthcdr calc-stack-top calc-stack)))
X (calc-dollar-used 0)
X (oper (or oper (calc-get-operator "Apply"
X--- 8045,8052 ----
X For example, applying f to [1, 2, 3] produces f(1, 2, 3)."
X (interactive)
X (calc-wrapper
X! (let* ((sel-mode nil)
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 "Apply"
X***************
X*** 4433,4452 ****
X
X (defun calc-reduce (&optional oper)
X "Apply a binary operator across all elements of a vector.
X! For example, applying + computes the sum of vector elements."
X (interactive)
X (calc-wrapper
X! (let* ((calc-dollar-values (mapcar 'car-safe
X (nthcdr calc-stack-top calc-stack)))
X (calc-dollar-used 0)
X! (oper (or oper (calc-get-operator "Reduce" 2))))
X (message "Working...")
X (calc-set-command-flag 'clear-message)
X (calc-enter-result (1+ calc-dollar-used)
X! (concat (substring "red" 0 (- 4 (length (nth 2 oper))))
X (nth 2 oper))
X! (list (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--- 8065,8091 ----
X
X (defun calc-reduce (&optional oper)
X "Apply a binary operator across all elements of a vector.
X! For example, applying + computes the sum of vector elements.
X! With Hyperbolic flag, accumulate intermediate results into a vector."
X (interactive)
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 (calc-enter-result (1+ calc-dollar-used)
X! (concat (substring (if accum "acc" "red")
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*** 4456,4462 ****
X For example, applying * computes a vector of products."
X (interactive)
X (calc-wrapper
X! (let* ((calc-dollar-values (mapcar 'car-safe
X (nthcdr calc-stack-top calc-stack)))
X (calc-dollar-used 0)
X (oper (or oper (calc-get-operator "Map")))
X--- 8095,8102 ----
X For example, applying * computes a vector of products."
X (interactive)
X (calc-wrapper
X! (let* ((sel-mode nil)
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 "Map")))
X***************
X*** 4477,4493 ****
X (1+ calc-dollar-used)))))))
X )
X
X ;;; Return a list of the form (nargs func name)
X (defun calc-get-operator (msg &optional nargs)
X (let ((inv nil) (hyp nil) (prefix nil)
X done key oper (which 0)
X (msgs '( "(Press ? for help)"
X! "+, -, *, /, ^, %, \\, :, !, |, Neg"
X "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt"
X "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB"
X! "Binary + And, Or, Xor, Diff; Not, Clip"
X "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction"
X! "Kombinatorics + Dfact, Lcm, Gcd, Binomial, Perms; Random"
X "Matrix-dir + Elements, Rows, Cols, Across, Down"
X "X or Z = any function by name; ' = alg entry; $ = stack")))
X (while (not done)
X--- 8117,8181 ----
X (1+ calc-dollar-used)))))))
X )
X
X+ (defun calc-outer-product (&optional oper)
X+ "Compute the generalized outer product of two vectors.
X+ For example, using * produces a multiplication table."
X+ (interactive)
X+ (calc-wrapper
X+ (let* ((sel-mode nil)
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 "Outer" 2))))
X+ (message "Working...")
X+ (calc-set-command-flag 'clear-message)
X+ (calc-enter-result (+ 2 calc-dollar-used)
X+ (concat (substring "out" 0 (- 4 (length (nth 2 oper))))
X+ (nth 2 oper))
X+ (cons 'calcFunc-outer
X+ (cons (math-calcFunc-to-var (nth 1 oper))
X+ (calc-top-list-n
X+ 2 (1+ calc-dollar-used)))))))
X+ )
X+
X+ (defun calc-inner-product (&optional mul-oper add-oper)
X+ "Compute the generalized inner product of two vectors or matrices.
X+ You specify the multiplicative and additive operators or functions to use.
X+ For example, using * and + respectively does a matrix multiplication."
X+ (interactive)
X+ (calc-wrapper
X+ (let* ((sel-mode nil)
X+ (calc-dollar-values (mapcar 'calc-get-stack-element
X+ (nthcdr calc-stack-top calc-stack)))
X+ (calc-dollar-used 0)
X+ (mul-oper (or mul-oper (calc-get-operator "Inner (Mult)" 2)))
X+ (add-oper (or add-oper (calc-get-operator "Inner (Add)" 2))))
X+ (message "Working...")
X+ (calc-set-command-flag 'clear-message)
X+ (calc-enter-result (+ 2 calc-dollar-used)
X+ (concat "in"
X+ (substring (nth 2 mul-oper) 0 1)
X+ (substring (nth 2 add-oper) 0 1))
X+ (nconc (list 'calcFunc-inner
X+ (math-calcFunc-to-var (nth 1 mul-oper))
X+ (math-calcFunc-to-var (nth 1 add-oper)))
X+ (calc-top-list-n 2 (1+ calc-dollar-used))))))
X+ )
X+
X ;;; Return a list of the form (nargs func name)
X (defun calc-get-operator (msg &optional nargs)
X (let ((inv nil) (hyp nil) (prefix nil)
X done key oper (which 0)
X (msgs '( "(Press ? for help)"
X! "+, -, *, /, ^, %, \\, :, &, !, |, Neg"
X "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt"
X "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB"
X! "Algebra + Simp, Esimp, Deriv, Integ, !, =, etc."
X! "Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip"
X "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction"
X! "Functions + Re, Im; Hypot; Mant, Expon, Scale; etc."
X! "Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc."
X! "Vectors + Length, Row, Col, Diag, Mask, etc."
X "Matrix-dir + Elements, Rows, Cols, Across, Down"
X "X or Z = any function by name; ' = alg entry; $ = stack")))
X (while (not done)
X***************
X*** 4506,4522 ****
X (keyboard-quit))
X ((= key ??)
X (setq which (% (1+ which) (length msgs))))
X! ((= key ?I)
X! (setq inv (not inv)
X! prefix nil))
X! ((= key ?H)
X! (setq hyp (not hyp)
X! prefix nil))
X ((eq key prefix)
X (setq prefix nil))
X! ((and (memq key '(?b ?c ?k ?m)) (null prefix))
X! (setq inv nil hyp nil
X! prefix key))
X ((eq prefix ?m)
X (setq prefix nil)
X (if (eq key ?e)
X--- 8194,8207 ----
X (keyboard-quit))
X ((= key ??)
X (setq which (% (1+ which) (length msgs))))
X! ((and (= key ?I) (null prefix))
X! (setq inv (not inv)))
X! ((and (= key ?H) (null prefix))
X! (setq hyp (not hyp)))
X ((eq key prefix)
X (setq prefix nil))
X! ((and (memq key '(?a ?b ?c ?f ?k ?m ?v ?V)) (null prefix))
X! (setq prefix (downcase key)))
X ((eq prefix ?m)
X (setq prefix nil)
X (if (eq key ?e)
X***************
X*** 4562,4576 ****
X arglist)
X expr))
X done t))))
X! ((setq oper (assq key (cond ((eq prefix ?b) calc-b-oper-keys)
X! ((eq prefix ?c) calc-c-oper-keys)
X! ((eq prefix ?k) calc-k-oper-keys)
X! (inv (if hyp
X! calc-inv-hyp-oper-keys
X! calc-inv-oper-keys))
X! (t (if hyp
X! calc-hyp-oper-keys
X! calc-oper-keys)))))
X (if (eq (nth 1 oper) 'user)
X (let ((func (intern
X (completing-read "Function name: "
X--- 8247,8260 ----
X arglist)
X expr))
X done t))))
X! ((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0))
X! (cond ((eq prefix ?a) calc-a-oper-keys)
X! ((eq prefix ?b) calc-b-oper-keys)
X! ((eq prefix ?c) calc-c-oper-keys)
X! ((eq prefix ?f) calc-f-oper-keys)
X! ((eq prefix ?k) calc-k-oper-keys)
X! ((eq prefix ?v) calc-v-oper-keys)
X! (t calc-oper-keys)))))
X (if (eq (nth 1 oper) 'user)
X (let ((func (intern
X (completing-read "Function name: "
X***************
X*** 4612,4703 ****
X (error "Must be a %d-argument operator" nargs))
X (append (cdr oper)
X (list
X! (concat (if prefix (char-to-string prefix) "")
X! (if inv "I" "") (if hyp "H" "")
X! (char-to-string key)))))
X! )
X!
X! (defconst calc-oper-keys '( ( ?+ 2 calcFunc-add )
X! ( ?- 2 calcFunc-sub )
X! ( ?* 2 calcFunc-mul )
X! ( ?/ 2 calcFunc-div )
X! ( ?^ 2 calcFunc-pow )
X! ( ?| 2 calcFunc-vconcat )
X! ( ?% 2 calcFunc-mod )
X! ( ?\\ 2 calcFunc-idiv )
X! ( ?: 2 calcFunc-fdiv )
X! ( ?! 1 calcFunc-fact )
X! ( ?n 1 calcFunc-neg )
X! ( ?x user )
X! ( ?z user )
X! ( ?A 1 calcFunc-abs )
X! ( ?J 1 calcFunc-conj )
X! ( ?G 1 calcFunc-arg )
X! ( ?Q 1 calcFunc-sqrt )
X! ( ?N 2 calcFunc-min )
X! ( ?X 2 calcFunc-max )
X! ( ?F 1 calcFunc-floor )
X! ( ?R 1 calcFunc-round )
X! ( ?S 1 calcFunc-sin )
X! ( ?C 1 calcFunc-cos )
X! ( ?T 1 calcFunc-tan )
X! ( ?L 1 calcFunc-ln )
X! ( ?E 1 calcFunc-exp )
X! ( ?B 2 calcFunc-log )
X! ))
X! (defconst calc-b-oper-keys '( ( ?a 2 calcFunc-and )
X! ( ?o 2 calcFunc-or )
X! ( ?x 2 calcFunc-xor )
X! ( ?d 2 calcFunc-diff )
X! ( ?n 1 calcFunc-not )
X! ( ?c 1 calcFunc-clip )
X! ( ?l 2 calcFunc-lsh )
X! ( ?r 2 calcFunc-rsh )
X! ( ?L 2 calcFunc-ash )
X! ( ?R 2 calcFunc-rash )
X! ( ?t 2 calcFunc-rot )
X! ))
X! (defconst calc-c-oper-keys '( ( ?d 1 calcFunc-deg )
X! ( ?r 1 calcFunc-rad )
X! ( ?h 1 calcFunc-hms )
X! ( ?f 1 calcFunc-float )
X! ( ?F 1 calcFunc-frac )
X! ))
X! (defconst calc-k-oper-keys '( ( ?g 2 calcFunc-gcd )
X! ( ?l 2 calcFunc-lcm )
X! ( ?b 2 calcFunc-choose )
X! ( ?d 1 calcFunc-dfact )
X! ( ?m 1 calcFunc-moebius )
X! ( ?p 2 calcFunc-perm )
X! ( ?r 1 calcFunc-random )
X! ( ?t 1 calcFunc-totient )
X! ))
X! (defconst calc-inv-oper-keys '( ( ?F 1 calcFunc-ceil )
X! ( ?R 1 calcFunc-trunc )
X! ( ?Q 1 calcFunc-sqr )
X! ( ?S 1 calcFunc-arcsin )
X! ( ?C 1 calcFunc-arccos )
X! ( ?T 1 calcFunc-arctan )
X! ( ?L 1 calcFunc-exp )
X! ( ?E 1 calcFunc-ln )
X! ))
X! (defconst calc-hyp-oper-keys '( ( ?F 1 calcFunc-ffloor )
X! ( ?R 1 calcFunc-fround )
X! ( ?S 1 calcFunc-sinh )
X! ( ?C 1 calcFunc-cosh )
X! ( ?T 1 calcFunc-tanh )
X! ( ?L 1 calcFunc-log10 )
X! ( ?E 1 calcFunc-exp10 )
X! ))
X! (defconst calc-inv-hyp-oper-keys '( ( ?F 1 calcFunc-fceil )
X! ( ?R 1 calcFunc-ftrunc )
X! ( ?S 1 calcFunc-arcsinh )
X! ( ?C 1 calcFunc-arccosh )
X! ( ?T 1 calcFunc-arctanh )
X! ( ?L 1 calcFunc-exp10 )
X! ( ?E 1 calcFunc-log10 )
X! ))
X!
X
X
X
X--- 8296,8488 ----
X (error "Must be a %d-argument operator" nargs))
X (append (cdr oper)
X (list
X! (let ((name (concat (if inv "I" "") (if hyp "H" "")
X! (if prefix (char-to-string prefix) "")
X! (char-to-string key))))
X! (if (> (length name) 3)
X! (substring name 0 3)
X! name)))))
X! )
X!
X! (defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add )
X! ( ?- 2 calcFunc-sub )
X! ( ?* 2 calcFunc-mul )
X! ( ?/ 2 calcFunc-div )
X! ( ?^ 2 calcFunc-pow )
X! ( ?| 2 calcFunc-vconcat )
X! ( ?% 2 calcFunc-mod )
X! ( ?\\ 2 calcFunc-idiv )
X! ( ?: 2 calcFunc-fdiv )
X! ( ?! 1 calcFunc-fact )
X! ( ?& 1 calcFunc-inv )
X! ( ?n 1 calcFunc-neg )
X! ( ?x user )
X! ( ?z user )
X! ( ?A 1 calcFunc-abs )
X! ( ?J 1 calcFunc-conj )
X! ( ?G 1 calcFunc-arg )
X! ( ?Q 1 calcFunc-sqrt )
X! ( ?N 2 calcFunc-min )
X! ( ?X 2 calcFunc-max )
X! ( ?F 1 calcFunc-floor )
X! ( ?R 1 calcFunc-round )
X! ( ?S 1 calcFunc-sin )
X! ( ?C 1 calcFunc-cos )
X! ( ?T 1 calcFunc-tan )
X! ( ?L 1 calcFunc-ln )
X! ( ?E 1 calcFunc-exp )
X! ( ?B 2 calcFunc-log ) )
X! ( ( ?F 1 calcFunc-ceil ) ; inverse
X! ( ?R 1 calcFunc-trunc )
X! ( ?Q 1 calcFunc-sqr )
X! ( ?S 1 calcFunc-arcsin )
X! ( ?C 1 calcFunc-arccos )
X! ( ?T 1 calcFunc-arctan )
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! ( ?C 1 calcFunc-cosh )
X! ( ?T 1 calcFunc-tanh )
X! ( ?L 1 calcFunc-log10 )
X! ( ?E 1 calcFunc-exp10 ) )
X! ( ( ?F 1 calcFunc-fceil ) ; inverse-hyperbolic
X! ( ?R 1 calcFunc-ftrunc )
X! ( ?S 1 calcFunc-arcsinh )
X! ( ?C 1 calcFunc-arccosh )
X! ( ?T 1 calcFunc-arctanh )
X! ( ?L 1 calcFunc-exp10 )
X! ( ?E 1 calcFunc-log10 ) )
X! ))
X! (defconst calc-a-oper-keys '( ( ( ?s 1 calcFunc-simplify )
X! ( ?e 1 calcFunc-esimplify )
X! ( ?d 2 calcFunc-deriv )
X! ( ?i 2 calcFunc-integ )
X! ( ?S 2 calcFunc-solve )
X! ( ?= 2 calcFunc-eq )
X! ( ?\# 2 calcFunc-neq )
X! ( ?< 2 calcFunc-lt )
X! ( ?> 2 calcFunc-gt )
X! ( ?\[ 2 calcFunc-leq )
X! ( ?\] 2 calcFunc-geq )
X! ( ?{ 2 calcFunc-in )
X! ( ?! 1 calcFunc-lnot )
X! ( ?& 2 calcFunc-land )
X! ( ?\| 2 calcFunc-lor )
X! ( ?: 3 calcFunc-if ) )
X! ( ( ?S 2 calcFunc-finv ) )
X! ( ( ?S 2 calcFunc-fsolve ) )
X! ( ( ?S 2 calcFunc-ffinv ) )
X! ))
X! (defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and )
X! ( ?o 2 calcFunc-or )
X! ( ?x 2 calcFunc-xor )
X! ( ?d 2 calcFunc-diff )
X! ( ?n 1 calcFunc-not )
X! ( ?c 1 calcFunc-clip )
X! ( ?l 2 calcFunc-lsh )
X! ( ?r 2 calcFunc-rsh )
X! ( ?L 2 calcFunc-ash )
X! ( ?R 2 calcFunc-rash )
X! ( ?t 2 calcFunc-rot ) )
X! ))
X! (defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg )
X! ( ?r 1 calcFunc-rad )
X! ( ?h 1 calcFunc-hms )
X! ( ?f 1 calcFunc-float )
X! ( ?F 1 calcFunc-frac ) )
X! ))
X! (defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta )
X! ( ?e 1 calcFunc-erf )
X! ( ?g 1 calcFunc-gamma )
X! ( ?h 2 calcFunc-hypot )
X! ( ?i 1 calcFunc-im )
X! ( ?j 2 calcFunc-besJ )
X! ( ?n 2 calcFunc-min )
X! ( ?r 1 calcFunc-re )
X! ( ?s 1 calcFunc-sign )
X! ( ?x 2 calcFunc-max )
X! ( ?y 2 calcFunc-besY )
X! ( ?A 1 calcFunc-abssqr )
X! ( ?B 3 calcFunc-betaI )
X! ( ?E 1 calcFunc-expm1 )
X! ( ?G 2 calcFunc-gammaP )
X! ( ?I 2 calcFunc-ilog )
X! ( ?L 1 calcFunc-lnp1 )
X! ( ?M 1 calcFunc-mant )
X! ( ?Q 1 calcFunc-isqrt )
X! ( ?S 1 calcFunc-scf )
X! ( ?T 2 calcFunc-arctan2 )
X! ( ?X 1 calcFunc-xpon )
X! ( ?\[ 2 calcFunc-decr )
X! ( ?\] 2 calcFunc-incr ) )
X! ( ( ?e 1 calcFunc-erfc )
X! ( ?E 1 calcFunc-lnp1 )
X! ( ?G 2 calcFunc-gammaQ )
X! ( ?L 1 calcFunc-expm1 ) )
X! ( ( ?B 3 calcFunc-betaB )
X! ( ?G 2 calcFunc-gammag) )
X! ( ( ?G 2 calcFunc-gammaG ) )
X! ))
X! (defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern )
X! ( ?c 2 calcFunc-choose )
X! ( ?d 1 calcFunc-dfact )
X! ( ?e 1 calcFunc-euler )
X! ( ?f 1 calcFunc-prfac )
X! ( ?g 2 calcFunc-gcd )
X! ( ?h 2 calcFunc-shuffle )
X! ( ?l 2 calcFunc-lcm )
X! ( ?m 1 calcFunc-moebius )
X! ( ?n 1 calcFunc-nextprime )
X! ( ?r 1 calcFunc-random )
X! ( ?s 2 calcFunc-stir1 )
X! ( ?t 1 calcFunc-totient )
X! ( ?B 3 calcFunc-utpb )
X! ( ?C 2 calcFunc-utpc )
X! ( ?F 3 calcFunc-utpf )
X! ( ?N 3 calcFunc-utpn )
X! ( ?P 2 calcFunc-utpp )
X! ( ?T 2 calcFunc-utpt ) )
X! ( ( ?n 1 calcFunc-prevprime )
X! ( ?B 3 calcFunc-ltpb )
X! ( ?C 2 calcFunc-ltpc )
X! ( ?F 3 calcFunc-ltpf )
X! ( ?N 3 calcFunc-ltpn )
X! ( ?P 2 calcFunc-ltpp )
X! ( ?T 2 calcFunc-ltpt ) )
X! ( ( ?b 2 calcFunc-bern )
X! ( ?c 2 calcFunc-perm )
X! ( ?e 2 calcFunc-euler )
X! ( ?s 2 calcFunc-stir2 ) )
X! ))
X! (defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange )
X! ( ?b 2 calcFunc-cvec )
X! ( ?c 2 calcFunc-mcol )
X! ( ?d 2 calcFunc-diag )
X! ( ?e 2 calcFunc-vexp )
X! ( ?f 2 calcFunc-find )
X! ( ?l 1 calcFunc-vlen )
X! ( ?m 2 calcFunc-vmask )
X! ( ?n 1 calcFunc-rnorm )
X! ( ?r 2 calcFunc-mrow )
X! ( ?s 3 calcFunc-subvec )
X! ( ?t 1 calcFunc-trn )
X! ( ?x 1 calcFunc-index )
X! ( ?D 1 calcFunc-det )
X! ( ?C 1 calcFunc-cross )
X! ( ?G 1 calcFunc-grade )
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! ))
X
X
X
X***************
X*** 4918,4923 ****
X--- 8703,8709 ----
X "Leave it symbolic for non-constant arguments? ")))
X (if cmd
X (progn
X+ (calc-need-macros)
X (fset cmd
X (list 'lambda
X '()
X***************
X*** 4959,4965 ****
X (if (consp form)
X (if (eq (car form) 'var)
X (if (or (memq (nth 1 form) arglist)
X! (boundp (nth 2 form)))
X ()
X (setq arglist (cons (nth 1 form) arglist)))
X (calc-default-formula-arglist-step (cdr form))))
X--- 8745,8751 ----
X (if (consp form)
X (if (eq (car form) 'var)
X (if (or (memq (nth 1 form) arglist)
X! (calc-var-value (nth 2 form)))
X ()
X (setq arglist (cons (nth 1 form) arglist)))
X (calc-default-formula-arglist-step (cdr form))))
X***************
X*** 5030,5036 ****
X '(arg)
X '(interactive "P")
X (list 'calc-execute-kbd-macro
X! last-kbd-macro
X 'arg))))
X (let* ((kmap (calc-user-key-map))
X (old (assq key kmap)))
X--- 8816,8823 ----
X '(arg)
X '(interactive "P")
X (list 'calc-execute-kbd-macro
X! (vector (key-description last-kbd-macro)
X! last-kbd-macro)
X 'arg))))
X (let* ((kmap (calc-user-key-map))
X (old (assq key kmap)))
X***************
X*** 5075,5095 ****
X (lambda (cmd)
X (if (stringp (symbol-function cmd))
X (symbol-function cmd)
X! (nth 1 (nth 3 (symbol-function cmd))))))
X (function
X (lambda (new cmd)
X (if (stringp (symbol-function cmd))
X (fset cmd new)
X! (setcar (cdr (nth 3 (symbol-function
X! cmd)))
X! new))))))
X! (calc-wrapper
X! (calc-edit-mode (list 'calc-finish-macro-edit
X! (list 'quote def)))
X! (insert (if (stringp cmd)
X! cmd
X! (nth 1 (nth 3 cmd)))))
X! (calc-show-edit-buffer)))
X (t (let* ((func (calc-stack-command-p cmd))
X (defn (and func
X (symbolp func)
X--- 8862,8919 ----
X (lambda (cmd)
X (if (stringp (symbol-function cmd))
X (symbol-function cmd)
X! (let ((mac (nth 1 (nth 3 (symbol-function
X! cmd)))))
X! (if (vectorp mac)
X! (aref mac 1)
X! mac)))))
X (function
X (lambda (new cmd)
X (if (stringp (symbol-function cmd))
X (fset cmd new)
X! (let ((mac (cdr (nth 3 (symbol-function
X! cmd)))))
X! (if (vectorp (car mac))
X! (progn
X! (aset (car mac) 0
X! (key-description new))
X! (aset (car mac) 1 new))
X! (setcar mac new))))))))
X! (let ((keys (progn (and (fboundp 'edit-kbd-macro)
X! (edit-kbd-macro nil))
X! (fboundp 'MacEdit-parse-keys))))
X! (calc-wrapper
X! (calc-edit-mode (list 'calc-finish-macro-edit
X! (list 'quote def)
X! keys)
X! t)
X! (if keys
X! (let (top
X! (fill-column 70)
X! (fill-prefix nil))
X! (insert "Notations: RET, SPC, TAB, DEL, LFD, NUL"
X! ", C-xxx, M-xxx.\n\n")
X! (setq top (point))
X! (insert (if (stringp cmd)
X! (key-description cmd)
X! (if (vectorp (nth 1 (nth 3 cmd)))
X! (aref (nth 1 (nth 3 cmd)) 0)
X! (key-description (nth 1 (nth 3 cmd)))))
X! "\n")
X! (if (>= (prog2 (forward-char -1)
X! (current-column)
X! (forward-char 1))
X! (screen-width))
X! (fill-region top (point))))
X! (insert "Press C-q to quote control characters like RET"
X! " and TAB.\n"
X! (if (stringp cmd)
X! cmd
X! (if (vectorp (nth 1 (nth 3 cmd)))
X! (aref (nth 1 (nth 3 cmd)) 1)
X! (nth 1 (nth 3 cmd)))))))
X! (calc-show-edit-buffer)
X! (forward-line (if keys 2 1)))))
X (t (let* ((func (calc-stack-command-p cmd))
X (defn (and func
X (symbolp func)
X***************
X*** 5099,5115 ****
X (calc-wrapper
X (calc-edit-mode (list 'calc-finish-formula-edit
X (list 'quote func)))
X! (insert (math-format-flat-expr defn 0) "\n"))
X (calc-show-edit-buffer))
X (error "That command's definition cannot be edited"))))))
X )
X
X! (defun calc-finish-macro-edit (def)
X! (let ((str (buffer-substring (point) (point-max))))
X (if (symbolp (cdr def))
X (if (stringp (symbol-function (cdr def)))
X (fset (cdr def) str)
X! (setcar (cdr (nth 3 (symbol-function (cdr def)))) str))
X (setcdr def str)))
X )
X
X--- 8923,8949 ----
X (calc-wrapper
X (calc-edit-mode (list 'calc-finish-formula-edit
X (list 'quote func)))
X! (insert (math-format-nice-expr defn (screen-width))
X! "\n"))
X (calc-show-edit-buffer))
X (error "That command's definition cannot be edited"))))))
X )
X
X! (defun calc-finish-macro-edit (def keys)
X! (forward-line 1)
X! (if (and keys (looking-at "\n")) (forward-line 1))
X! (let* ((true-str (buffer-substring (point) (point-max)))
X! (str true-str))
X! (if keys (setq str (MacEdit-parse-keys str)))
X (if (symbolp (cdr def))
X (if (stringp (symbol-function (cdr def)))
X (fset (cdr def) str)
X! (let ((mac (cdr (nth 3 (symbol-function (cdr def))))))
X! (if (vectorp (car mac))
X! (progn
X! (aset (car mac) 0 (if keys true-str (key-description str)))
X! (aset (car mac) 1 str))
X! (setcar mac str))))
X (setcdr def str)))
X )
X
X***************
X*** 5191,5197 ****
X (insert "\"\n"))))
X )
X (put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
X- (put 'calc-dollar-sign 'MacEdit-print 'calc-macro-edit-algebraic)
X
X (defun calc-macro-edit-variable ()
X (let ((str "") ch)
X--- 9025,9030 ----
X***************
X*** 5285,5300 ****
X (let* ((cmd (cdr def))
X (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
X (pt (point))
X! (fill-column 70))
X (if (and fcmd
X (eq (car-safe fcmd) 'lambda)
X (get cmd 'calc-user-defn))
X (progn
X! (insert (prin1-to-string
X! (cons 'defun (cons cmd (cdr fcmd))))
X "\n")
X! (fill-region pt (point))
X! (indent-rigidly pt (point) 3)
X (delete-region pt (1+ pt))
X (let* ((func (calc-stack-command-p cmd))
X (ffunc (and func (symbolp func) (symbol-function func)))
X--- 9118,9143 ----
X (let* ((cmd (cdr def))
X (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
X (pt (point))
X! (fill-column 70)
X! (fill-prefix nil)
X! str q-ok)
X (if (and fcmd
X (eq (car-safe fcmd) 'lambda)
X (get cmd 'calc-user-defn))
X (progn
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! (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***************
X*** 5303,5313 ****
X (eq (car-safe ffunc) 'lambda)
X (get func 'calc-user-defn)
X (progn
X! (insert (prin1-to-string
X! (cons 'defun (cons func (cdr ffunc))))
X "\n")
X! (fill-region pt (point))
X! (indent-rigidly pt (point) 3)
X (delete-region pt (1+ pt))))))
X (and (stringp fcmd)
X (insert " (fset '" (prin1-to-string cmd)
X--- 9146,9158 ----
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! (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***************
X*** 5356,5363 ****
X (mapatoms (function
X (lambda (x)
X (and (string-match "\\`var-" (symbol-name x))
X! (boundp x)
X! (symbol-value x)
X (not (eq (car-safe (symbol-value x))
X 'special-const))
X (calc-insert-permanent-variable x)))))
X--- 9201,9207 ----
X (mapatoms (function
X (lambda (x)
X (and (string-match "\\`var-" (symbol-name x))
X! (calc-var-value x)
X (not (eq (car-safe (symbol-value x))
X 'special-const))
X (calc-insert-permanent-variable x)))))
X***************
X*** 5388,5394 ****
X (symbol-name var)
X " ')\n")
X (backward-char 2))
X! (insert (prin1-to-string (symbol-value var)))
X (forward-line 1)
X )
X
X--- 9232,9238 ----
X (symbol-name var)
X " ')\n")
X (backward-char 2))
X! (insert (prin1-to-string (calc-var-value var)))
X (forward-line 1)
X )
X
X***************
X*** 5401,5408 ****
X (mapatoms (function
X (lambda (x)
X (and (string-match "\\`var-" (symbol-name x))
X! (boundp x)
X! (symbol-value x)
X (not (eq (car-safe (symbol-value x)) 'special-const))
X (insert "(setq "
X (symbol-name x)
X--- 9245,9251 ----
X (mapatoms (function
X (lambda (x)
X (and (string-match "\\`var-" (symbol-name x))
X! (calc-var-value x)
X (not (eq (car-safe (symbol-value x)) 'special-const))
X (insert "(setq "
X (symbol-name x)
X***************
X*** 5426,5431 ****
X--- 9269,9279 ----
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+ (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***************
X*** 5458,5467 ****
X (delete-region (point) (point-max))
X (while new-stack
X (calc-record-undo (list 'push 1))
X! (let ((fmt (math-format-stack-value
X! (car (car new-stack)))))
X! (setcar (cdr (car new-stack)) (calc-count-lines fmt))
X! (insert fmt "\n"))
X (setq new-stack (cdr new-stack)))
X (calc-renumber-stack))
X (while new-stack
X--- 9306,9312 ----
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***************
X*** 5471,5476 ****
X--- 9316,9337 ----
X (calc-record-undo (list 'set 'saved-stack-top 0))))))))
X )
X
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+ )
X+
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+
X
X (defun calc-kbd-if ()
X "An \"if\" statement in a Calc keyboard macro.
X***************
X*** 5678,5684 ****
X )
X
X (defun calc-kbd-break ()
X! "Break out of a keyboard macro, or out of a Z< Z> or Z{ Z} loop in a macro.
X Usage: cond Z/ breaks only if cond is true. Use \"1 Z/\" to break always."
X (interactive)
X (calc-wrapper
X--- 9539,9545 ----
X )
X
X (defun calc-kbd-break ()
X! "Break out of a keyboard macro, or out of a Z< Z>, Z{ Z}, or Z( Z) loop.
X Usage: cond Z/ breaks only if cond is true. Use \"1 Z/\" to break always."
X (interactive)
X (calc-wrapper
X***************
X*** 5714,5719 ****
X--- 9575,9581 ----
X (calc-simplify-mode calc-simplify-mode)
X (calc-mapping-dir calc-mapping-dir)
X (calc-algebraic-mode calc-algebraic-mode)
X+ (calc-incomplete-algebraic-mode calc-incomplete-algebraic-mode)
X (calc-symbolic-mode calc-symbolic-mode)
X (calc-prefer-frac calc-prefer-frac)
X (calc-complex-mode calc-complex-mode)
X***************
X*** 5849,5854 ****
X--- 9711,9725 ----
X (math-defcache math-pi-over-180 nil
X (math-div-float (math-pi) '(float 18 1)))
X
X+ (math-defcache math-sqrt-pi nil
X+ (math-sqrt-float (math-pi)))
X+
X+ (math-defcache math-sqrt-2 nil
X+ (math-sqrt-float '(float 2 0)))
X+
X+ (math-defcache math-sqrt-two-pi nil
X+ (math-sqrt-float (math-two-pi)))
X+
X (math-defcache math-sqrt-e (float (bigpos 849 146 128 700 270 721 648 1) -21)
X (math-add-float '(float 1 0) (math-exp-minus-1-raw '(float 5 -1))))
X
X***************
X*** 5885,5890 ****
X--- 9756,9822 ----
X (/= (% a 2) 0))
X )
X
X+ ;;; True if A is a small or big integer. [P x] [Public]
X+ (defun math-integerp (a)
X+ (or (integerp a)
X+ (memq (car-safe a) '(bigpos bigneg)))
X+ )
X+
X+ ;;; True if A is (numerically) a non-negative integer. [P N] [Public]
X+ (defun math-natnump (a)
X+ (or (natnump a)
X+ (eq (car-safe a) 'bigpos))
X+ )
X+
X+ ;;; True if A is a rational (or integer). [P x] [Public]
X+ (defun math-ratp (a)
X+ (or (integerp a)
X+ (memq (car-safe a) '(bigpos bigneg frac)))
X+ )
X+
X+ ;;; True if A is a real (or rational). [P x] [Public]
X+ (defun math-realp (a)
X+ (or (integerp a)
X+ (memq (car-safe a) '(bigpos bigneg frac float)))
X+ )
X+
X+ ;;; True if A is a real or HMS form. [P x] [Public]
X+ (defun math-anglep (a)
X+ (or (integerp a)
X+ (memq (car-safe a) '(bigpos bigneg frac float hms)))
X+ )
X+
X+ ;;; True if A is a number of any kind. [P x] [Public]
X+ (defun math-numberp (a)
X+ (or (integerp a)
X+ (memq (car-safe a) '(bigpos bigneg frac float cplx polar)))
X+ )
X+
X+ ;;; True if A is a complex number or angle. [P x] [Public]
X+ (defun math-scalarp (a)
X+ (or (integerp a)
X+ (memq (car-safe a) '(bigpos bigneg frac float cplx polar hms)))
X+ )
X+
X+ ;;; True if A is a vector. [P x] [Public]
X+ (defun math-vectorp (a)
X+ (eq (car-safe a) 'vec)
X+ )
X+
X+ ;;; True if A is any vector or scalar data object. [P x]
X+ (defun math-objvecp (a) ; [Public]
X+ (or (integerp a)
X+ (memq (car-safe a) '(bigpos bigneg frac float cplx polar
X+ hms sdev intv mod vec incomplete)))
X+ )
X+
X+ ;;; True if A is numerically (but not literally) an integer. [P x] [Public]
X+ (defun math-messy-integerp (a)
X+ (cond
X+ ((eq (car-safe a) 'float) (>= (nth 2 a) 0))
X+ ((eq (car-safe a) 'frac) (Math-integerp (math-normalize a))))
X+ )
X+
X ;;; True if A is numerically an integer. [P x] [Public]
X (defun math-num-integerp (a)
X (or (Math-integerp a)
X***************
X*** 5959,5964 ****
X--- 9891,9908 ----
X (= (car dims) (nth 1 dims))))
X )
X
X+ ;;; True if A is any scalar data object. [P x]
X+ (defun math-objectp (a) ; [Public]
X+ (or (integerp a)
X+ (memq (car-safe a) '(bigpos bigneg frac float cplx
X+ polar hms sdev intv mod)))
X+ )
X+ (defmacro Math-objectp (a) ; [Public]
X+ (` (or (not (consp (, a)))
X+ (memq (car (, a))
X+ '(bigpos bigneg frac float cplx polar hms sdev intv mod))))
X+ )
X+
X ;;; True if A is any real scalar data object. [P x]
X (defun math-real-objectp (a) ; [Public]
X (or (integerp a)
X***************
X*** 5965,5981 ****
X (memq (car-safe a) '(bigpos bigneg frac float hms sdev intv mod)))
X )
X
X! ;;; True if A is an object not composed of sub-formulas . [P x] [Public]
X! (defun math-primp (a)
X! (or (integerp a)
X! (memq (car-safe a) '(bigpos bigneg frac float cplx polar
X! hms mod var)))
X! )
X! (defmacro Math-primp (a)
X! (` (or (not (consp (, a)))
X! (memq (car (, a)) '(bigpos bigneg frac float cplx polar
X! hms mod var))))
X! )
X
X ;;; True if A is a constant or vector of constants. [P x] [Public]
X (defun math-constp (a)
X--- 9909,9915 ----
X (memq (car-safe a) '(bigpos bigneg frac float hms sdev intv mod)))
X )
X
X! ;;; Math-primp moved up so calc-select stuff can use it.
X
X ;;; True if A is a constant or vector of constants. [P x] [Public]
X (defun math-constp (a)
X***************
X*** 6058,6063 ****
X--- 9992,10072 ----
X )
X
X
X+ (defun math-normalize-fancy (a)
X+ (cond ((eq (car a) 'frac)
X+ (math-make-frac (math-normalize (nth 1 a))
X+ (math-normalize (nth 2 a))))
X+ ((eq (car a) 'cplx)
X+ (let ((real (math-normalize (nth 1 a)))
X+ (imag (math-normalize (nth 2 a))))
X+ (if (math-zerop imag) real (list 'cplx real imag))))
X+ ((eq (car a) 'polar)
X+ (math-normalize-polar a))
X+ ((eq (car a) 'hms)
X+ (math-normalize-hms a))
X+ ((eq (car a) 'mod)
X+ (math-normalize-mod a))
X+ ((eq (car a) 'sdev)
X+ (let ((x (math-normalize (nth 1 a)))
X+ (s (math-normalize (nth 2 a))))
X+ (if (or (and (Math-objectp x) (not (Math-anglep x)))
X+ (and (Math-objectp s) (not (Math-anglep s))))
X+ (list 'calcFunc-sdev x s)
X+ (math-make-sdev x s))))
X+ ((eq (car a) 'intv)
X+ (let ((mask (math-normalize (nth 1 a)))
X+ (lo (math-normalize (nth 2 a)))
X+ (hi (math-normalize (nth 3 a))))
X+ (if (or (and (Math-objectp lo) (not (Math-anglep lo)))
X+ (and (Math-objectp hi) (not (Math-anglep hi))))
X+ (list 'calcFunc-intv mask lo hi)
X+ (math-make-intv mask lo hi))))
X+ ((eq (car a) 'vec)
X+ (cons 'vec (mapcar 'math-normalize (cdr a))))
X+ ((eq (car a) 'quote)
X+ (math-normalize (nth 1 a)))
X+ ((eq (car a) 'special-const)
X+ (calc-with-default-simplification
X+ (math-normalize (nth 1 a))))
X+ ((eq (car a) 'var)
X+ (cons 'var (cdr a))) ; need to re-cons for selection routines
X+ ((eq (car a) 'calcFunc-if)
X+ (math-normalize-logical-op a))
X+ ((memq (car a) '(calcFunc-lambda calcFunc-quote))
X+ (let ((calc-simplify-mode 'none))
X+ (cons (car a) (mapcar 'math-normalize (cdr a)))))
X+ ((or (integerp (car a)) (consp (car a)))
X+ (if (null (cdr a))
X+ (math-normalize (car a))
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+ ;;; Normalize a bignum digit list by trimming high-end zeros. [L l]
X+ (defun math-norm-bignum (a)
X+ (let ((digs a) (last nil))
X+ (while digs
X+ (or (eq (car digs) 0) (setq last digs))
X+ (setq digs (cdr digs)))
X+ (and last
X+ (progn
X+ (setcdr last nil)
X+ a)))
X+ )
X+
X (defun math-bignum-test (a) ; [B N; B s; b b]
X (if (consp a)
X a
X***************
X*** 6105,6111 ****
X (math-compare (math-mul a (nth 2 b)) (nth 1 b)))
X ((and (eq (car-safe a) 'float) (eq (car-safe b) 'float))
X (if (math-lessp-float a b) -1 1))
X! ((and (Math-anglep a) (Math-anglep b))
X (math-sign (math-add a (math-neg b))))
X ((eq (car-safe a) 'var)
X 2)
X--- 10114,10123 ----
X (math-compare (math-mul a (nth 2 b)) (nth 1 b)))
X ((and (eq (car-safe a) 'float) (eq (car-safe b) 'float))
X (if (math-lessp-float a b) -1 1))
X! ((and (or (Math-anglep a)
X! (and (eq (car a) 'cplx) (eq (nth 2 a) 0)))
X! (or (Math-anglep b)
X! (and (eq (car b) 'cplx) (eq (nth 2 b) 0))))
X (math-sign (math-add a (math-neg b))))
X ((eq (car-safe a) 'var)
X 2)
X***************
X*** 6146,6157 ****
X (let ((ediff (- (nth 2 a) (nth 2 b))))
X (if (>= ediff 0)
X (if (>= ediff (+ calc-internal-prec calc-internal-prec))
X! (Math-integer-negp (nth 1 a))
X (Math-lessp (math-scale-int (nth 1 a) ediff)
X (nth 1 b)))
X (if (>= (setq ediff (- ediff))
X (+ calc-internal-prec calc-internal-prec))
X! (Math-integer-posp (nth 1 b))
X (Math-lessp (nth 1 a)
X (math-scale-int (nth 1 b) ediff)))))
X )
X--- 10158,10173 ----
X (let ((ediff (- (nth 2 a) (nth 2 b))))
X (if (>= ediff 0)
X (if (>= ediff (+ calc-internal-prec calc-internal-prec))
X! (if (eq (nth 1 a) 0)
X! (Math-integer-posp (nth 1 b))
X! (Math-integer-negp (nth 1 a)))
X (Math-lessp (math-scale-int (nth 1 a) ediff)
X (nth 1 b)))
X (if (>= (setq ediff (- ediff))
X (+ calc-internal-prec calc-internal-prec))
X! (if (eq (nth 1 b) 0)
X! (Math-integer-negp (nth 1 a))
X! (Math-integer-posp (nth 1 b)))
X (Math-lessp (nth 1 a)
X (math-scale-int (nth 1 b) ediff)))))
X )
X***************
X*** 6199,6207 ****
X ;;; Convert a function name into a like-looking variable name formula.
X (defun math-calcFunc-to-var (f)
X (if (symbolp f)
X! (let ((base (if (string-match "\\`calcFunc-\\(.+\\)\\'" (symbol-name f))
X! (math-match-substring (symbol-name f) 1)
X! (symbol-name f))))
X (list 'var
X (intern base)
X (intern (concat "var-" base))))
X--- 10215,10233 ----
X ;;; Convert a function name into a like-looking variable name formula.
X (defun math-calcFunc-to-var (f)
X (if (symbolp f)
X! (let* ((func (or (cdr (assq f '( ( + . calcFunc-add )
X! ( - . calcFunc-sub )
X! ( * . calcFunc-mul )
X! ( / . calcFunc-div )
X! ( ^ . calcFunc-pow )
X! ( % . calcFunc-mod )
X! ( neg . calcFunc-neg )
X! ( | . calcFunc-vconcat ) )))
X! f))
X! (base (if (string-match "\\`calcFunc-\\(.+\\)\\'"
X! (symbol-name func))
X! (math-match-substring (symbol-name func) 1)
X! (symbol-name func))))
X (list 'var
X (intern base)
X (intern (concat "var-" base))))
X***************
X*** 6221,6227 ****
X argvals (cdr argvals)))
X res)
X (cons 'calcFunc-call (cons (math-calcFunc-to-var f) args)))
X! (cons f args))
X )
X
X (defun calcFunc-call (f &rest args)
X--- 10247,10265 ----
X argvals (cdr argvals)))
X res)
X (cons 'calcFunc-call (cons (math-calcFunc-to-var f) args)))
X! (if (and (eq f 'calcFunc-neg)
X! (= (length args) 1))
X! (list 'neg (car args))
X! (let ((func (assq f '( ( calcFunc-add . + )
X! ( calcFunc-sub . - )
X! ( calcFunc-mul . * )
X! ( calcFunc-div . / )
X! ( calcFunc-pow . ^ )
X! ( calcFunc-mod . % )
X! ( calcFunc-vconcat . | ) ))))
X! (if (and func (= (length args) 2))
X! (cons (cdr func) args)
X! (cons f args)))))
X )
X
X (defun calcFunc-call (f &rest args)
X***************
X*** 6239,6244 ****
X--- 10277,10341 ----
X
X
X
X+ ;;;; [calc-frac.el]
X+
X+ ;;;; Fractions.
X+
X+ ;;; Build a normalized fraction. [R I I]
X+ ;;; (This could probably be implemented more efficiently than using
X+ ;;; the plain gcd algorithm.)
X+ (defun math-make-frac (num den)
X+ (if (Math-integer-negp den)
X+ (setq num (math-neg num)
X+ den (math-neg den)))
X+ (let ((gcd (math-gcd num den)))
X+ (if (eq gcd 1)
X+ (if (eq den 1)
X+ num
X+ (list 'frac num den))
X+ (if (equal gcd den)
X+ (math-quotient num gcd)
X+ (list 'frac (math-quotient num gcd) (math-quotient den gcd)))))
X+ )
X+
X+ (defun calc-add-fractions (a b)
X+ (if (eq (car-safe a) 'frac)
X+ (if (eq (car-safe b) 'frac)
X+ (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b))
X+ (math-mul (nth 2 a) (nth 1 b)))
X+ (math-mul (nth 2 a) (nth 2 b)))
X+ (math-make-frac (math-add (nth 1 a)
X+ (math-mul (nth 2 a) b))
X+ (nth 2 a)))
X+ (math-make-frac (math-add (math-mul a (nth 2 b))
X+ (nth 1 b))
X+ (nth 2 b)))
X+ )
X+
X+ (defun calc-mul-fractions (a b)
X+ (if (eq (car-safe a) 'frac)
X+ (if (eq (car-safe b) 'frac)
X+ (math-make-frac (math-mul (nth 1 a) (nth 1 b))
X+ (math-mul (nth 2 a) (nth 2 b)))
X+ (math-make-frac (math-mul (nth 1 a) b)
X+ (nth 2 a)))
X+ (math-make-frac (math-mul a (nth 1 b))
X+ (nth 2 b)))
X+ )
X+
X+ (defun calc-div-fractions (a b)
X+ (if (eq (car-safe a) 'frac)
X+ (if (eq (car-safe b) 'frac)
X+ (math-make-frac (math-mul (nth 1 a) (nth 2 b))
X+ (math-mul (nth 2 a) (nth 1 b)))
X+ (math-make-frac (nth 1 a)
X+ (math-mul (nth 2 a) b)))
X+ (math-make-frac (math-mul a (nth 2 b))
X+ (nth 1 b)))
X+ )
X+
X+
X+
X ;;;; [calc-vec.el]
X
X ;;;; Vectors.
X***************
X*** 6293,6298 ****
X--- 10390,10421 ----
X obj)
X )
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+
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+
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***************
X*** 6400,6421 ****
X (vec nil)
X (i -1)
X len cols obj expr)
X! (if (eq mode 'rows)
X! ()
X! (while (and (< (setq i (1+ i)) nargs)
X! (not (math-matrixp (aref ptrs i)))))
X! (if (< i nargs)
X! (if (eq mode 'elems)
X! (setq func (list 'lambda '(&rest x)
X! (list 'math-symb-map
X! (list 'quote f) '(quote elems) 'x))
X! mode 'rows)
X! (while (< i nargs)
X! (if (math-matrixp (aref ptrs i))
X! (aset ptrs i (math-transpose (aref ptrs i))))
X! (setq i (1+ i))))
X! (setq mode 'elems))
X! (setq i -1))
X (while (< (setq i (1+ i)) nargs)
X (setq obj (aref ptrs i))
X (if (and (eq (car-safe obj) 'vec)
X--- 10523,10543 ----
X (vec nil)
X (i -1)
X len cols obj expr)
X! (while (and (< (setq i (1+ i)) nargs)
X! (not (math-matrixp (aref ptrs i)))))
X! (if (< i nargs)
X! (if (eq mode 'elems)
X! (setq func (list 'lambda '(&rest x)
X! (list 'math-symb-map
X! (list 'quote f) '(quote elems) 'x))
X! mode 'rows)
X! (if (eq mode 'cols)
X! (while (< i nargs)
X! (if (math-matrixp (aref ptrs i))
X! (aset ptrs i (math-transpose (aref ptrs i))))
X! (setq i (1+ i)))))
X! (setq mode 'elems))
X! (setq i -1)
X (while (< (setq i (1+ i)) nargs)
X (setq obj (aref ptrs i))
X (if (and (eq (car-safe obj) 'vec)
X***************
X*** 6566,6571 ****
X--- 10688,10764 ----
X (calcFunc-reducer func vec))
X )
X
X+ (defun calcFunc-accum (func vec)
X+ (setq func (math-var-to-calcFunc func))
X+ (or (math-vectorp vec)
X+ (math-reject-arg vec 'vectorp))
X+ (let* ((expr (car (setq vec (cdr vec))))
X+ (res (list 'vec 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 expr (car vec)))
X+ res (nconc res (list expr))))
X+ (math-normalize 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+ (setq func (math-var-to-calcFunc func))
X+ (let ((mat nil))
X+ (while (setq a (cdr a))
X+ (setq mat (cons (cons 'vec
X+ (mapcar (function (lambda (x)
X+ (math-build-call func
X+ (list (car a)
X+ x))))
X+ (cdr b)))
X+ mat)))
X+ (math-normalize (cons 'vec (nreverse mat))))
X+ )
X+
X+
X+ (defun calcFunc-inner (mul-func add-func a b)
X+ (or (math-vectorp a) (math-reject-arg a 'vectorp))
X+ (or (math-vectorp b) (math-reject-arg b 'vectorp))
X+ (if (math-matrixp a)
X+ (if (math-matrixp b)
X+ (cons 'vec (math-inner-mats (cdr a) (mapcar 'cdr (cdr b))))
X+ (math-mat-col
X+ (cons 'vec
X+ (if (= (length (nth 1 a)) 2)
X+ (math-inner-mats (cdr a)
X+ (mapcar 'cdr (cdr (math-row-matrix b))))
X+ (math-inner-mats (cdr a)
X+ (mapcar 'cdr (cdr (math-col-matrix b))))))
X+ 1))
X+ (if (math-matrixp b)
X+ (cons 'vec (math-inner-mat-row a (mapcar 'cdr (cdr b))))
X+ (car (math-inner-mat-row a
X+ (mapcar 'cdr (cdr (math-col-matrix b)))))))
X+ )
X+
X+ (defun math-inner-mats (a b)
X+ (and a
X+ (cons (cons 'vec (math-inner-mat-row (car a) b))
X+ (math-inner-mats (cdr a) b)))
X+ )
X+
X+ (defun math-inner-mat-row (a b) ; uses "mul-func", "add-func"
X+ (if (math-no-empty-rows b)
X+ (cons
X+ (calcFunc-reduce add-func
X+ (calcFunc-map mul-func
X+ a
X+ (cons 'vec (mapcar 'car b))))
X+ (math-inner-mat-row a (mapcar 'cdr b)))
X+ (if (math-list-all-nil b)
X+ nil
X+ (math-dimension-error)))
X+ )
X+
X
X ;;;; [calc-mat.el]
X
X***************
X*** 6618,6627 ****
X )
X
X (defun calcFunc-mrow (mat n) ; [Public]
X! (and (integerp (setq n (math-check-integer n)))
X! (> n 0)
X! (math-vectorp mat)
X! (nth n mat))
X )
X
X ;;; Get the Nth column of a matrix.
X--- 10811,10826 ----
X )
X
X (defun calcFunc-mrow (mat n) ; [Public]
X! (if (Math-vectorp n)
X! (math-map-vec (function (lambda (x) (calcFunc-mrow mat x))) n)
X! (if (eq (car-safe n) 'intv)
X! (math-subvector mat
X! (math-add (nth 2 n) (if (memq (nth 1 n) '(2 3)) 0 1))
X! (math-add (nth 3 n) (if (memq (nth 1 n) '(1 3)) 1 0)))
X! (and (integerp (setq n (math-check-integer n)))
X! (> n 0)
X! (Math-vectorp mat)
X! (nth n mat))))
X )
X
X ;;; Get the Nth column of a matrix.
X***************
X*** 6630,6642 ****
X )
X
X (defun calcFunc-mcol (mat n) ; [Public]
X! (and (integerp (setq n (math-check-integer n)))
X! (> n 0)
X! (math-vectorp mat)
X! (if (math-matrixp mat)
X! (and (< n (length (nth 1 mat)))
X! (math-mat-col mat n))
X! (nth n mat)))
X )
X
X ;;; Remove the Nth row from a matrix.
X--- 10829,10847 ----
X )
X
X (defun calcFunc-mcol (mat n) ; [Public]
X! (if (Math-vectorp n)
X! (math-map-vec (function (lambda (x) (calcFunc-mcol mat x))) n)
X! (if (eq (car-safe n) 'intv)
X! (if (math-matrixp mat)
X! (math-map-vec (function (lambda (x) (calcFunc-mrow x n))) mat)
X! (calcFunc-mrow mat n))
X! (and (integerp (setq n (math-check-integer n)))
X! (> n 0)
X! (Math-vectorp mat)
X! (if (math-matrixp mat)
X! (and (< n (length (nth 1 mat)))
X! (math-mat-col mat n))
X! (nth n mat)))))
X )
X
X ;;; Remove the Nth row from a matrix.
X***************
X*** 6767,6784 ****
X )
X
X ;;; Create a vector of consecutive integers. [Public]
X! (defun math-vec-index (n)
X! (and (not (integerp n))
X! (setq n (math-check-fixnum n)))
X! (or (natnump n) (math-reject-arg n 'natnump))
X! (let ((vec nil))
X! (while (> n 0)
X! (setq vec (cons n vec)
X! n (1- n)))
X! (cons 'vec vec))
X )
X (fset 'calcFunc-index (symbol-function 'math-vec-index))
X
X
X ;;; Compute the row and column norms of a vector or matrix. [Public]
X (defun math-rnorm (a)
X--- 10972,11081 ----
X )
X
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! (if start
X! (progn
X! (if (>= n 0)
X! (while (>= (setq n (1- n)) 0)
X! (setq vec (cons start vec)
X! start (math-add start (or incr 1))))
SHAR_EOF
echo "End of part 7, continue with part 8"
echo "8" > s2_seq_.tmp
exit 0