;;;	Copyright (c) 1989, 1990 by Aubrey Jaffer, All rights reserved.

;;; An algebraic extension is the root of a polynomial with more than
;;; one distinct value.  These values are not linked;  the difference
;;; between two algebraic extensions which are roots of identical
;;; polynomials is not 0.  Radicals have an additional rule that
;;; exponents of "positive" radicands commute.  For instance:
;;; (x^2)^(1/2) ==> x.  Notice that ((-x)^2)^(1/2) ==> x also.
;;; (-x^2)^(1/2) ==> (-1)^(1/2)*x.  Therefore "deep" squarefree
;;; factorization forms the backbone of radical simplification and
;;; denesting.  This seems to be a radical departure from previous work.

;;; algebraic extensions
;;; we want to find all extensions used by this poly except this poly.
(define (alg_exts poly)
  (let ((elts ()))
    (poly_for-each-var 
     (lambda (v)
       (let ((er (extrule v)))
	 (if (and er (not (eq? er poly)))
	     (set! elts (adjoin v elts)))))
     poly)
    elts))

;;;alg_vars returns a list of all vars used in this or in extensions
;;;used in this.
(define (alg_vars poly)
  (let ((deps '()) (exts '()))
    (poly_for-each-var
     (lambda (v) (if (extrule v)
		     (set! exts (adjoin v exts))
		   (set! deps (adjoin v deps))))
     poly)
    (for-each (lambda (v) (set! deps (union (var_dependencies v) deps)))
	      exts)
    deps))

(define (alg_square-free-var p var)
  (alg_/ p (alg_gcd p (alg_diff p var))))

;;; This is for equations
;;; Don't simplify a rule with itself
(define (alg_simplify p)
  (let ((exrls (map extrule (sort (alg_exts p) var_>))))
    (if (memv p exrls)
	p
	(reduce-init poly_prem p exrls))))

(define (alg_clear-denoms p)
  (do ((v (poly_find-var-if? (denom p) extrule)
	  (poly_find-var-if? (denom p) extrule))
       (oldv "foo" (car v)))
      ((not v) p)
      (if (eq? (car v) oldv)
	  (eval-error "could not clear denominator of: " p))
      (set! p (alg_simplify
	       (poly_* p (alg_conjugate (rat_denom p) v))))))

;;; This generates conjugates for any algebraic by a wonderful theorem of mine.
;;; 4/30/90
(define (alg_conjugate poly extpoly)
  (let* ((var (car extpoly))
	 (pdiv (univ_pdiv extpoly (promote var poly)))
	 (pquo (car pdiv))
	 (prem (cadr pdiv)))
    (if (zero? (univ_degree prem var))
	pquo
      (poly_* pquo (alg_conjugate prem extpoly)))))

;;; This section attempts to implement an incremental version of
;;; Caviness, B.F., Fateman, R.:
;;; Simplification of Radical Expressions.
;;; SYMSAC 1976, 329-338
;;; as described in
;;; Buchberger, B., Collins, G.E., Loos, R.:
;;; Computer Algebra, Symbolic and Algebraic Computation. Second Edition
;;; Springer-Verlag/Wein 1983, 20-22
;;; This algorithm for canonical simplification of UNNESTED radical expressions
;;; also has the convention that (s * t)^r = s^r * t^r.
;;; If the variable LINK-RADICANDS is #f then a new multiple value expression
;;; is returned for each radical.

;;; this is actually alg_depth
(define (rad_depth imp)
  (let ((exts (alg_exts imp)))
    (if (null? exts)
	0
      (+ 1 (apply max (map (lambda (x) (rad_depth (extrule x))) exts))))))

;;; Integer power of EXPR
(define (ipow a pow)
  (if (not (integer? pow)) (math-error "non-integer power? " pow))
  (cond ((expl? a) (if (< pow 0)
		       (make-rat 1 (poly_^ a (- pow)))
		     (poly_^ a pow)))
	((rat? a) (if (< pow 0)
		      (make-rat (ipow (rat_denom a) (- pow))
				(ipow (rat_num a) (- pow)))
		    (make-rat (ipow (rat_num a) pow)
			      (ipow (rat_denom a) pow))))
	(else (if (< pow 0)
		  (app* (list @ 1 (univ_monomial -1 (- pow) @1)) a)
		(app* (univ_monomial 1 pow @1) a)))))

(define (^ a pow)
  (if (not (rat_number? pow)) (math-error "Non-numeric exponent: " pow))
  (if (eqn? a) (math-error "Expt of equation?: " a))
  (let ((tmp #f)
	(expnum (num pow))
	(expdenom (denom pow)))
    (cond ((eqv? 1 expdenom) (ipow a expnum))
	  (link-radicands
	   (cond ((expl? a) (ipow (make-radical-ext a expdenom) expnum))
		 ((not (rat? a)) (math-error "Non-rational radicand: " a))
		 ((rat_unit-denom? a)
		  (ipow (make-radical-ext (poly_* (denom a) (num a)) expdenom)
			expnum))
		 (else (ipow (make-rat (make-radical-ext (rat_num a) expdenom)
				       (make-radical-ext (rat_denom a) expdenom))
			     expnum))))
	  (else
	   (app* (cond ((> expnum 0)
			(set! tmp (univ_monomial -1 expdenom @))
			(set-car! (cdr tmp) (univ_monomial 1 expnum @1))
			tmp)
		       (else
			(set! tmp (univ_monomial
				   (univ_monomial -1 (- expnum) @1)
				   expdenom
				   @))
			(set-car! (cdr tmp) 1)
			tmp))
		 a)))))

;;; Generate extensions for radicals of polynomials
;;; Currently this does not split defined radicands.
;;; It will as soon as expression rework is added.
(define (make-radical-ext p r)
  (set! p (licit->polxpr p))
  (let ((prest #f)
	(pegcd #f)
	(radrest #f)
	(en #f)
	(e (member-if (lambda (e) (equal? p (cadr e))) radical-defs)))
    (cond (e (if (divides? r (length (cddr (car e))))
		 (radpow (car e) r)
	       (var->expl (make-rad-var p r))))
	  ((begin (set! e (member-if (lambda (rule)
				       (set! en (cadr rule))
				       (set! pegcd (poly_gcd en p))
				       (not (eqv? 1 pegcd)))
				     radical-defs))
		  e)
	   (set! prest (poly_/ p pegcd))
	   (set! radrest (poly_/ en pegcd))
	   (if (and (eqv? 1 radrest) (divides? r (length (cddr (car e)))))
	       (app* @1*@2 (make-radical-ext prest r) (radpow (car e) r))
	     (var->expl (make-rad-var p r))))
	  (else (var->expl (make-rad-var p r))))))

(define (radpow radrule r)
  (univ_monomial 1 (quotient (length (cddr radrule)) r) (car radrule)))

;;; set up initial radical and extension
(define %sqrt1 (make-ext-var "%sqrt1" (list @ -1 0 1)))
(define %i (make-ext-var "%i" (list @ 1 0 1)))
(define radical-defs (list (extrule %i)))

;;;	Copyright (c) 1989, 1990 by Aubrey Jaffer, All rights reserved.
