Function: math-poly-all-roots

math-poly-all-roots is an autoloaded and byte-compiled function defined in calcalg2.el.gz.

Signature

(math-poly-all-roots VAR P &optional MATH-FACTORING)

Source Code

;; Defined in /usr/src/emacs/lisp/calc/calcalg2.el.gz
(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)))
	   (orig-p (reverse p))
	   (math-int-coefs nil)
	   (math-int-scale nil)
	   (math-double-roots nil)
	   (math-int-factors nil)
	   (math-int-threshold nil)
	   (pp p))
      ;; If rational coefficients, look for exact rational factors.
      (while (and pp (Math-ratp (car pp)))
	(setq pp (cdr pp)))
      (if pp
	  (if (or math-factoring math-symbolic-solve)
	      (throw 'ouch nil))
	(let ((lead (car orig-p))
	      (calc-prefer-frac t)
	      (scale (apply 'math-lcm-denoms p)))
	  (setq math-int-scale (math-abs (math-mul scale lead))
		math-int-threshold (math-div '(float 5 -2) math-int-scale)
		math-int-coefs (cdr (math-div (cons 'vec orig-p) lead)))))
      (if (> deg 4)
	  (let ((calc-prefer-frac nil)
		(calc-symbolic-mode nil)
		(pp p)
		(def-p (copy-sequence orig-p)))
	    (while pp
	      (if (Math-numberp (car pp))
		  (setq pp (cdr pp))
		(throw 'ouch nil)))
	    (while (> deg (if math-symbolic-solve 2 4))
	      (let* ((x (math-poly-any-root def-p '(float 0 0) nil))
		     b c pp)
		(if (and (eq (car-safe x) 'cplx)
			 (math-nearly-zerop (nth 2 x) (nth 1 x)))
		    (setq x (calcFunc-re x)))
		(or math-factoring
		    (setq roots (cons x roots)))
		(or (math-numberp x)
		    (setq x (math-evaluate-expr x)))
		(setq pp def-p
		      b (car def-p))
		(while (setq pp (cdr pp))
		  (setq c (car pp))
		  (setcar pp b)
		  (setq b (math-add (math-mul x b) c)))
		(setq def-p (cdr def-p)
		      deg (1- deg))))
	    (setq p (reverse def-p))))
      (if (> deg 1)
	  (let ((math-solve-var '(var DUMMY var-DUMMY))
		(math-solve-sign nil)
		(math-solve-ranges nil)
		(math-solve-full 'all))
	    (if (= (length p) (length math-int-coefs))
		(setq p (reverse math-int-coefs)))
	    (setq roots (append (cdr (apply (cond ((= deg 2)
						   'math-solve-quadratic)
						  ((= deg 3)
						   'math-solve-cubic)
						  (t
						   'math-solve-quartic))
					    math-solve-var p))
				roots)))
	(if (> deg 0)
	    (setq roots (cons (math-div (math-neg (car p)) (nth 1 p))
			      roots))))
      (if math-factoring
	  (progn
	    (while roots
	      (math-poly-integer-root (car roots))
	      (setq roots (cdr roots)))
	    (list math-int-factors (nreverse math-int-coefs) math-int-scale))
	(let ((vec nil)) ;; res
	  (while roots
	    (let ((root (car roots))
		  (math-solve-full (and math-solve-full 'all)))
	      (if (math-floatp root)
		  (setq root (math-poly-any-root orig-p root t)))
	      (setq vec (append vec
				(cdr (or (math-try-solve-for var root nil t)
					 (throw 'ouch nil))))))
	    (setq roots (cdr roots)))
	  (setq vec (cons 'vec (nreverse vec)))
	  (if math-symbolic-solve
	      (setq vec (math-normalize vec)))
	  (if (eq math-solve-full t)
	      (list 'calcFunc-subscr
		    vec
		    (math-solve-get-int 1 (1- (length orig-p)) 1))
	    vec))))))