Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume15/calc-1.05/part07

Lisp/Scheme | 1990-10-14 | 57KB | 1,743 lines

Newsgroups: comp.sources.misc
X-UNIX-From: [e-mail]
subject: v15i034: Patch for GNU Emacs Calc, version 1.04 -> 1.05, part 07/20
from: [e-mail] (David Gillespie)
Sender: [e-mail] (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 15, Issue 34
Submitted-by: [e-mail] (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