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

Text File | 1991-10-31 | 55.2 KB | 1,823 lines

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

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

---- Cut Here and unpack ----
#!/bin/sh
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-poly.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 23; then
    echo Please unpack part "$Scheck" next!
    exit 1
 else
    exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
    echo 'x - still skipping calc-poly.el'
else
echo 'x - continuing file calc-poly.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-poly.el' &&
)
X
X
;;; Multiply two terms, expanding out products of sums.
(defun math-mul-thru (lhs rhs)
X  (if (memq (car-safe lhs) '(+ -))
X      (list (car lhs)
X        (math-mul-thru (nth 1 lhs) rhs)
X        (math-mul-thru (nth 2 lhs) rhs))
X    (if (memq (car-safe rhs) '(+ -))
X    (list (car rhs)
X          (math-mul-thru lhs (nth 1 rhs))
X          (math-mul-thru lhs (nth 2 rhs)))
X      (math-mul lhs rhs)))
)
X
(defun math-div-thru (num den)
X  (if (memq (car-safe num) '(+ -))
X      (list (car num)
X        (math-div-thru (nth 1 num) den)
X        (math-div-thru (nth 2 num) den))
X    (math-div num den))
)
X
X
;;; Sort the terms of a sum into canonical order.
(defun math-sort-terms (expr)
X  (if (memq (car-safe expr) '(+ -))
X      (math-list-to-sum
X       (sort (math-sum-to-list expr)
X         (function (lambda (a b) (math-beforep (car a) (car b))))))
X    expr)
)
X
(defun math-list-to-sum (lst)
X  (if (cdr lst)
X      (list (if (cdr (car lst)) '- '+)
X        (math-list-to-sum (cdr lst))
X        (car (car lst)))
X    (if (cdr (car lst))
X    (math-neg (car (car lst)))
X      (car (car lst))))
)
X
(defun math-sum-to-list (tree &optional neg)
X  (cond ((eq (car-safe tree) '+)
X     (nconc (math-sum-to-list (nth 1 tree) neg)
X        (math-sum-to-list (nth 2 tree) neg)))
X    ((eq (car-safe tree) '-)
X     (nconc (math-sum-to-list (nth 1 tree) neg)
X        (math-sum-to-list (nth 2 tree) (not neg))))
X    (t (list (cons tree neg))))
)
X
;;; Check if the polynomial coefficients are modulo forms.
(defun math-poly-modulus (expr &optional expr2)
X  (or (math-poly-modulus-rec expr)
X      (and expr2 (math-poly-modulus-rec expr2))
X      1)
)
X
(defun math-poly-modulus-rec (expr)
X  (if (and (eq (car-safe expr) 'mod) (Math-natnump (nth 2 expr)))
X      (list 'mod 1 (nth 2 expr))
X    (and (memq (car-safe expr) '(+ - * /))
X     (or (math-poly-modulus-rec (nth 1 expr))
X         (math-poly-modulus-rec (nth 2 expr)))))
)
X
X
;;; Divide two polynomials.  Return (quotient . remainder).
(defun math-poly-div (u v &optional math-poly-div-base)
X  (if math-poly-div-base
X      (math-do-poly-div u v)
X    (math-do-poly-div (calcFunc-expand u) (calcFunc-expand v)))
)
(setq math-poly-div-base nil)
X
(defun math-poly-div-exact (u v &optional base)
X  (let ((res (math-poly-div u v base)))
X    (if (eq (cdr res) 0)
X    (car res)
X      (math-reject-arg (list 'vec u v) "Argument is not a polynomial")))
)
X
(defun math-do-poly-div (u v)
X  (cond ((math-constp u)
X     (if (math-constp v)
X         (cons (math-div u v) 0)
X       (cons 0 u)))
X    ((math-constp v)
X     (cons (if (eq v 1)
X           u
X         (if (memq (car-safe u) '(+ -))
X             (math-add-or-sub (math-poly-div-exact (nth 1 u) v)
X                      (math-poly-div-exact (nth 2 u) v)
X                      nil (eq (car u) '-))
X           (math-div u v)))
X           0))
X    ((Math-equal u v)
X     (cons math-poly-modulus 0))
X    ((and (math-atomic-factorp u) (math-atomic-factorp v))
X     (cons (math-simplify (math-div u v)) 0))
X    (t
X     (let ((base (or math-poly-div-base
X             (math-poly-div-base u v)))
X           vp up res)
X       (if (or (null base)
X           (null (setq vp (math-is-polynomial v base nil 'gen))))
X           (cons 0 u)
X         (setq up (math-is-polynomial u base nil 'gen)
X           res (math-poly-div-coefs up vp))
X         (cons (math-build-polynomial-expr (car res) base)
X           (math-build-polynomial-expr (cdr res) base))))))
)
X
(defun math-poly-div-rec (u v)
X  (cond ((math-constp u)
X     (math-div u v))
X    ((math-constp v)
X     (if (eq v 1)
X         u
X       (if (memq (car-safe u) '(+ -))
X           (math-add-or-sub (math-poly-div-rec (nth 1 u) v)
X                (math-poly-div-rec (nth 2 u) v)
X                nil (eq (car u) '-))
X         (math-div u v))))
X    ((Math-equal u v) math-poly-modulus)
X    ((and (math-atomic-factorp u) (math-atomic-factorp v))
X     (math-simplify (math-div u v)))
X    (math-poly-div-base
X     (math-div u v))
X    (t
X     (let ((base (math-poly-div-base u v))
X           vp up res)
X       (if (or (null base)
X           (null (setq vp (math-is-polynomial v base nil 'gen))))
X           (math-div u v)
X         (setq up (math-is-polynomial u base nil 'gen)
X           res (math-poly-div-coefs up vp))
X         (math-add (math-build-polynomial-expr (car res) base)
X               (math-div (math-build-polynomial-expr (cdr res) base)
X                 v))))))
)
X
;;; Divide two polynomials in coefficient-list form.  Return (quot . rem).
(defun math-poly-div-coefs (u v)
X  (cond ((null v) (math-reject-arg nil "Division by zero"))
X    ((< (length u) (length v)) (cons nil u))
X    ((cdr u)
X     (let ((q nil)
X           (urev (reverse u))
X           (vrev (reverse v)))
X       (while
X           (let ((qk (math-poly-div-rec (math-simplify (car urev))
X                        (car vrev)))
X             (up urev)
X             (vp vrev))
X         (if (or q (not (math-zerop qk)))
X             (setq q (cons qk q)))
X         (while (setq up (cdr up) vp (cdr vp))
X           (setcar up (math-sub (car up) (math-mul-thru qk (car vp)))))
X         (setq urev (cdr urev))
X         up))
X       (while (and urev (Math-zerop (car urev)))
X         (setq urev (cdr urev)))
X       (cons q (nreverse (mapcar 'math-simplify urev)))))
X    (t
X     (cons (list (math-poly-div-rec (car u) (car v)))
X           nil)))
)
X
;;; Perform a pseudo-division of polynomials.  (See Knuth section 4.6.1.)
;;; This returns only the remainder from the pseudo-division.
(defun math-poly-pseudo-div (u v)
X  (cond ((null v) nil)
X    ((< (length u) (length v)) u)
X    ((or (cdr u) (cdr v))
X     (let ((urev (reverse u))
X           (vrev (reverse v))
X           up)
X       (while
X           (let ((vp vrev))
X         (setq up urev)
X         (while (setq up (cdr up) vp (cdr vp))
X           (setcar up (math-sub (math-mul-thru (car vrev) (car up))
X                    (math-mul-thru (car urev) (car vp)))))
X         (setq urev (cdr urev))
X         up)
X         (while up
X           (setcar up (math-mul-thru (car vrev) (car up)))
X           (setq up (cdr up))))
X       (while (and urev (Math-zerop (car urev)))
X         (setq urev (cdr urev)))
X       (nreverse (mapcar 'math-simplify urev))))
X    (t nil))
)
X
;;; Compute the GCD of two multivariate polynomials.
(defun math-poly-gcd (u v)
X  (cond ((Math-equal u v) u)
X    ((math-constp u)
X     (if (Math-zerop u)
X         v
X       (calcFunc-gcd u (calcFunc-pcont v))))
X    ((math-constp v)
X     (if (Math-zerop v)
X         v
X       (calcFunc-gcd v (calcFunc-pcont u))))
X    (t
X     (let ((base (math-poly-gcd-base u v)))
X       (if base
X           (math-simplify
X        (calcFunc-expand
X         (math-build-polynomial-expr
X          (math-poly-gcd-coefs (math-is-polynomial u base nil 'gen)
X                       (math-is-polynomial v base nil 'gen))
X          base)))
X         (calcFunc-gcd (calcFunc-pcont u) (calcFunc-pcont u))))))
)
X
(defun math-poly-div-list (lst a)
X  (if (eq a 1)
X      lst
X    (if (eq a -1)
X    (math-mul-list lst a)
X      (mapcar (function (lambda (x) (math-poly-div-exact x a))) lst)))
)
X
(defun math-mul-list (lst a)
X  (if (eq a 1)
X      lst
X    (if (eq a -1)
X    (mapcar 'math-neg lst)
X      (and (not (eq a 0))
X       (mapcar (function (lambda (x) (math-mul x a))) lst))))
)
X
;;; Run GCD on all elements in a list.
(defun math-poly-gcd-list (lst)
X  (if (or (memq 1 lst) (memq -1 lst))
X      (math-poly-gcd-frac-list lst)
X    (let ((gcd (car lst)))
X      (while (and (setq lst (cdr lst)) (not (eq gcd 1)))
X    (or (eq (car lst) 0)
X        (setq gcd (math-poly-gcd gcd (car lst)))))
X      (if lst (setq lst (math-poly-gcd-frac-list lst)))
X      gcd))
)
X
(defun math-poly-gcd-frac-list (lst)
X  (while (and lst (not (eq (car-safe (car lst)) 'frac)))
X    (setq lst (cdr lst)))
X  (if lst
X      (let ((denom (nth 2 (car lst))))
X    (while (setq lst (cdr lst))
X      (if (eq (car-safe (car lst)) 'frac)
X          (setq denom (calcFunc-lcm denom (nth 2 (car lst))))))
X    (list 'frac 1 denom))
X    1)
)
X
;;; Compute the GCD of two monovariate polynomial lists.
;;; Knuth section 4.6.1, algorithm C.
(defun math-poly-gcd-coefs (u v)
X  (let ((d (math-poly-gcd (math-poly-gcd-list u)
X              (math-poly-gcd-list v)))
X    (g 1) (h 1) (z 0) hh r delta ghd)
X    (while (and u v (Math-zerop (car u)) (Math-zerop (car v)))
X      (setq u (cdr u) v (cdr v) z (1+ z)))
X    (or (eq d 1)
X    (setq u (math-poly-div-list u d)
X          v (math-poly-div-list v d)))
X    (while (progn
X         (setq delta (- (length u) (length v)))
X         (if (< delta 0)
X         (setq r u u v v r delta (- delta)))
X         (setq r (math-poly-pseudo-div u v))
X         (cdr r))
X      (setq u v
X        v (math-poly-div-list r (math-mul g (math-pow h delta)))
X        g (nth (1- (length u)) u)
X        h (if (<= delta 1)
X          (math-mul (math-pow g delta) (math-pow h (- 1 delta)))
X        (math-poly-div-exact (math-pow g delta)
X                     (math-pow h (1- delta))))))
X    (setq v (if r
X        (list d)
X          (math-mul-list (math-poly-div-list v (math-poly-gcd-list v)) d)))
X    (if (math-guess-if-neg (nth (1- (length v)) v))
X    (setq v (math-mul-list v -1)))
X    (while (>= (setq z (1- z)) 0)
X      (setq v (cons 0 v)))
X    v)
)
X
X
;;; Return true if is a factor containing no sums or quotients.
(defun math-atomic-factorp (expr)
X  (cond ((eq (car-safe expr) '*)
X     (and (math-atomic-factorp (nth 1 expr))
X          (math-atomic-factorp (nth 2 expr))))
X    ((memq (car-safe expr) '(+ - /))
X     nil)
X    ((memq (car-safe expr) '(^ neg))
X     (math-atomic-factorp (nth 1 expr)))
X    (t t))
)
X
;;; Find a suitable base for dividing a by b.
;;; The base must exist in both expressions.
;;; The degree in the numerator must be higher or equal than the
;;; degree in the denominator.
;;; If the above conditions are not met the quotient is just a remainder.
;;; Return nil if this is the case.
X
(defun math-poly-div-base (a b)
X  (let (a-base b-base)
X    (and (setq a-base (math-total-polynomial-base a))
X     (setq b-base (math-total-polynomial-base b))
X     (catch 'return
X       (while a-base
X         (let ((maybe (assoc (car (car a-base)) b-base)))
X           (if maybe
X           (if (>= (nth 1 (car a-base)) (nth 1 maybe))
X               (throw 'return (car (car a-base))))))
X         (setq a-base (cdr a-base))))))
)
X
;;; Same as above but for gcd algorithm.
;;; Here there is no requirement that degree(a) > degree(b).
;;; Take the base that has the highest degree considering both a and b.
;;; ("a^20+b^21+x^3+a+b", "a+b^2+x^5+a^22+b^10") --> (a 22)
X
(defun math-poly-gcd-base (a b)
X  (let (a-base b-base)
X    (and (setq a-base (math-total-polynomial-base a))
X     (setq b-base (math-total-polynomial-base b))
X     (catch 'return
X       (while (and a-base b-base)
X         (if (> (nth 1 (car a-base)) (nth 1 (car b-base)))
X         (if (assoc (car (car a-base)) b-base)
X             (throw 'return (car (car a-base)))
X           (setq a-base (cdr a-base)))
X           (if (assoc (car (car b-base)) a-base)
X           (throw 'return (car (car b-base)))
X         (setq b-base (cdr b-base))))))))
)
X
;;; Sort a list of polynomial bases.
(defun math-sort-poly-base-list (lst)
X  (sort lst (function (lambda (a b)
X            (or (> (nth 1 a) (nth 1 b))
X                (and (= (nth 1 a) (nth 1 b))
X                 (math-beforep (car a) (car b)))))))
)
X
;;; Given an expression find all variables that are polynomial bases.
;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ).
;;; Note dynamic scope of mpb-total-base.
(defun math-total-polynomial-base (expr)
X  (let ((mpb-total-base nil))
X    (math-polynomial-base expr 'math-polynomial-p1)
X    (math-sort-poly-base-list mpb-total-base))
)
X
(defun math-polynomial-p1 (subexpr)
X  (or (assoc subexpr mpb-total-base)
X      (memq (car subexpr) '(+ - * / neg))
X      (and (eq (car subexpr) '^) (natnump (nth 2 subexpr)))
X      (let* ((math-poly-base-variable subexpr)
X         (exponent (math-polynomial-p mpb-top-expr subexpr)))
X    (if exponent
X        (setq mpb-total-base (cons (list subexpr exponent)
X                       mpb-total-base)))))
X  nil
)
X
X
X
X
(defun calcFunc-factors (expr &optional var)
X  (let ((math-factored-vars (if var t nil))
X    (math-to-list t)
X    (calc-prefer-frac t))
X    (or var
X    (setq var (math-polynomial-base expr)))
X    (let ((res (math-factor-finish
X        (or (catch 'factor (math-factor-expr-try var))
X            expr))))
X      (math-simplify (if (math-vectorp res)
X             res
X               (list 'vec (list 'vec res 1))))))
)
X
(defun calcFunc-factor (expr &optional var)
X  (let ((math-factored-vars nil)
X    (math-to-list nil)
X    (calc-prefer-frac t))
X    (math-simplify (math-factor-finish
X            (if var
X            (let ((math-factored-vars t))
X              (or (catch 'factor (math-factor-expr-try var)) expr))
X              (math-factor-expr expr)))))
)
X
(defun math-factor-finish (x)
X  (if (Math-primp x)
X      x
X    (if (eq (car x) 'calcFunc-Fac-Prot)
X    (math-factor-finish (nth 1 x))
X      (cons (car x) (mapcar 'math-factor-finish (cdr x)))))
)
X
(defun math-factor-protect (x)
X  (if (memq (car-safe x) '(+ -))
X      (list 'calcFunc-Fac-Prot x)
X    x)
)
X
(defun math-factor-expr (expr)
X  (cond ((eq math-factored-vars t) expr)
X    ((or (memq (car-safe expr) '(* / ^ neg))
X         (assq (car-safe expr) calc-tweak-eqn-table))
X     (cons (car expr) (mapcar 'math-factor-expr (cdr expr))))
X    ((memq (car-safe expr) '(+ -))
X     (let* ((math-factored-vars math-factored-vars)
X        (y (catch 'factor (math-factor-expr-part expr))))
X       (if y
X           (math-factor-expr y)
X         expr)))
X    (t expr))
)
X
(defun math-factor-expr-part (x)    ; uses "expr"
X  (if (memq (car-safe x) '(+ - * / ^ neg))
X      (while (setq x (cdr x))
X    (math-factor-expr-part (car x)))
X    (and (not (Math-objvecp x))
X     (not (assoc x math-factored-vars))
X     (> (math-factor-contains expr x) 1)
X     (setq math-factored-vars (cons (list x) math-factored-vars))
X     (math-factor-expr-try x)))
)
X
(defun math-factor-expr-try (x)
X  (if (eq (car-safe expr) '*)
X      (let ((res1 (catch 'factor (let ((expr (nth 1 expr)))
X                   (math-factor-expr-try x))))
X        (res2 (catch 'factor (let ((expr (nth 2 expr)))
X                   (math-factor-expr-try x)))))
X    (and (or res1 res2)
X         (throw 'factor (math-accum-factors (or res1 (nth 1 expr)) 1
X                        (or res2 (nth 2 expr))))))
X    (let* ((p (math-is-polynomial expr x 30 'gen))
X       (math-poly-modulus (math-poly-modulus expr))
X       res)
X      (and (cdr p)
X       (setq res (math-factor-poly-coefs p))
X       (throw 'factor res))))
)
X
(defun math-accum-factors (fac pow facs)
X  (if math-to-list
X      (if (math-vectorp fac)
X      (progn
X        (while (setq fac (cdr fac))
X          (setq facs (math-accum-factors (nth 1 (car fac))
X                         (* pow (nth 2 (car fac)))
X                         facs)))
X        facs)
X    (if (and (eq (car-safe fac) '^) (natnump (nth 2 fac)))
X        (setq pow (* pow (nth 2 fac))
X          fac (nth 1 fac)))
X    (if (eq fac 1)
X        facs
X      (or (math-vectorp facs)
X          (setq facs (if (eq facs 1) '(vec)
X               (list 'vec (list 'vec facs 1)))))
X      (let ((found facs))
X        (while (and (setq found (cdr found))
X            (not (equal fac (nth 1 (car found))))))
X        (if found
X        (progn
X          (setcar (cdr (cdr (car found))) (+ pow (nth 2 (car found))))
X          facs)
X          ;; Put constant term first.
X          (if (and (cdr facs) (Math-ratp (nth 1 (nth 1 facs))))
X          (cons 'vec (cons (nth 1 facs) (cons (list 'vec fac pow)
X                              (cdr (cdr facs)))))
X        (cons 'vec (cons (list 'vec fac pow) (cdr facs))))))))
X    (math-mul (math-pow fac pow) facs))
)
X
(defun math-factor-poly-coefs (p &optional square-free)    ; uses "x"
X  (let (t1 t2)
X    (cond ((not (cdr p))
X       (or (car p) 0))
X
X      ;; Strip off multiples of x.
X      ((Math-zerop (car p))
X       (let ((z 0))
X         (while (and p (Math-zerop (car p)))
X           (setq z (1+ z) p (cdr p)))
X         (if (cdr p)
X         (setq p (math-factor-poly-coefs p square-free))
X           (setq p (math-sort-terms (math-factor-expr (car p)))))
X         (math-accum-factors x z (math-factor-protect p))))
X
X      ;; Factor out content.
X      ((and (not square-free)
X        (not (eq 1 (setq t1 (math-mul (math-poly-gcd-list p)
X                          (if (math-guess-if-neg
X                           (nth (1- (length p)) p))
X                          -1 1))))))
X       (math-accum-factors t1 1 (math-factor-poly-coefs
X                     (math-poly-div-list p t1) 'cont)))
X
X      ;; Check if linear in x.
X      ((not (cdr (cdr p)))
X       (math-add (math-factor-protect
X              (math-sort-terms
X               (math-factor-expr (car p))))
X             (math-mul x (math-factor-protect
X                  (math-sort-terms
X                   (math-factor-expr (nth 1 p)))))))
X
X      ;; If symbolic coefficients, use FactorRules.
X      ((let ((pp p))
X         (while (and pp (or (Math-ratp (car pp))
X                (and (eq (car (car pp)) 'mod)
X                     (Math-integerp (nth 1 (car pp)))
X                     (Math-integerp (nth 2 (car pp))))))
X           (setq pp (cdr pp)))
X         pp)
X       (let ((res (math-rewrite
X               (list 'calcFunc-thecoefs x (cons 'vec p))
X               '(var FactorRules var-FactorRules))))
X         (or (and (eq (car-safe res) 'calcFunc-thefactors)
X              (= (length res) 3)
X              (math-vectorp (nth 2 res))
X              (let ((facs 1)
X                (vec (nth 2 res)))
X            (while (setq vec (cdr vec))
X              (setq facs (math-accum-factors (car vec) 1 facs)))
X            facs))
X         (math-build-polynomial-expr p x))))
X
X      ;; Check if rational coefficients (i.e., not modulo a prime).
X      ((eq math-poly-modulus 1)
X
X       ;; Check if there are any squared terms, or a content not = 1.
X       (if (or (eq square-free t)
X           (equal (setq t1 (math-poly-gcd-coefs
X                    p (setq t2 (math-poly-deriv-coefs p))))
X              '(1)))
X
X           ;; We now have a square-free polynomial with integer coefs.
X           ;; For now, we use a kludgey method that finds linear and
X           ;; quadratic terms using floating-point root-finding.
X           (if (setq t1 (let ((calc-symbolic-mode nil))
X                  (math-poly-all-roots nil p t)))
X           (let ((roots (car t1))
X             (csign (if (math-negp (nth (1- (length p)) p)) -1 1))
X             (expr 1)
X             (unfac (nth 1 t1))
X             (scale (nth 2 t1)))
X             (while roots
X               (let ((coef0 (car (car roots)))
X                 (coef1 (cdr (car roots))))
X             (setq expr (math-accum-factors
X                     (if coef1
X                     (let ((den (math-lcm-denoms
X                             coef0 coef1)))
X                       (setq scale (math-div scale den))
X                       (math-add
X                        (math-add
X                         (math-mul den (math-pow x 2))
X                         (math-mul (math-mul coef1 den) x))
X                        (math-mul coef0 den)))
X                       (let ((den (math-lcm-denoms coef0)))
X                     (setq scale (math-div scale den))
X                     (math-add (math-mul den x)
X                           (math-mul coef0 den))))
X                     1 expr)
X                   roots (cdr roots))))
X             (setq expr (math-accum-factors
X                 expr 1
X                 (math-mul csign
X                       (math-build-polynomial-expr
X                        (math-mul-list (nth 1 t1) scale)
X                        x)))))
X         (math-build-polynomial-expr p x))   ; can't factor it.
X
X         ;; Separate out the squared terms (Knuth exercise 4.6.2-34).
X         ;; This step also divides out the content of the polynomial.
X         (let* ((cabs (math-poly-gcd-list p))
X            (csign (if (math-negp (nth (1- (length p)) p)) -1 1))
X            (t1s (math-mul-list t1 csign))
X            (uu nil)
X            (v (car (math-poly-div-coefs p t1s)))
X            (w (car (math-poly-div-coefs t2 t1s))))
X           (while
X           (not (math-poly-zerop
X             (setq t2 (math-poly-simplify
X                   (math-poly-mix
X                    w 1 (math-poly-deriv-coefs v) -1)))))
X         (setq t1 (math-poly-gcd-coefs v t2)
X               uu (cons t1 uu)
X               v (car (math-poly-div-coefs v t1))
X               w (car (math-poly-div-coefs t2 t1))))
X           (setq t1 (length uu)
X             t2 (math-accum-factors (math-factor-poly-coefs v t)
X                        (1+ t1) 1))
X           (while uu
X         (setq t2 (math-accum-factors (math-factor-poly-coefs
X                           (car uu) t)
X                          t1 t2)
X               t1 (1- t1)
X               uu (cdr uu)))
X           (math-accum-factors (math-mul cabs csign) 1 t2))))
X
X      ;; Factoring modulo a prime.
X      ((and (= (length (setq temp (math-poly-gcd-coefs
X                       p (math-poly-deriv-coefs p))))
X           (length p)))
X       (setq p (car temp))
X       (while (cdr temp)
X         (setq temp (nthcdr (nth 2 math-poly-modulus) temp)
X           p (cons (car temp) p)))
X       (and (setq temp (math-factor-poly-coefs p))
X        (math-pow temp (nth 2 math-poly-modulus))))
X      (t
X       (math-reject-arg nil "*Modulo factorization not yet implemented"))))
)
X
(defun math-poly-deriv-coefs (p)
X  (let ((n 1)
X    (dp nil))
X    (while (setq p (cdr p))
X      (setq dp (cons (math-mul (car p) n) dp)
X        n (1+ n)))
X    (nreverse dp))
)
X
(defun math-factor-contains (x a)
X  (if (equal x a)
X      1
X    (if (memq (car-safe x) '(+ - * / neg))
X    (let ((sum 0))
X      (while (setq x (cdr x))
X        (setq sum (+ sum (math-factor-contains (car x) a))))
X      sum)
X      (if (and (eq (car-safe x) '^)
X           (natnump (nth 2 x)))
X      (* (math-factor-contains (nth 1 x) a) (nth 2 x))
X    0)))
)
X
X
X
X
X
;;; Merge all quotients and expand/simplify the numerator
(defun calcFunc-nrat (expr)
X  (if (math-any-floats expr)
X      (setq expr (calcFunc-pfrac expr)))
X  (if (math-vectorp expr)
X      (cons 'vec (mapcar 'calcFunc-nrat (cdr expr)))
X    (let* ((calc-prefer-frac t)
X       (res (math-to-ratpoly expr))
X       (num (math-simplify (math-sort-terms (calcFunc-expand (car res)))))
X       (den (math-simplify (math-sort-terms (calcFunc-expand (cdr res)))))
X       (g (math-poly-gcd num den)))
X      (or (eq g 1)
X      (let ((num2 (math-poly-div num g))
X        (den2 (math-poly-div den g)))
X        (and (eq (cdr num2) 0) (eq (cdr den2) 0)
X         (setq num (car num2) den (car den2)))))
X      (math-simplify (math-div num den))))
)
X
;;; Returns expressions (num . denom).
(defun math-to-ratpoly (expr)
X  (let ((res (math-to-ratpoly-rec expr)))
X    (cons (math-simplify (car res)) (math-simplify (cdr res))))
)
X
(defun math-to-ratpoly-rec (expr)
X  (cond ((Math-primp expr)
X     (cons expr 1))
X    ((memq (car expr) '(+ -))
X     (let ((r1 (math-to-ratpoly-rec (nth 1 expr)))
X           (r2 (math-to-ratpoly-rec (nth 2 expr))))
X       (if (equal (cdr r1) (cdr r2))
X           (cons (list (car expr) (car r1) (car r2)) (cdr r1))
X         (if (eq (cdr r1) 1)
X         (cons (list (car expr)
X                 (math-mul (car r1) (cdr r2))
X                 (car r2))
X               (cdr r2))
X           (if (eq (cdr r2) 1)
X           (cons (list (car expr)
X                   (car r1)
X                   (math-mul (car r2) (cdr r1)))
X             (cdr r1))
X         (let ((g (math-poly-gcd (cdr r1) (cdr r2))))
X           (let ((d1 (and (not (eq g 1)) (math-poly-div (cdr r1) g)))
X             (d2 (and (not (eq g 1)) (math-poly-div
X                          (math-mul (car r1) (cdr r2))
X                          g))))
X             (if (and (eq (cdr d1) 0) (eq (cdr d2) 0))
X             (cons (list (car expr) (car d2)
X                     (math-mul (car r2) (car d1)))
X                   (math-mul (car d1) (cdr r2)))
X               (cons (list (car expr)
X                   (math-mul (car r1) (cdr r2))
X                   (math-mul (car r2) (cdr r1)))
X                 (math-mul (cdr r1) (cdr r2)))))))))))
X    ((eq (car expr) '*)
X     (let* ((r1 (math-to-ratpoly-rec (nth 1 expr)))
X        (r2 (math-to-ratpoly-rec (nth 2 expr)))
X        (g (math-mul (math-poly-gcd (car r1) (cdr r2))
X                 (math-poly-gcd (cdr r1) (car r2)))))
X       (if (eq g 1)
X           (cons (math-mul (car r1) (car r2))
X             (math-mul (cdr r1) (cdr r2)))
X         (cons (math-poly-div-exact (math-mul (car r1) (car r2)) g)
X           (math-poly-div-exact (math-mul (cdr r1) (cdr r2)) g)))))
X    ((eq (car expr) '/)
X     (let* ((r1 (math-to-ratpoly-rec (nth 1 expr)))
X        (r2 (math-to-ratpoly-rec (nth 2 expr))))
X       (if (and (eq (cdr r1) 1) (eq (cdr r2) 1))
X           (cons (car r1) (car r2))
X         (let ((g (math-mul (math-poly-gcd (car r1) (car r2))
X                (math-poly-gcd (cdr r1) (cdr r2)))))
X           (if (eq g 1)
X           (cons (math-mul (car r1) (cdr r2))
X             (math-mul (cdr r1) (car r2)))
X         (cons (math-poly-div-exact (math-mul (car r1) (cdr r2)) g)
X               (math-poly-div-exact (math-mul (cdr r1) (car r2))
X                        g)))))))
X    ((and (eq (car expr) '^) (integerp (nth 2 expr)))
X     (let ((r1 (math-to-ratpoly-rec (nth 1 expr))))
X       (if (> (nth 2 expr) 0)
X           (cons (math-pow (car r1) (nth 2 expr))
X             (math-pow (cdr r1) (nth 2 expr)))
X         (cons (math-pow (cdr r1) (- (nth 2 expr)))
X           (math-pow (car r1) (- (nth 2 expr)))))))
X    ((eq (car expr) 'neg)
X     (let ((r1 (math-to-ratpoly-rec (nth 1 expr))))
X       (cons (math-neg (car r1)) (cdr r1))))
X    (t (cons expr 1)))
)
X
X
(defun math-ratpoly-p (expr &optional var)
X  (cond ((equal expr var) 1)
X    ((Math-primp expr) 0)
X    ((memq (car expr) '(+ -))
X     (let ((p1 (math-ratpoly-p (nth 1 expr) var))
X           p2)
X       (and p1 (setq p2 (math-ratpoly-p (nth 2 expr) var))
X        (max p1 p2))))
X    ((eq (car expr) '*)
X     (let ((p1 (math-ratpoly-p (nth 1 expr) var))
X           p2)
X       (and p1 (setq p2 (math-ratpoly-p (nth 2 expr) var))
X        (+ p1 p2))))
X    ((eq (car expr) 'neg)
X     (math-ratpoly-p (nth 1 expr) var))
X    ((eq (car expr) '/)
X     (let ((p1 (math-ratpoly-p (nth 1 expr) var))
X           p2)
X       (and p1 (setq p2 (math-ratpoly-p (nth 2 expr) var))
X        (- p1 p2))))
X    ((and (eq (car expr) '^)
X          (integerp (nth 2 expr)))
X     (let ((p1 (math-ratpoly-p (nth 1 expr) var)))
X       (and p1 (* p1 (nth 2 expr)))))
X    ((not var) 1)
X    ((math-poly-depends expr var) nil)
X    (t 0))
)
X
X
(defun calcFunc-apart (expr &optional var)
X  (cond ((Math-primp expr) expr)
X    ((eq (car expr) '+)
X     (math-add (calcFunc-apart (nth 1 expr) var)
X           (calcFunc-apart (nth 2 expr) var)))
X    ((eq (car expr) '-)
X     (math-sub (calcFunc-apart (nth 1 expr) var)
X           (calcFunc-apart (nth 2 expr) var)))
X    ((not (math-ratpoly-p expr var))
X     (math-reject-arg expr "Expected a rational function"))
X    (t
X     (let* ((calc-prefer-frac t)
X        (rat (math-to-ratpoly expr))
X        (num (car rat))
X        (den (cdr rat))
X        (qr (math-poly-div num den))
X        (q (car qr))
X        (r (cdr qr)))
X       (or var
X           (setq var (math-polynomial-base den)))
X       (math-add q (or (and var
X                (math-expr-contains den var)
X                (math-partial-fractions r den var))
X               (math-div r den))))))
)
X
X
(defun math-padded-polynomial (expr var deg)
X  (let ((p (math-is-polynomial expr var deg)))
X    (append p (make-list (- deg (length p)) 0)))
)
X
(defun math-partial-fractions (r den var)
X  (let* ((fden (calcFunc-factors den var))
X     (tdeg (math-polynomial-p den var))
X     (fp fden)
X     (dlist nil)
X     (eqns 0)
X     (lz nil)
X     (tz (make-list (1- tdeg) 0))
X     (calc-matrix-mode 'scalar))
X    (and (not (and (= (length fden) 2) (eq (nth 2 (nth 1 fden)) 1)))
X     (progn
X       (while (setq fp (cdr fp))
X         (let ((rpt (nth 2 (car fp)))
X           (deg (math-polynomial-p (nth 1 (car fp)) var))
X           dnum dvar deg2)
X           (while (> rpt 0)
X         (setq deg2 deg
X               dnum 0)
X         (while (> deg2 0)
X           (setq dvar (append '(vec) lz '(1) tz)
X             lz (cons 0 lz)
X             tz (cdr tz)
X             deg2 (1- deg2)
X             dnum (math-add dnum (math-mul dvar
X                               (math-pow var deg2)))
X             dlist (cons (and (= deg2 (1- deg))
X                      (math-pow (nth 1 (car fp)) rpt))
X                     dlist)))
X         (let ((fpp fden)
X               (mult 1))
X           (while (setq fpp (cdr fpp))
X             (or (eq fpp fp)
X             (setq mult (math-mul mult
X                          (math-pow (nth 1 (car fpp))
X                            (nth 2 (car fpp)))))))
X           (setq dnum (math-mul dnum mult)))
X         (setq eqns (math-add eqns (math-mul dnum
X                             (math-pow
X                              (nth 1 (car fp))
X                              (- (nth 2 (car fp))
X                             rpt))))
X               rpt (1- rpt)))))
X       (setq eqns (math-div (cons 'vec (math-padded-polynomial r var tdeg))
X                (math-transpose
X                 (cons 'vec
X                       (mapcar
X                    (function
X                     (lambda (x)
X                       (cons 'vec (math-padded-polynomial
X                               x var tdeg))))
X                    (cdr eqns))))))
X       (and (math-vectorp eqns)
X        (let ((res 0)
X              (num nil))
X          (setq eqns (nreverse eqns))
X          (while eqns
X            (setq num (cons (car eqns) num)
X              eqns (cdr eqns))
X            (if (car dlist)
X            (setq num (math-build-polynomial-expr
X                   (nreverse num) var)
X                  res (math-add res (math-div num (car dlist)))
X                  num nil))
X            (setq dlist (cdr dlist)))
X          (math-normalize res))))))
)
X
X
X
(defun math-expand-term (expr)
X  (cond ((and (eq (car-safe expr) '*)
X          (memq (car-safe (nth 1 expr)) '(+ -)))
X     (math-add-or-sub (list '* (nth 1 (nth 1 expr)) (nth 2 expr))
X              (list '* (nth 2 (nth 1 expr)) (nth 2 expr))
X              nil (eq (car (nth 1 expr)) '-)))
X    ((and (eq (car-safe expr) '*)
X          (memq (car-safe (nth 2 expr)) '(+ -)))
X     (math-add-or-sub (list '* (nth 1 expr) (nth 1 (nth 2 expr)))
X              (list '* (nth 1 expr) (nth 2 (nth 2 expr)))
X              nil (eq (car (nth 2 expr)) '-)))
X    ((and (eq (car-safe expr) '/)
X          (memq (car-safe (nth 1 expr)) '(+ -)))
X     (math-add-or-sub (list '/ (nth 1 (nth 1 expr)) (nth 2 expr))
X              (list '/ (nth 2 (nth 1 expr)) (nth 2 expr))
X              nil (eq (car (nth 1 expr)) '-)))
X    ((and (eq (car-safe expr) '^)
X          (memq (car-safe (nth 1 expr)) '(+ -))
X          (integerp (nth 2 expr))
X          (if (> (nth 2 expr) 0)
X          (or (and (or (> mmt-many 500000) (< mmt-many -500000))
X               (math-expand-power (nth 1 expr) (nth 2 expr)
X                          nil t))
X              (list '*
X                (nth 1 expr)
X                (list '^ (nth 1 expr) (1- (nth 2 expr)))))
X        (if (< (nth 2 expr) 0)
X            (list '/ 1 (list '^ (nth 1 expr) (- (nth 2 expr))))))))
X    (t expr))
)
X
(defun calcFunc-expand (expr &optional many)
X  (math-normalize (math-map-tree 'math-expand-term expr many))
)
X
(defun math-expand-power (x n &optional var else-nil)
X  (or (and (natnump n)
X       (memq (car-safe x) '(+ -))
X       (let ((terms nil)
X         (cterms nil))
X         (while (memq (car-safe x) '(+ -))
X           (setq terms (cons (if (eq (car x) '-)
X                     (math-neg (nth 2 x))
X                   (nth 2 x))
X                 terms)
X             x (nth 1 x)))
X         (setq terms (cons x terms))
X         (if var
X         (let ((p terms))
X           (while p
X             (or (math-expr-contains (car p) var)
X             (setq terms (delq (car p) terms)
X                   cterms (cons (car p) cterms)))
X             (setq p (cdr p)))
X           (if cterms
X               (setq terms (cons (apply 'calcFunc-add cterms)
X                     terms)))))
X         (if (= (length terms) 2)
X         (let ((i 0)
X               (accum 0))
X           (while (<= i n)
X             (setq accum (list '+ accum
X                       (list '* (calcFunc-choose n i)
X                         (list '*
X                           (list '^ (nth 1 terms) i)
X                           (list '^ (car terms)
X                             (- n i)))))
X               i (1+ i)))
X           accum)
X           (if (= n 2)
X           (let ((accum 0)
X             (p1 terms)
X             p2)
X             (while p1
X               (setq accum (list '+ accum
X                     (list '^ (car p1) 2))
X                 p2 p1)
X               (while (setq p2 (cdr p2))
X             (setq accum (list '+ accum
X                       (list '* 2 (list '*
X                                (car p1)
X                                (car p2))))))
X               (setq p1 (cdr p1)))
X             accum)
X         (if (= n 3)
X             (let ((accum 0)
X               (p1 terms)
X               p2 p3)
X               (while p1
X             (setq accum (list '+ accum (list '^ (car p1) 3))
X                   p2 p1)
X             (while (setq p2 (cdr p2))
X               (setq accum (list '+
X                         (list '+
X                           accum
X                           (list '* 3
X                             (list
X                              '*
X                              (list '^ (car p1) 2)
X                              (car p2))))
X                         (list '* 3
X                           (list
X                            '* (car p1)
X                            (list '^ (car p2) 2))))
X                 p3 p2)
X               (while (setq p3 (cdr p3))
X                 (setq accum (list '+ accum
X                           (list '* 6
X                             (list '*
X                               (car p1)
X                               (list
X                                '* (car p2)
X                                (car p3))))))))
X             (setq p1 (cdr p1)))
X               accum))))))
X      (and (not else-nil)
X       (list '^ x n)))
)
X
(defun calcFunc-expandpow (x n)
X  (math-normalize (math-expand-power x n))
)
X
X
X
SHAR_EOF
echo 'File calc-poly.el is complete' &&
chmod 0644 calc-poly.el ||
echo 'restore of calc-poly.el failed'
Wc_c="`wc -c < 'calc-poly.el'`"
test 35651 -eq "$Wc_c" ||
    echo 'calc-poly.el: original size 35651, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-prog.el ==============
if test -f 'calc-prog.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-prog.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-prog.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-prog.el' &&
;; Calculator for GNU Emacs, part II [calc-prog.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-prog () nil)
X
X
(defun calc-equal-to (arg)
X  (interactive "P")
X  (calc-wrapper
X   (if (and (integerp arg) (> arg 2))
X       (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
X     (calc-binary-op "eq" 'calcFunc-eq arg)))
)
X
(defun calc-remove-equal (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "rmeq" 'calcFunc-rmeq arg))
)
X
(defun calc-not-equal-to (arg)
X  (interactive "P")
X  (calc-wrapper
X   (if (and (integerp arg) (> arg 2))
X       (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
X     (calc-binary-op "neq" 'calcFunc-neq arg)))
)
X
(defun calc-less-than (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "lt" 'calcFunc-lt arg))
)
X
(defun calc-greater-than (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "gt" 'calcFunc-gt arg))
)
X
(defun calc-less-equal (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "leq" 'calcFunc-leq arg))
)
X
(defun calc-greater-equal (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "geq" 'calcFunc-geq arg))
)
X
(defun calc-in-set (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "in" 'calcFunc-in arg))
)
X
(defun calc-logical-and (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "land" 'calcFunc-land arg 1))
)
X
(defun calc-logical-or (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "lor" 'calcFunc-lor arg 0))
)
X
(defun calc-logical-not (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "lnot" 'calcFunc-lnot arg))
)
X
(defun calc-logical-if ()
X  (interactive)
X  (calc-wrapper
X   (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3))))
)
X
X
X
X
X
(defun calc-timing (n)
X  (interactive "P")
X  (calc-wrapper
X   (calc-change-mode 'calc-timing n nil t)
X   (message (if calc-timing
X        "Reporting timing of slow commands in Trail."
X          "Not reporting timing of commands.")))
)
X
(defun calc-pass-errors ()
X  (interactive)
X  ;; The following two cases are for the new, optimizing byte compiler
X  ;; or the standard 18.57 byte compiler, respectively.
X  (condition-case err
X      (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
X    (or (memq (car-safe (car-safe place)) '(error xxxerror))
X        (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27)))
X    (or (memq (car (car place)) '(error xxxerror))
X        (error "foo"))
X    (setcar (car place) 'xxxerror))
X    (error (error "The calc-do function has been modified; unable to patch.")))
)
X
(defun calc-user-define ()
X  (interactive)
X  (message "Define user key: z-")
X  (let ((key (read-char)))
X    (if (= (calc-user-function-classify key) 0)
X    (error "Can't redefine \"?\" key"))
X    (let ((func (intern (completing-read (concat "Set key z "
X                         (char-to-string key)
X                         " to command: ")
X                     obarray
X                     'commandp
X                     t
X                     "calc-"))))
X      (let* ((kmap (calc-user-key-map))
X         (old (assq key kmap)))
X    (if old
X        (setcdr old func)
X      (setcdr kmap (cons (cons key func) (cdr kmap)))))))
)
X
(defun calc-user-undefine ()
X  (interactive)
X  (message "Undefine user key: z-")
X  (let ((key (read-char)))
X    (if (= (calc-user-function-classify key) 0)
X    (error "Can't undefine \"?\" key"))
X    (let* ((kmap (calc-user-key-map)))
X      (delq (or (assq key kmap)
X        (assq (upcase key) kmap)
X        (assq (downcase key) kmap)
X        (error "No such user key is defined"))
X        kmap)))
)
X
(defun calc-user-define-formula ()
X  (interactive)
X  (calc-wrapper
X   (let* ((form (calc-top 1))
X      (arglist nil)
X      (is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
X              (>= (length form) 2)))
X      odef key keyname cmd cmd-base func alist is-symb)
X     (if is-lambda
X     (setq arglist (mapcar (function (lambda (x) (nth 1 x)))
X                   (nreverse (cdr (reverse (cdr form)))))
X           form (nth (1- (length form)) form))
X       (calc-default-formula-arglist form)
X       (setq arglist (sort arglist 'string-lessp)))
X     (message "Define user key: z-")
X     (setq key (read-char))
X     (if (= (calc-user-function-classify key) 0)
X     (error "Can't redefine \"?\" key"))
X     (setq key (and (not (memq key '(13 32))) key)
X       keyname (and key
X            (if (or (and (<= ?0 key) (<= key ?9))
X                (and (<= ?a key) (<= key ?z))
X                (and (<= ?A key) (<= key ?Z)))
X                (char-to-string key)
X              (format "%03d" key)))
X       odef (assq key (calc-user-key-map)))
X     (while
X     (progn
X       (setq cmd (completing-read "Define M-x command name: "
X                      obarray 'commandp nil
X                      (if (and odef (symbolp (cdr odef)))
X                      (symbol-name (cdr odef))
X                    "calc-"))
X         cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
X                   (math-match-substring cmd 1))
X         cmd (and (not (or (string-equal cmd "")
X                   (string-equal cmd "calc-")))
X              (intern cmd)))
X       (and cmd
X        (fboundp cmd)
X        odef
X        (not
X         (y-or-n-p
X          (if (get cmd 'calc-user-defn)
X              (concat "Replace previous definition for "
X                  (symbol-name cmd) "? ")
X            "That name conflicts with a built-in Emacs function.  Replace this function? "))))))
X     (if (and key (not cmd))
X     (setq cmd (intern (concat "calc-User-" keyname))))
X     (while
X     (progn
X       (setq func (completing-read "Define algebraic function name: "
X                       obarray 'fboundp nil
X                       (concat "calcFunc-"
X                           (if cmd-base
X                           (if (string-match
X                            "\\`User-.+" cmd-base)
X                               (concat
X                            "User"
X                            (substring cmd-base 5))
X                             cmd-base)
X                         "")))
X         func (and (not (or (string-equal func "")
X                    (string-equal func "calcFunc-")))
X               (intern func)))
X       (and func
X        (fboundp func)
X        (not (fboundp cmd))
X        odef
X        (not
X         (y-or-n-p
X          (if (get func 'calc-user-defn)
X              (concat "Replace previous definition for "
X                  (symbol-name func) "? ")
X            "That name conflicts with a built-in Emacs function.  Replace this function? "))))))
X     (if (not func)
X     (setq func (intern (concat "calcFunc-User"
X                    (or keyname
X                    (and cmd (symbol-name cmd))
X                    (format "%05d" (% (random) 10000)))))))
X     (if is-lambda
X     (setq alist arglist)
X       (while
X       (progn
X         (setq alist (read-from-minibuffer "Function argument list: "
X                           (if arglist
X                           (prin1-to-string arglist)
X                         "()")
X                           minibuffer-local-map
X                           t))
X         (and (not (calc-subsetp alist arglist))
X          (not (y-or-n-p
X            "Okay for arguments that don't appear in formula to be ignored? "))))))
X     (setq is-symb (and alist
X            func
X            (y-or-n-p
X             "Leave it symbolic for non-constant arguments? ")))
X     (setq alist (mapcar (function (lambda (x)
X                     (or (cdr (assq x '((nil . arg-nil)
X                            (t . arg-t))))
X                     x))) alist))
X     (if cmd
X     (progn
X       (calc-need-macros)
X       (fset cmd
X         (list 'lambda
X               '()
X               '(interactive)
X               (list 'calc-wrapper
X                 (list 'calc-enter-result
X                   (length alist)
X                   (let ((name (symbol-name (or func cmd))))
X                     (and (string-match
X                       "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
X                       name)
X                      (math-match-substring name 1)))
X                   (list 'cons
X                     (list 'quote func)
X                     (list 'calc-top-list-n
X                           (length alist)))))))
X       (put cmd 'calc-user-defn t)))
X     (let ((body (list 'math-normalize (calc-fix-user-formula form))))
X       (fset func
X         (append
X          (list 'lambda alist)
X          (and is-symb
X           (mapcar (function (lambda (v)
X                       (list 'math-check-const v t)))
X               alist))
X          (list body))))
X     (put func 'calc-user-defn form)
X     (setq math-integral-cache-state nil)
X     (if key
X     (let* ((kmap (calc-user-key-map))
X        (old (assq key kmap)))
X       (if old
X           (setcdr old cmd)
X         (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
X   (message ""))
)
X
(defun calc-default-formula-arglist (form)
X  (if (consp form)
X      (if (eq (car form) 'var)
X      (if (or (memq (nth 1 form) arglist)
X          (math-const-var form))
X          ()
X        (setq arglist (cons (nth 1 form) arglist)))
X    (calc-default-formula-arglist-step (cdr form))))
)
X
(defun calc-default-formula-arglist-step (l)
X  (and l
X       (progn
X     (calc-default-formula-arglist (car l))
X     (calc-default-formula-arglist-step (cdr l))))
)
X
(defun calc-subsetp (a b)
X  (or (null a)
X      (and (memq (car a) b)
X       (calc-subsetp (cdr a) b)))
)
X
(defun calc-fix-user-formula (f)
X  (if (consp f)
X      (let (temp)
X    (cond ((and (eq (car f) 'var)
X            (memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil)
X                                (t . arg-t))))
X                     (nth 1 f)))
X              alist))
X           temp)
X          ((or (math-constp f) (eq (car f) 'var))
X           (list 'quote f))
X          ((and (eq (car f) 'calcFunc-eval)
X            (= (length f) 2))
X           (list 'let '((calc-simplify-mode nil))
X             (list 'math-normalize (calc-fix-user-formula (nth 1 f)))))
X          ((and (eq (car f) 'calcFunc-evalsimp)
X            (= (length f) 2))
X           (list 'math-simplify (calc-fix-user-formula (nth 1 f))))
X          ((and (eq (car f) 'calcFunc-evalextsimp)
X            (= (length f) 2))
X           (list 'math-simplify-extended
X             (calc-fix-user-formula (nth 1 f))))
X          (t
X           (cons 'list
X             (cons (list 'quote (car f))
X               (mapcar 'calc-fix-user-formula (cdr f)))))))
X    f)
)
X
(defun calc-user-define-composition ()
X  (interactive)
X  (calc-wrapper
X   (if (eq calc-language 'unform)
X       (error "Can't define formats for unformatted mode"))
X   (let* ((comp (calc-top 1))
X      (func (intern (completing-read "Define format for which function: "
X                     obarray 'fboundp nil "calcFunc-")))
X      (comps (get func 'math-compose-forms))
X      entry entry2
X      (arglist nil)
X      (alist nil))
X     (if (math-zerop comp)
X     (if (setq entry (assq calc-language comps))
X         (put func 'math-compose-forms (delq entry comps)))
X       (calc-default-formula-arglist comp)
X       (setq arglist (sort arglist 'string-lessp))
X       (while
X       (progn
X         (setq alist (read-from-minibuffer "Composition argument list: "
X                           (if arglist
X                           (prin1-to-string arglist)
X                         "()")
X                           minibuffer-local-map
X                           t))
X         (and (not (calc-subsetp alist arglist))
X          (y-or-n-p
X           "Okay for arguments that don't appear in formula to be invisible? "))))
X       (or (setq entry (assq calc-language comps))
X       (put func 'math-compose-forms
X        (cons (setq entry (list calc-language)) comps)))
X       (or (setq entry2 (assq (length alist) (cdr entry)))
X       (setcdr entry
X           (cons (setq entry2 (list (length alist))) (cdr entry))))
X       (setcdr entry2 (list 'lambda alist (calc-fix-user-formula comp))))
X     (calc-pop-stack 1)
X     (calc-do-refresh)))
)
X
X
(defun calc-user-define-kbd-macro (arg)
X  (interactive "P")
X  (or last-kbd-macro
X      (error "No keyboard macro defined"))
X  (message "Define last kbd macro on user key: z-")
X  (let ((key (read-char)))
X    (if (= (calc-user-function-classify key) 0)
X    (error "Can't redefine \"?\" key"))
X    (let ((cmd (intern (completing-read "Full name for new command: "
X                    obarray
X                    'commandp
X                    nil
X                    (concat "calc-User-"
X                        (if (or (and (>= key ?a)
X                                 (<= key ?z))
X                            (and (>= key ?A)
X                                 (<= key ?Z))
X                            (and (>= key ?0)
X                                 (<= key ?9)))
X                            (char-to-string key)
X                          (format "%03d" key)))))))
X      (and (fboundp cmd)
X       (not (let ((f (symbol-function cmd)))
X          (or (stringp f)
X              (and (consp f)
X               (eq (car-safe (nth 3 f))
X                   'calc-execute-kbd-macro)))))
X       (error "Function %s is already defined and not a keyboard macro"
X          cmd))
X      (put cmd 'calc-user-defn t)
X      (fset cmd (if (< (prefix-numeric-value arg) 0)
X            last-kbd-macro
X          (list 'lambda
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                  (format "z%c" key)))))
X      (let* ((kmap (calc-user-key-map))
X         (old (assq key kmap)))
X    (if old
X        (setcdr old cmd)
X      (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
)
X
X
(defun calc-user-define-invocation ()
X  (interactive)
X  (or last-kbd-macro
X      (error "No keyboard macro defined"))
X  (setq calc-invocation-macro last-kbd-macro)
X  (message "Use `M-# Z' to invoke this macro")
)
X
X
(defun calc-user-define-edit (prefix)
X  (interactive "P")  ; but no calc-wrapper!
X  (message "Edit definition of command: z-")
X  (let* ((key (read-char))
X     (def (or (assq key (calc-user-key-map))
X          (assq (upcase key) (calc-user-key-map))
X          (assq (downcase key) (calc-user-key-map))
X          (error "No command defined for that key")))
X     (cmd (cdr def)))
X    (if (symbolp cmd)
X    (setq cmd (symbol-function cmd)))
X    (cond ((or (stringp cmd)
X           (and (consp cmd)
X            (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
X       (if (and (>= (prefix-numeric-value prefix) 0)
X            (fboundp 'edit-kbd-macro)
X            (symbolp (cdr def))
X            (eq major-mode 'calc-mode))
X           (progn
X         (if (and (< (window-width) (screen-width))
X              calc-display-trail)
X             (let ((win (get-buffer-window (calc-trail-buffer))))
X               (if win
X               (delete-window win))))
X         (edit-kbd-macro (cdr def) prefix nil
X                 (function
X                  (lambda (x)
X                    (and calc-display-trail
X                     (calc-wrapper
X                      (calc-trail-display 1 t)))))
X                 (function
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                   (get func 'calc-user-defn))))
X           (if (and defn (calc-valid-formula-func func))
X           (progn
X             (calc-wrapper
X              (calc-edit-mode (list 'calc-finish-formula-edit
X                        (list 'quote func)))
X              (insert (math-showing-full-precision
X                   (math-format-nice-expr defn (screen-width)))
X                  "\n"))
X             (calc-show-edit-buffer))
X         (error "That command's definition cannot be edited"))))))
)
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
;;; The following are hooks into the MacEdit package from macedit.el.
(put 'calc-execute-extended-command 'MacEdit-print
X     (function (lambda ()
X         (setq macro-str (concat "\excalc-" macro-str))))
)
X
(put 'calcDigit-start 'MacEdit-print
X     (function (lambda ()
X         (if calc-algebraic-mode
X             (calc-macro-edit-algebraic)
X           (MacEdit-unread-chars key-last)
X           (let ((str "")
X             (min-bsp 0)
X             ch last)
X             (while (and (setq ch (MacEdit-read-char))
X                 (or (and (>= ch ?0) (<= ch ?9))
X                     (memq ch '(?\. ?e ?\_ ?n ?\: ?\# ?M
X                            ?o ?h ?\@ ?\"))
X                     (and (memq ch '(?\' ?m ?s))
X                      (string-match "[@oh]" str))
X                     (and (or (and (>= ch ?a) (<= ch ?z))
X                          (and (>= ch ?A) (<= ch ?Z)))
X                      (string-match
X                       "^[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#"
X                       str))
X                     (and (memq ch '(?\177 ?\C-h))
X                      (> (length str) 0))
X                     (and (memq ch '(?+ ?-))
X                      (> (length str) 0)
X                      (eq (aref str (1- (length str)))
X                          ?e))))
X               (if (or (and (>= ch ?0) (<= ch ?9))
X                   (and (or (not (memq ch '(?\177 ?\C-h)))
X                    (<= (length str) min-bsp))
X                    (setq min-bsp (1+ (length str)))))
X               (setq str (concat str (char-to-string ch)))
X             (setq str (substring str 0 -1))))
X             (if (memq ch '(32 10 13))
X             (setq str (concat str (char-to-string ch)))
X               (MacEdit-unread-chars ch))
X             (insert "type \"")
X             (MacEdit-insert-string str)
X             (insert "\"\n")))))
)
X
(defun calc-macro-edit-algebraic ()
X  (MacEdit-unread-chars key-last)
X  (let ((str "")
X    (min-bsp 0))
X    (while (progn
X         (MacEdit-lookup-key calc-alg-ent-map)
X         (or (and (memq key-symbol '(self-insert-command
X                     calcAlg-previous))
X              (< (length str) 60))
X         (memq key-symbol
X                '(backward-delete-char
X                  delete-backward-char
X                  backward-delete-char-untabify))
X         (eq key-last 9)))
X      (setq macro-str (substring macro-str (length key-str)))
X      (if (or (eq key-symbol 'self-insert-command)
X          (and (or (not (memq key-symbol '(backward-delete-char
X                           delete-backward-char
X                           backward-delete-char-untabify)))
X               (<= (length str) min-bsp))
X           (setq min-bsp (+ (length str) (length key-str)))))
X      (setq str (concat str key-str))
X    (setq str (substring str 0 -1))))
X    (if (memq key-last '(10 13))
X    (setq str (concat str key-str)
X          macro-str (substring macro-str (length key-str))))
X    (if (> (length str) 0)
X    (progn
X      (insert "type \"")
X      (MacEdit-insert-string str)
X      (insert "\"\n"))))
)
(put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
(put 'calc-auto-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
X
(defun calc-macro-edit-variable (&optional no-cmd)
X  (let ((str "") ch)
X    (or no-cmd (insert (symbol-name key-symbol) "\n"))
X    (if (memq (MacEdit-peek-char) '(?\+ ?\- ?\* ?\/ ?\^ ?\|))
X    (setq str (char-to-string (MacEdit-read-char))))
X    (if (and (setq ch (MacEdit-peek-char))
X         (>= ch ?0) (<= ch ?9))
X    (insert "type \"" str
X        (char-to-string (MacEdit-read-char)) "\"\n")
X      (if (> (length str) 0)
X      (insert "type \"" str "\"\n"))
X      (MacEdit-read-argument)))
)
(put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-into 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-neg 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-plus 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-minus 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-times 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-div 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-power 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-concat 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-inv 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-decr 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-incr 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-exchange 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-unstore 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-recall 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-let 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-permanent-variable 'MacEdit-print 'calc-macro-edit-variable)
X
(defun calc-macro-edit-variable-2 ()
X  (calc-macro-edit-variable)
X  (calc-macro-edit-variable t)
)
(put 'calc-copy-variable 'MacEdit-print 'calc-macro-edit-variable-2)
(put 'calc-declare-variable 'MacEdit-print 'calc-macro-edit-variable-2)
X
(defun calc-macro-edit-quick-digit ()
X  (insert "type \"" key-str "\"  # " (symbol-name key-symbol) "\n")
)
(put 'calc-store-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
(put 'calc-store-into-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
(put 'calc-recall-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
(put 'calc-select-part 'MacEdit-print 'calc-macro-edit-quick-digit)
(put 'calc-clean-num 'MacEdit-print 'calc-macro-edit-quick-digit)
X
X
(defun calc-finish-formula-edit (func)
X  (let ((buf (current-buffer))
X    (str (buffer-substring (point) (point-max)))
X    (start (point))
X    (body (calc-valid-formula-func func)))
X    (set-buffer calc-original-buffer)
X    (let ((val (math-read-expr str)))
X      (if (eq (car-safe val) 'error)
X      (progn
X        (set-buffer buf)
X        (goto-char (+ start (nth 1 val)))
X        (error (nth 2 val))))
X      (setcar (cdr body)
X          (let ((alist (nth 1 (symbol-function func))))
X        (calc-fix-user-formula val)))
X      (put func 'calc-user-defn val)))
)
X
(defun calc-valid-formula-func (func)
X  (let ((def (symbol-function func)))
X    (and (consp def)
X     (eq (car def) 'lambda)
X     (progn
X       (setq def (cdr (cdr def)))
X       (while (and def
X               (not (eq (car (car def)) 'math-normalize)))
X         (setq def (cdr def)))
X       (car def))))
)
X
X
(defun calc-get-user-defn ()
X  (interactive)
X  (calc-wrapper
X   (message "Get definition of command: z-")
X   (let* ((key (read-char))
X      (def (or (assq key (calc-user-key-map))
X           (assq (upcase key) (calc-user-key-map))
SHAR_EOF
true || echo 'restore of calc-prog.el failed'
fi
echo 'End of  part 23'
echo 'File calc-prog.el is continued in part 24'
echo 24 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].