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

(proclaim '(optimize (speed 3) (compilation-speed 0)))

;;; (vsubst 0 x poly) no longer works, why?
(define (vsubst new old e)
  (let ((ans
	 (cond ((eq? new old) e)
	       ((number? e) e)
	       ((bunch? e) (map (lambda (e) (vsubst new old e)) e))
	       ((eqv? 0 new) (poly_subst0 old e))
	       ((eqv? 1 new) (reduce poly_+ (cdr (promote old e))))
	       ((var_< (car e) new) (univ_norm0 new (cdr (promote old e))))
	       ((var_< new old)
		(poly_resultant (list old (list new 0 -1) 1) e old))
	       (else (poly_resultant (list new (list old 0 -1) 1) e old)))))
    ans))

;;; Makes an expression whose value is the variable VAR in the equation
;;; E or (if E is an expression) E=0
(define (suchthat var e)
  (set! var (variable var))
  (set! e (poly_subst0 @ (licit->poleqn e)))
  (extize (normalize (vsubst @ var e))))

;; canonicalizers
(define (normalize x)
  (cond ((bunch? x) (map normalize x))
	((symbol? x) (eval-error "normalize symbol? " x))
	((eqn? x)
	 (poly->eqn (signcan (poly_square-free (alg_simplify (eqn->poly x))))))
	(else (expr_normalize x))))
(define (expr_normalize p)
  (set! p (expr_norm p))
  (if (impl? p)
      (expr_norm-or-signcan
       (alg_simplify (poly_square-free-var
		      (if (rat? p) (alg_clear-denoms p) p)
		      @)))
      (alg_simplify p)))
(define (extize p)
  (cond ((bunch? p) (eval-error "cannot suchthat a vector" p))
	((eqn? p) p)
	((expl? p) p)
	((rat? p) p)
	(else (let ((v (make-ext-var (string-standard-case "E") p)))
		(set! var-news (cons v var-news))
		(var->expl v)))))

;; differentials

(define (poly_diffn p vars)
  (if (null? vars) 0
    (poly_+ (poly_* (var->expl (var_differential (car vars)))
		    (poly_diff p (car vars)))
	    (poly_diffn p (cdr vars)))))
(define (chain-exts drule es)
  (if (null? es)
      drule
      (chain-exts (poly_resultant
		   drule
		   (poly_diffn (extrule (car es))
			       (poly_vars (extrule (car es))))
		   (var_differential (car es)))
		  (union (cdr es) (alg_exts (extrule (car es)))))))
(define (total-differential a)
  (if (bunch? a)
      (map total-differential a)
      (let ((pa (licit->poleqn a)))
	(chain-exts
	 (if (impl? pa)
	     (vsubst @ d@ (poly_resultant pa (poly_diffn pa (poly_vars pa)) @))
	     (poly_diffn pa (poly_vars pa)))
	 (alg_exts pa)))))

;;;; FINITE DIFFERENCES
;;; shift needs to go through extensions; which will create new
;;; extensions (yucc).  It is clear what to do for radicals, but other
;;; extensions will be hard to link up.  For instance y: {x|x^5+a+b+9+x}
;;; needs to yield the same number whether a or b is substituted first.
(define (shift p var)
  (vsubst var
	  @2
	  (poly_resultant (list @2 (list var -1 -1) 1)
			  p
			  var)))
(define (unsum p var)
  (app* @1-@2 p (shift p (variable var))))
(define (poly_fdiffn p vars)
  (if (null? vars) 0
    (poly_+ (poly_* (var->expl (var_finite-differential (car vars)))
		    (unsum p (car vars)))
	    (poly_fdiffn p (cdr vars)))))
(define (total-finite-differential e)
  (if (bunch? e)
      (map total-finite-differential e)
    (poly_fdiffn e (alg_vars e))))

 ;;;logical operations on licits
(define (impl_not p)
  (poly_+ (poly_* (licit->poleqn p)
		  (var->expl (newvar "~"))) -1))

(define (impl_and p . qs)
  (cond ((bunch? p) (impl_and (append p qs)))))

(define expl_t (var->expl (string->var (string-standard-case "t"))))
(define (expl_t? e) (equal? e expl_t))
(define (ncexpt a pow)
  (cond ((not (or (integer? pow) (expl_t? pow)))
	 (math-error "Non-integer exponent: " pow))
	((eqns? a) (math-error "Expt of equation?: " a))
	((not (bunch? a)) (fcexpt a pow))
	((expl_t? pow) (transpose a))
	(else (mtrx_expt a pow))))

;;; This rule can not be entered from user level.
(define %inftsl (make-ext-var "%inftsl" (list @ 0 0 1)))

;;;; Routines for factoring
(define (poly_diff-coefs el n)
  (if (null? el)
      el
    (cons (poly_* n (car el))
	  (poly_diff-coefs (cdr el) (+ 1 n)))))
(define (poly_diff p var)
  (cond ((number? p) 0)
	((eq? (car p) var) (univ_norm0 var (poly_diff-coefs (cddr p) 1)))
	((var_< (car p) var) 0)
	(else (univ_norm0 (car p) (map-no-end-0s
				   (lambda (x) (poly_diff x var))
				   (cdr p))))))
(define (poly_diff-all p)
  (let ((ans 0))
    (do ((vars (poly_vars p) (cdr vars)))
	((null? vars) ans)
	(set! ans (poly_+ (poly_diff p (car vars)) ans)))))

;;;functions involved with square free.
(define (poly_square-free-var p var)
  (poly_/ p (poly_gcd p (poly_diff p var))))

(define (poly_square-free p)
  (if (number? p)
      p
    (poly_* (poly_square-free (univ_cont p))
	    (poly_/ p (poly_gcd p (poly_diff p (car p)))))))

(define (poly_factorq p) (poly_factor-all p))

(define (poly_factor-var c var)
  (poly_factor-split c (poly_diff c var)))

(define (poly_factor-all c)
  (poly_factor-split c (poly_diff-all c)))

;;; This algorithm is due to:
;;; Multivariate Polynomial Factorization
;;; David R. Musser
;;; Journal of the Association for Computing Machinery
;;; Vol 22, No. 2, April 1975

(define (poly_factor-split c splitter)
  (let ((d #f) (aj #f) (b (poly_gcd c splitter)))
    (do ((b b (poly_/ b d))
	 (a (poly_/ c b) d))
	((number? b)
	 (if (eqv? 1 b)
	     (nreverse (cons a aj))
	     (cons b (nreverse (cons a aj)))))
      (set! d (poly_gcd a b))
      (set! aj (cons (poly_/ a d) aj)))))

;;; the following algorithm attempts to separate factors in a multivariate
;;; polynomial with major variable.  It substitues 0 for each variable
;;; that it finds in turn and takes GCD against the original expression.
;;; It assumes that it's argument is squarefree and contentfree in the
;;; major variable.
(define (univ_split pe varlist)
  (cond ((unit? pe) (list))
	((null? varlist) (list pe))
	((let ((p0 (signcan
		    (poly_gcd pe (poly_subst0 (car varlist) pe))))
	       (cvl (cdr varlist)))
	   (if (unit? p0)
	       (univ_split pe cvl)
	     (nconc (univ_split (poly_/ pe p0) cvl)
		    (univ_split p0 cvl)))))))

(define (univ_split-all poly) (univ_split poly (poly_vars poly)))

(define (factor-free-var p var)
  (poly_gcd p (poly_subst0 var p)))

(define (factor_test)
  (test (list (list x 1 2) (list x 1 2) (list x -1 0 1))
	poly_factorq
	(list x -1 -4 -3 4 4)))

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