comparison lisp/calc/calcalg2.el @ 41271:fcd507927105

Change all toplevel `setq' forms to `defvar' forms, and move them before their first use. Use `when', `unless'. Remove trailing periods from error forms. Add description and headers suggested by Emacs Lisp coding conventions.

41270:711f18abaf57

;; Calculator for GNU Emacs, part II [calc-alg-2.el]
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor

;; 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.



;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)

(require 'calc-macs)

(defun calc-derivative (var num)
  (interactive "sDifferentiate with respect to: \np")
  (calc-slow-wrapper
   (and (< num 0) (error "Order of derivative must be positive"))
   (let ((func (if (calc-is-hyperbolic) 'calcFunc-tderiv 'calcFunc-deriv))
	 n expr)
     (if (or (equal var "") (equal var "$"))
	 (setq n 2
	       expr (calc-top-n 2)
	       var (calc-top-n 1))
       (setq var (math-read-expr var))
       (if (eq (car-safe var) 'error)
	   (error "Bad format in expression: %s" (nth 1 var)))
       (setq n 1
	     expr (calc-top-n 1)))
     (while (>= (setq num (1- num)) 0)
       (setq expr (list func expr var)))
     (calc-enter-result n "derv" expr))))

	(and (= (length expr) 3)
	     (list 'calcFunc-subscr (nth 1 expr)
		   (math-derivative (nth 2 expr)))))))





(setq math-integ-var '(var X ---))
(setq math-integ-var-2 '(var Y ---))
(setq math-integ-vars (list 'f math-integ-var math-integ-var-2))
(setq math-integ-var-list (list math-integ-var))
(setq math-integ-var-list-list (list math-integ-var-list))

(defmacro math-tracing-integral (&rest parts)
  (list 'and
	'trace-buffer
	(list 'save-excursion

					     '(var pi var-pi)))))))




(defun calcFunc-table (expr var &optional low high step)
  (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf)))
  (or high (setq high low low 1))
  (and (or (math-infinitep low) (math-infinitep high))
       (not step)

	      (and (not (and (equal low '(neg (var inf var-inf)))
			     (equal high '(var inf var-inf))))
		   (list low high))
	      (and step (list step))))))

(setq math-tabulate-initial nil)
(setq math-tabulate-function nil)

(defun math-scan-for-limits (x)
  (cond ((Math-primp x))
	((and (eq (car x) 'calcFunc-subscr)
	      (Math-vectorp (nth 1 x))
	      (math-expr-contains (nth 2 x) var))

	(t
	 (while (setq x (cdr x))
	   (math-scan-for-limits (car x))))))


(defun calcFunc-sum (expr var &optional low high step)
  (if math-disable-sums (math-reject-arg))
  (let* ((res (let* ((calc-internal-prec (+ calc-internal-prec 2)))
		(math-sum-rec expr var low high step)))
	 (math-disable-sums t))
    (math-normalize res)))
(setq math-disable-sums nil)

(defun math-sum-rec (expr var &optional low high step)
  (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf)))
  (and low (not high) (setq high low low 1))
  (let (t1 t2 val)

	       (let ((temp (or (car not-const) 1)))
		 (while (setq not-const (cdr not-const))
		   (setq temp (list '* (car not-const) temp)))
		 temp)))))

;; Following is from CRC Math Tables, 27th ed, pp. 52-53.
(defun math-sum-integer-power (pow)
  (let ((calc-prefer-frac t)
	(n (length math-sum-int-pow-cache)))
    (while (<= n pow)

	(setcar lin (math-sub 1 (math-mul n sum)))
	(setq math-sum-int-pow-cache
	      (nconc math-sum-int-pow-cache (list (nreverse new)))
	      n (1+ n))))
    (nth pow math-sum-int-pow-cache)))
(setq math-sum-int-pow-cache (list '(0 1)))

(defun math-to-exponentials (expr)
  (and (consp expr)
       (= (length expr) 2)
       (let ((x (nth 1 expr))

	 (list 'calcFunc-exp (nth 2 expr)))
	(t
	 (cons (car expr) (mapcar 'math-to-exps (cdr expr))))))


(defun calcFunc-prod (expr var &optional low high step)
  (if math-disable-prods (math-reject-arg))
  (let* ((res (let* ((calc-internal-prec (+ calc-internal-prec 2)))
		(math-prod-rec expr var low high step)))
	 (math-disable-prods t))
    (math-normalize res)))
(setq math-disable-prods nil)

(defun math-prod-rec (expr var &optional low high step)
  (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf)))
  (and low (not high) (setq high '(var inf var-inf)))
  (let (t1 t2 t3 val)

	  (calcFunc-table expr var low high)))))




;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears
;;; in lhs but not in rhs or rhs'; return rhs'.
;;; Uses global values: solve-*.
(defun math-try-solve-for (lhs rhs &optional sign no-poly)
  (let (t1 t2 t3)

	   (math-try-solve-for t1 rhs sign))
	  (t
	   (calc-record-why "*No inverse known" lhs)
	   nil))))

(setq math-solve-ranges nil)

(defun math-try-solve-prod ()
  (cond ((eq (car lhs) '*)
	 (cond ((not (math-expr-contains (nth 1 lhs) solve-var))
		(math-try-solve-for (nth 2 lhs)

      (math-sub (math-add (math-mul sign1 (math-div r 2))
			  (math-solve-get-sign (math-div de 2)))
		(math-div a 4))))
   nil t))

(defun math-poly-all-roots (var p &optional math-factoring)
  (catch 'ouch
    (let* ((math-symbolic-solve calc-symbolic-mode)
	   (roots nil)
	   (deg (1- (length p)))

	  (if (eq solve-full t)
	      (list 'calcFunc-subscr
		    vec
		    (math-solve-get-int 1 (1- (length orig-p)) 1))
	    vec))))))
(setq math-symbolic-solve nil)

(defun math-lcm-denoms (&rest fracs)
  (let ((den 1))
    (while fracs
      (if (eq (car-safe (car fracs)) 'frac)

		    (math-add aa
			      (let ((calc-symbolic-mode math-symbolic-solve))
				(math-mul (math-sqrt (math-sub (math-sqr aa)
							       rnd0))
					  (if (math-negp xim) -1 1)))))))))))
(setq math-int-coefs nil)

;;; The following routine is from Numerical Recipes, section 9.5.
(defun math-poly-laguerre-root (p x polish)
  (let* ((calc-prefer-frac nil)
	 (calc-symbolic-mode nil)

41271:fcd507927105

;;; calcalg2.el --- more algebraic functions for Calc

;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.

;; Author: David Gillespie <[e-mail]>
;; Maintainer: Colin Walters <[e-mail]>

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor

;; 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.

;;; Commentary:

;;; Code:

;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)

(require 'calc-macs)

(defun calc-derivative (var num)
  (interactive "sDifferentiate with respect to: \np")
  (calc-slow-wrapper
   (when (< num 0)
     (error "Order of derivative must be positive"))
   (let ((func (if (calc-is-hyperbolic) 'calcFunc-tderiv 'calcFunc-deriv))
	 n expr)
     (if (or (equal var "") (equal var "$"))
	 (setq n 2
	       expr (calc-top-n 2)
	       var (calc-top-n 1))
       (setq var (math-read-expr var))
       (when (eq (car-safe var) 'error)
	 (error "Bad format in expression: %s" (nth 1 var)))
       (setq n 1
	     expr (calc-top-n 1)))
     (while (>= (setq num (1- num)) 0)
       (setq expr (list func expr var)))
     (calc-enter-result n "derv" expr))))

	(and (= (length expr) 3)
	     (list 'calcFunc-subscr (nth 1 expr)
		   (math-derivative (nth 2 expr)))))))


(defvar math-integ-var '(var X ---))
(defvar math-integ-var-2 '(var Y ---))
(defvar math-integ-vars (list 'f math-integ-var math-integ-var-2))
(defvar math-integ-var-list (list math-integ-var))
(defvar math-integ-var-list-list (list math-integ-var-list))

(defmacro math-tracing-integral (&rest parts)
  (list 'and
	'trace-buffer
	(list 'save-excursion

					     '(var pi var-pi)))))))




(defvar math-tabulate-initial nil)
(defvar math-tabulate-function nil)
(defun calcFunc-table (expr var &optional low high step)
  (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf)))
  (or high (setq high low low 1))
  (and (or (math-infinitep low) (math-infinitep high))
       (not step)

	      (and (not (and (equal low '(neg (var inf var-inf)))
			     (equal high '(var inf var-inf))))
		   (list low high))
	      (and step (list step))))))

(defun math-scan-for-limits (x)
  (cond ((Math-primp x))
	((and (eq (car x) 'calcFunc-subscr)
	      (Math-vectorp (nth 1 x))
	      (math-expr-contains (nth 2 x) var))

	(t
	 (while (setq x (cdr x))
	   (math-scan-for-limits (car x))))))


(defvar math-disable-sums nil)
(defun calcFunc-sum (expr var &optional low high step)
  (if math-disable-sums (math-reject-arg))
  (let* ((res (let* ((calc-internal-prec (+ calc-internal-prec 2)))
		(math-sum-rec expr var low high step)))
	 (math-disable-sums t))
    (math-normalize res)))

(defun math-sum-rec (expr var &optional low high step)
  (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf)))
  (and low (not high) (setq high low low 1))
  (let (t1 t2 val)

	       (let ((temp (or (car not-const) 1)))
		 (while (setq not-const (cdr not-const))
		   (setq temp (list '* (car not-const) temp)))
		 temp)))))

(defvar math-sum-int-pow-cache (list '(0 1)))
;; Following is from CRC Math Tables, 27th ed, pp. 52-53.
(defun math-sum-integer-power (pow)
  (let ((calc-prefer-frac t)
	(n (length math-sum-int-pow-cache)))
    (while (<= n pow)

	(setcar lin (math-sub 1 (math-mul n sum)))
	(setq math-sum-int-pow-cache
	      (nconc math-sum-int-pow-cache (list (nreverse new)))
	      n (1+ n))))
    (nth pow math-sum-int-pow-cache)))

(defun math-to-exponentials (expr)
  (and (consp expr)
       (= (length expr) 2)
       (let ((x (nth 1 expr))

	 (list 'calcFunc-exp (nth 2 expr)))
	(t
	 (cons (car expr) (mapcar 'math-to-exps (cdr expr))))))


(defvar math-disable-prods nil)
(defun calcFunc-prod (expr var &optional low high step)
  (if math-disable-prods (math-reject-arg))
  (let* ((res (let* ((calc-internal-prec (+ calc-internal-prec 2)))
		(math-prod-rec expr var low high step)))
	 (math-disable-prods t))
    (math-normalize res)))

(defun math-prod-rec (expr var &optional low high step)
  (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf)))
  (and low (not high) (setq high '(var inf var-inf)))
  (let (t1 t2 t3 val)

	  (calcFunc-table expr var low high)))))




(defvar math-solve-ranges nil)
;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears
;;; in lhs but not in rhs or rhs'; return rhs'.
;;; Uses global values: solve-*.
(defun math-try-solve-for (lhs rhs &optional sign no-poly)
  (let (t1 t2 t3)

	   (math-try-solve-for t1 rhs sign))
	  (t
	   (calc-record-why "*No inverse known" lhs)
	   nil))))


(defun math-try-solve-prod ()
  (cond ((eq (car lhs) '*)
	 (cond ((not (math-expr-contains (nth 1 lhs) solve-var))
		(math-try-solve-for (nth 2 lhs)

      (math-sub (math-add (math-mul sign1 (math-div r 2))
			  (math-solve-get-sign (math-div de 2)))
		(math-div a 4))))
   nil t))

(defvar math-symbolic-solve nil)
(defvar math-int-coefs nil)
(defun math-poly-all-roots (var p &optional math-factoring)
  (catch 'ouch
    (let* ((math-symbolic-solve calc-symbolic-mode)
	   (roots nil)
	   (deg (1- (length p)))

	  (if (eq solve-full t)
	      (list 'calcFunc-subscr
		    vec
		    (math-solve-get-int 1 (1- (length orig-p)) 1))
	    vec))))))

(defun math-lcm-denoms (&rest fracs)
  (let ((den 1))
    (while fracs
      (if (eq (car-safe (car fracs)) 'frac)

		    (math-add aa
			      (let ((calc-symbolic-mode math-symbolic-solve))
				(math-mul (math-sqrt (math-sub (math-sqr aa)
							       rnd0))
					  (if (math-negp xim) -1 1)))))))))))

;;; The following routine is from Numerical Recipes, section 9.5.
(defun math-poly-laguerre-root (p x polish)
  (let* ((calc-prefer-frac nil)
	 (calc-symbolic-mode nil)