;;; "hensel.scm" Hensel Lifting.		-*-scheme-*-
;;; Copyright 1994, 1995 Mike Thomas
;;; See the file "COPYING" for terms applying to this program.

(require 'common-list-functions)
(require 'factor)
(require 'random)
(require 'combinatorics)
(require 'polynomial-factorization)

;;; mth Taylor series coefficient in expansion about var = n
(define (taylor-coefficient poly var n m)
  (poly:/ (poly:evaln (let loop ((i 1) (fn poly))
			(if (> i m) fn (loop (+ 1 i) (poly:diff fn var))))
		      var n)
	  (factorial m)))

;;; hen:eea-lift computes s,t such that s a + t b = 1 (mod p^k),
;;; deg(s) < deg(b), deg(t) < deg(a), assuming GCD(a mod p, b mod p) =
;;; 1 in Z mod p [x], and that a and b have the same variable and are
;;; univariate.
;;; GCL Algorithm 6.3
;;; This is the extended euclidean gcd algorithm (mod p), but altered
;;; to lift its results to (mod p^k). Arguments a and b are assumed to
;;; be relatively prime.

(define hen:eea-lift
  (memon
   (lambda (a b p k)
     (if (not (equal? (u:var a) (u:var b)))
	 (math:error 'hen:eea-lift "polys not in the same variable." a b))
     (let* ((x (u:var a))
	    (amodp (ff:unorm p a))
	    (bmodp (ff:unorm p b))
	    (g (ff:eea-gcd amodp bmodp p))
	    (s (cadr g))
	    (smodp s)
	    (t (caddr g))
	    (tmodp t)
	    (modulus p))
       (do ((i 1 (+ 1 i)))
	   ((>= i k) (let ((res (list s t))) (check-el a b p k res) res))
	 (let* ((e  (number->poly
		     (poly:- (list x 1) (poly:+ (poly:* s a) (poly:* t b)))
		     x))
		(c  (ff:unorm p (u:p/c e modulus)))
		(sb (number->poly (poly:* smodp c) x))
		(tb (number->poly (poly:* tmodp c) x))
		(qr (ff:p/p->qr p sb bmodp))
		(q  (car qr))
		(si (cadr qr))
		(ta (fluid-let ((*modulus* (symmetric:modulus p)))
		      (poly:+ tb (poly:* q amodp)))))
	   (set! s (number->poly (poly:+ s (poly:* si modulus)) x))
	   (set! t (number->poly (poly:+ t (poly:* ta modulus)) x))
	   (set! modulus (* modulus p))))))))

(define (check-el a1 a2 p k result)
  (define p^k (integer-expt p k))
  (fluid-let ((*modulus* (symmetric:modulus p^k)))
    (let* ((x (u:var a1))
	   (inner-prod (ff:unorm
			p^k
			(number->poly
			 (poly:+ (poly:* a1 (car result))
				 (poly:* a2 (cadr result))) x))))
      (cond ((not (equal? (list x 1) inner-prod))
	     (ff:print "In hen:eea-lift: the result is not correct.")
	     (ff:print " a1 = " a1 " a2 = " a2 " result = " result)
	     (ff:print " inner-prod = " inner-prod
		       " supposed result = " (list x 1)
		       " p^k = " p^k))))))


;;; Compute s1..sr such that s(1)*b(1)+...+s(r)*b(r) = 1 (mod p^k)
;;; with deg(s(j)) < deg(a(j))
;;; where b(i) = a(1)*...a(i-1)*a(i+1)*...*a(r),  i = 1..r
;;; Assumes p doesn't divide leading coefft of a(i), i = 1..r
;;;  and the a(i) must each be pairwise relatively prime in Z mod p [x].
;;; GCL alg 6.3
(define hen:multiterm-eea-lift
  (memon (lambda (a p k)
	   (let* ((r (length a))
		  (var (u:var (car a)))
		  (r-1 (+ -1 r))
		  (r-2 (+ -2 r))
		  (s (make-vector r (list var 0)))
		  (q (make-vector r-1 (list var 0)))
		  (beta (make-vector r (list var 1))))
	     (vector-set! q r-2 (list-ref a r-1))
	     (let loop ((j (- r-2 1)))
	       (cond ((>= j 0)
		      (vector-set! q j (poly:* (list-ref a (+ 1 j))
					       (vector-ref q (+ 1 j))))
		      (loop (+ -1 j)))))
	     (let loop ((j 0))
	       (if (< j r-1)
		   (let ((sigma (hen:diophantine
				 (list (vector-ref q j) (list-ref a j))
				 (vector-ref beta j) p k)))
		     (vector-set! beta (+ 1 j) (car sigma))
		     (vector-set! s j  (cadr sigma))
		     (loop (+ 1 j)))))
	     (vector-set! s r-1 (vector-ref beta r-1))
	     (check-mel a p k (vector->list s))
	     (vector->list s)))))

(define (check-mel as p k result)
  (define p^k (integer-expt p k))
  (fluid-let ((*modulus* (symmetric:modulus p^k)))
    (let* ((la (length as))
	   (x (u:var (car as)))
	   (bs (make-vector la 0)))
      (let loop ((i 0))
	(cond ((< i la)
	       (let loop1 ((j 0)
			   (acc (list x 1)))
		 (cond ((< j la)
			(if (not (= i j))
			    (loop1 (+ 1 j) (poly:* acc (list-ref as j)))
			    (loop1 (+ 1 j) acc)))
		       (else (vector-set! bs i acc))))
	       (loop (+ 1 i)))))
      (set! bs (vector->list bs))
      (let ((inner-prod (number->poly (reduce poly:+ (map poly:* bs result)) x))
	    (cn (list x 1)))
	(cond ((not (equal? cn inner-prod))
	       (ff:print "In hen:multiterm-eea-lift: the result is not correct.")
	       (ff:print " as = " as " bs = " bs " result = " result)
	       (ff:print " inner-prod = " inner-prod " supposed result = " cn
			 " p^k = " p^k)))))))


;;; GCL alg 6.3
(define hen:diophantine1
  (memon (lambda (a x m p k)
	   (let ((r (length a))
		 (p^k (integer-expt p k))
		 (xm (poly:^ (var->expl x) m)))
	     (fluid-let ((*modulus* (symmetric:modulus p^k)))
	       (if (> r 2)
		   (let ((s (hen:multiterm-eea-lift a p k))
			 (result '()))
		     (do ((j 0 (+ 1 j)))
			 ((not (< j r)) (check-hd1 a x m p k result)
					result)
		       (set! result (append result
					    (cdr (ff:p/p->qr
						  p^k
						  (poly:* xm (list-ref s j))
						  (list-ref a j)))))))
		   (let* ((s (hen:eea-lift (cadr a) (car a) p k))
			  (q1 (ff:p/p->qr p^k (poly:* xm (car s))
					  (car a)))
			  (q (car q1))
			  (result (list (cadr q1)
					(poly:+ (poly:* xm (cadr s)) ;ff:p+p p^k
						(poly:* q (cadr a))))))
		     (check-hd1 a x m p k result)
		     result)))))))

(define (check-hd1 as x m p k result)
  (let* ((la (length as))
	 (p^k (integer-expt p k))
	 (bs (make-vector la 0)))
    (fluid-let ((*modulus* (symmetric:modulus p^k)))
      (let loop ((i 0))
	(cond ((< i la)
	       (let loop1 ((j 0)
			   (acc (list x 1)))
		 (cond ((< j la)
			(loop1 (+ 1 j)
			       (if (= i j) acc
				   (univ:* acc (list-ref as j)))))
		       (else (vector-set! bs i acc))))
	       (loop (+ 1 i)))))
      (set! bs (vector->list bs))
      (let ((inner-prod
	     (ff:unorm
	      p^k (number->poly (reduce poly:+ (map poly:* bs result))
				x)))
	    (x^m (number->poly (poly:^ (var->expl x) m) x)))
	(cond ((not (equal? x^m inner-prod))
	       (ff:print "In hen:diophantine1: the result is not correct.")
	       (ff:print " as = " as " bs = " bs " result = " result)
	       (ff:print " inner-prod = " inner-prod " x^m = " x^m " x = " x
			 " m = " m " p^k = " p^k)))))))

;;; GCL alg 6.4
;;; Assumes that the leading coefficient of a given multivariate
;;; polynomial is the last one
(define (hen:mhenseln a i p l u lcu)
  (let* ((nu-1 (length i))
	 (nu   (+ nu-1 1))
	 (pl   (integer-expt p l))
	 (av   (make-vector nu a))	;Partly substituted targets
	 (iv   (make-vector nu '())))	;Partial ideals for leading coefficients
    (do ((j (+ -2 nu) (+ -1 j)))
	((negative? j))
      (let ((xj     (car (list-ref i j)))
	    (alphaj (cadr (list-ref i j))))
	(vector-set! iv j (list-tail i j))
	(vector-set! av j (poly:evaln (vector-ref av (+ 1 j)) xj alphaj))))
    (let* ((maxdeg (apply max (map (lambda (x) (poly:degree a (car x))) i)))
	   (bu u)
	   (n  (length u)))
      (do ((j 0 (+ 1 j)))
	  ((>= j nu-1))
	(let* ((bu1 bu)
	       (monomial 1)
	       (e 1)
	       (xj     (car (list-ref i j)))
	       (alphaj (cadr (list-ref i j)))
	       (ij (list xj (- alphaj) 1)))
	  (set! bu (lcsubst bu lcu (vector-ref iv (+ 1 j)) pl))
	  (set! e (poly:- (vector-ref av (+ 1 j)) (reduce poly:* bu)))
	  (let loop1 ((k 1) (monomial ij))
	    (if (and (not (eqv? 0 e))
		     (<= k (poly:degree (vector-ref av (+ 1 j)) xj)))
		(let ((c (taylor-coefficient e xj alphaj k)))
		  (if (not (equal? c 0))
		      (let* ((du1 (hen:multivariate-diophantine
				   bu1 (number->poly c (u:var (car bu1)))
				   (butlast i (- nu-1 j)) maxdeg p l))
			     (du (map (lambda (x)
					(poly:0-degree-norm
					 (poly:* x  monomial))) du1)))
			(set! bu (map (lambda (x y)
					(ff:mnorm pl (poly:0-degree-norm
						      (poly:+ x y))))
				      bu du))
			(set! e (ff:mnorm
				 pl (poly:0-degree-norm
				     (poly:- (vector-ref av (+ 1 j))
					     (reduce poly:* bu)))))))
		  (loop1 (+ 1 k) (poly:* monomial ij)))))))
      (if (equal? a (poly:0-degree-norm (reduce-init poly:* 1 bu))) bu #f))))

;;; Substitute an updated leading coefficient into each member of u.
;;; The member of the correct leading coefficients in lcu corresponding to
;;; a factor in u, is reduced mod the ideal id.
(define (lcsubst u lcu id pl)
  (let* ((save (map (lambda (x) (butlast x 1)) u))
	 (unsubs (map (lambda (x y) (append x (list y))) save lcu)))
    (map (lambda (x)
	   (let loop ((i id))
	     (cond ((null? i) x)
		   (else (set! x (ff:mnorm
				  pl (poly:evaln x (caar i) (cadar i))))
			 (loop (cdr i))))))
	 unsubs)))

;;; GCL alg 6.2 partly tested
(define (hen:multivariate-diophantine a c i d p k)
  (let* ((r (length a))
	 (nu-1	  (length i))
	 (nu (+ nu-1 1))
	 (p^k (integer-expt p k)))
    (if (> nu 1)
	(let* ((ap (reduce-init poly:* 1 a))
	       (b (map (lambda (x) (poly:/ ap x)) a))
	       (xnu (car (list-ref i (- nu-1 1))))
	       (alphanu (cadr (list-ref i (- nu-1 1))))
	       (anew (map (lambda (x) (poly:evaln x xnu alphanu)) a))
	       (cnew (poly:evaln c xnu alphanu))
	       (inew (del (list xnu alphanu) i '()))
	       (sigma (hen:multivariate-diophantine anew cnew inew d p k))
	       (e (ff:mnorm
		   p^k (poly:- c (reduce-init poly:+ 0 (map poly:* sigma b)))))
	       (monomial 1))
	  (let loop ((m 1))
	    (cond
	     ((and (<= m d) (not (poly:0? e)))
	      (set! monomial (poly:* monomial (poly:- (var->expl xnu) alphanu)))
	      (let ((cm (taylor-coefficient e xnu alphanu m)))
		(if (not (equal? cm 0))
		    (let ((ds
			   (hen:multivariate-diophantine anew cm inew d p k)))
		      (set! ds (map (lambda (x1) (poly:* x1 monomial)) ds))
		      (set! sigma (map poly:+ sigma ds))
		      (set! e (ff:mnorm
			       p^k (poly:- e (reduce-init
					     poly:+ 0 (map poly:* ds b)))))
		      )))
	      (loop (+ 1 m)))
	     (else
	      (map (lambda (x) (ff:mnorm p^k x)) sigma)))))
	(let* ((x1 (u:var (car a)))
	       (sigma (make-list r 0))
	       (c1 (number->poly c x1)) ;So we can deconstruct consistently
	       (dc (poly:degree c1 x1)))
	  (let loop ((m 1))
	    (if (<= (+ -1 m) dc)
		(let* ((cm (poly:leading-coeff (list-ref c1 m) x1))
;;; IF cm = 0 then we don't need to do the diophantine solution.
		       (ds (hen:diophantine1 a x1 (+ -1 m) p k)))
		  (check-hd1 a x1 (+ -1 m) p k ds)
		  (set! ds (map (lambda (x) (poly:* x cm)) ds))
		  (set! sigma (map (lambda (x y)
				     (number->poly (poly:+ x y) x1))
				   sigma ds))
		  (loop (+ 1 m)))))
	  (map (lambda (x) (ff:unorm p^k x)) sigma)))))

;;; memoised diophantine equation solver is much faster
(define hen:diophantine
  (memon (lambda (a c p k)
	   (let* ((r (length a))
		  (p^k (integer-expt p k))
		  (x1	   (u:var c))
		  (dc (u:degree c))
		  (sigma   (make-list r 0)))
	     (let loop ((m 1))
	       (if (<= (+ -1 m) dc)
		   (let* ((cm (list-ref c m))
			  (ds (hen:diophantine1 a x1 (+ -1 m) p k)))
		     (set! ds (map (lambda (x) (poly:* x cm)) ds))
		     (set! sigma (map (lambda (x y)
					(number->poly (poly:+ x y) x1))
				      sigma ds))
		     (loop (+ 1 m)))
		   (let ((result (map (lambda (x) (ff:unorm p^k x)) sigma)))
		     (check-hd a c p k result)
		     result)))))))

(define (check-hd as c p k result)
  (define p^k (integer-expt p k))
  (fluid-let ((*modulus* (symmetric:modulus p^k)))
    (let* ((la (length as))
	   (x (u:var c))
	   (bs (make-vector la 0)))
      (let loop ((i 0))
	(cond ((< i la)
	       (let loop1 ((j 0)
			   (acc (list x 1)))
		 (cond ((< j la)
			(if (not (= i j))
			    (loop1 (+ 1 j) (poly:* acc (list-ref as j)))
			    (loop1 (+ 1 j) acc)))
		       (else (vector-set! bs i acc))))
	       (loop (+ 1 i)))))
      (set! bs (vector->list bs))
      (let ((inner-prod
	     (ff:unorm
	      p^k (number->poly (reduce poly:+ (map poly:* bs result)) x)))
	    (cn (ff:unorm p^k c)))
	(cond ((not (equal? cn inner-prod))
	       (print "In hen:diophantine: the result is not correct.")
	       (print " as = " as " bs = " bs " result = " result)
	       (print " inner-prod = " inner-prod " cn = " cn " p^k = " p^k)
	       ))))))

;;; 2 factor univariate linear Hensel lifting algorithm
(define (hen:ulhensel2 f g1 h1 p k)
  (let* ((g g1)
	 (h h1)
	 (lf (univ:lc f))
	 (ghrecip (ff:eea-gcd g1 h1 p))
	 (grecip (cadr ghrecip))
	 (hrecip (caddr ghrecip))
	 (x (u:var f)))
    (let loop ((i 2)
	       (modulus p)
	       (modulus*p (* p p)))
      (if (<= i k)
	  (let* ((discrepancy
		  (u:p/c (fluid-let ((*modulus* (symmetric:modulus modulus*p)))
			   (number->poly (poly:- (poly:* f (coef:invert lf))
						 (poly:* g h))
					 x))
			 modulus))
		 (gc (cadr (ff:p/p->qr
			    p (number->poly (poly:* hrecip discrepancy) x) g1)))
		 (hc (cadr (ff:p/p->qr
			    p (number->poly (poly:* grecip discrepancy) x)
			    h1))))
	    (set! g (poly:+ g (poly:* gc modulus)))
	    (set! h (poly:+ h (poly:* hc modulus)))
	    (loop (+ 1 i) modulus*p (* modulus*p p)))
	  (list g h)))))

;;; Experimental (slow) 3 factor univariate linear Hensel lifting algorithm
(define (hen:ulhensel3 f g1 h1 i1 p k)
  (let* ((g g1)
	 (h h1)
	 (lf (univ:lc f))
	 (i i1)
	 (x (u:var f)))
    (let loop ((l 2)
	       (modulus p)
	       (modulus*p (* p p)))
      (if (<= l k)
	  (let* ((diff
		  (u:p/c (fluid-let ((*modulus* (symmetric:modulus modulus*p)))
			   (number->poly (poly:- (poly:* f (coef:invert lf))
						 (poly:* (poly:* g h) i))
					 x))
			 modulus))
		 (dghi (hen:diophantine (list g1 h1 i1) diff p 1))
		 (dg (car dghi))
		 (dh (cadr dghi))
		 (di (caddr dghi)))
	    (set! g (poly:+ g (poly:* dg modulus)))
	    (set! h (poly:+ h (poly:* dh modulus)))
	    (set! i (poly:+ i (poly:* di modulus)))
	    (loop (+ 1 l) modulus*p (* modulus*p p)))
	  (list g h i)))))

;;; Experimental (slow) n factor univariate linear Hensel lifting algorithm
(define (hen:ulhenseln f as p k)
  (let ((x (u:var f))
	(lf (univ:lc f)))
    (let loop ((l 2)
	       (modulus p)
	       (modulus*p (* p p)))
      (if (<= l k)
	  (let* ((diff
		  (u:p/c (fluid-let ((*modulus* (symmetric:modulus modulus*p)))
			   (number->poly (poly:- (poly:* f (coef:invert lf))
						 (reduce poly:* as))
					 x))
			 modulus))
		 (ds (hen:diophantine as diff p 1)))
	    (set! as (map (lambda (x y) (poly:+ x (poly:* y modulus))) as ds))
	    (loop (+ 1 l) modulus*p (* modulus*p p)))
	  as))))

;;; Special var power factors of poly
(define (svpf poly)
  (let loop ((p (cdr poly)) (n 0))
    (if (number? (car p))
	(if (zero? (car p))
	    (if (null? (cdr p))
		(+ 1 n)
		(loop (cdr p) (+ 1 n)))
	    n)
	n)))

(define (map-svpf-factors ppoly)
  (map (lambda (x) (cons (poly:factorszpp (car x))
			 (cdr x)))
       (poly:sff ppoly)))

;;; Factorise multivariate polynomial over Z
(define (poly:factorz poly)
  (case (length (poly:vars poly))
    ((0) (list (list poly 1)))		; number
    ((1) (u:prepend-integer-factor	; univariate
	  (* (u:unitz poly) (univ:cont poly))
	  (map (lambda (x) (list (u:factorsz (car x)) (cadr x)))
	       (u:sff (u:primz poly)))))
    (else				; multivariate
     (cond (math:trace
	    (display-diag 'factoring:) (newline-diag)
	    (math:write (poleqns->licits poly) *output-grammar*)))
     (let* ((spec-var (car poly))
	    (spec-var-poly (var->expl spec-var))
	    (psign (poly:unitz poly spec-var))
	    (pcont (unitcan (univ:cont poly)))
	    (ppoly1 (poly:primz poly spec-var))
	    (spec-var-pf (svpf ppoly1))
	    (ppoly (poly:/ ppoly1 (poly:^ spec-var-poly spec-var-pf)))
	    (ppolyfactors
	     (cond ((zero? spec-var-pf)
		    (map-svpf-factors ppoly))
		   ((number? ppoly)
		    (list (list (list spec-var-poly) spec-var-pf)))
		   (else
		    (cons (list (list spec-var-poly) spec-var-pf)
			  (map-svpf-factors ppoly)))))
	    (facts
	     (cond ((number? pcont)
		    (u:prepend-integer-factor (* pcont psign) ppolyfactors))
		   (else
		    (u:prepend-integer-factor
		     psign (append (poly:factorz pcont) ppolyfactors))))))
       (cond (math:trace (display-diag 'yielding:) (newline-diag)
			 (math:write facts *output-grammar*)))
       facts))))

(define (unlucky? maxdeg poly1 spec-var)
  (or (not (= maxdeg (poly:degree poly1 spec-var)))
      (not (eqv? 1 (poly:gcd (poly:diff poly1 spec-var) poly1)))))

;;; Make a random ideal for the list of variables ivars with the
;;; random numbers > 1 and <= r.  Each variable must have a unique
;;; value to assist in sorting out leading coefficients.
;;; r > (length ivars) + (length nums)
;;; nums is a list of numbers which cannot appear in the ideal.
;;; The random number must be greater than one to enable the recognition of
;;; multiple factors in the leading coefficient.
(define ideal:prngs
  (make-random-state "repeatable seed for making random ideals"))
(define (make-random-ideal ivars nums r)
  (define (mri ivars sofar nums r)
    (if (null? ivars)
	sofar
	(let ((rn (let loop ((rn1 (+ 2 (random r ideal:prngs))))
		    (if (member rn1 nums)
			(loop (+ 2 (random r ideal:prngs))) rn1))))
	  (mri (cdr ivars) (cons rn sofar) (cons rn nums) r))))
  (if (> (+ (length ivars) (length nums)) r)
      (math:error 'make-random-ideal "r too small." ivars nums r))
  (map list ivars (mri ivars '() nums r)))

;;; Strip a list of factors and powers of the powers
(define (strip-powers l acc)
  (if (null? l) acc (strip-powers (cdr l) (append (caar l) acc))))

;;;; From: Michael Thomas <mjt@octavia.anu.edu.au>

;;; From page 142 of Davenport et al "Computer Algebra Systems and
;;; Algorithms for Algebraic Computation":
;;;
;;; Let
;;;
;;; Q = b0 + b1 * x + b2 * x^2 + b3 * x^3 + ... + bi * x^i + ... + bq * x^q
;;;
;;; be a divisor of the polynomial
;;;
;;; P = a0 + a1 * x + a2 * x^2 + a3 * x^3 + ... + ai * x^i + ... + ap * x^p
;;;
;;; (where the ai and bi are integers).
;;;
;;; Then
;;;
;;; |b0| + |b1| + |b2| + ... + |bq| <=
;;;
;;;	 2^q * |(ap/bq)| * (a0^2 + a1^2 + ... ap^2)^(1/2)

;;; Page 237 of GCL refers you to Mignotte[4] for ways of determining
;;; the bounding integer.  That reference is:

;;; M. Mignotte, "Some Useful Bounds.," pp. 259-263 in Computer
;;; Algebra - Symbolic and Algebraic computation, ed. B. Buchberger,
;;; G.E. Collins and R. Loos, Springer-Verlag (1982).

;;; Mignotte's paper conflicts with the theorem from Davenport in that
;;; the ratio of the two leading coefficients is the reciprocal of the
;;; ratio in Mignotte.

;;;; From jaffer:

;;; There seemed to be some confusion regarding the correct formula,
;;; so I tried all 4 variations (Monte Carlo, see "test/mignotte.scm")
;;; and they all work!  The formulas which divided bq by ap tended to
;;; be smaller; but we don't have bq unless we factor ap.  Dividing by
;;; ap alone or sqrt(ap) yielded errors.  Removing that term worked
;;; and yields smaller numbers than multiplying by ap.

;;; We don't have the degree of Q available when computing this, so
;;; assume the degree(P)-1 (which I tested).

;;; Return twice the Landau-Mignotte Bound of the coefficients of f
(define landau-mignotte-bound*2
  (cond
   ((provided? 'inexact)
    (lambda (p)
      (inexact->exact
       (ceiling
	(abs (* 2
		(sqrt (apply + (map (lambda (x) (* x x)) (cdr p))))
		(integer-expt 2 (u:degree p))))))))
   (else
    (require 'root)
    (lambda (p)
      (abs (* 2
	      (integer-sqrt (apply + (map (lambda (x) (* x x)) (cdr p))))
	      (integer-expt 2 (u:degree p))))))))

;;; ceiling integer logarithm of y base b
(define (cilog b y)
  (do ((t 1 (* t b))
       (e 0 (+ 1 e)))
      ((> t y) e)))

;;; Return a suitable power for the prime p to be raised to, to
;;; cover all possible coefficients of poly and its factors.
(define (u:prime-power poly p)
  (cilog p (landau-mignotte-bound*2 poly)))

;;; Generate the list of correct leading coefficients
;;; uniqs - association list of a unique prime factor for each leading
;;; coefficient of a polynomial's factors, evaluated over some ideal and their
;;; corresponding unevaluated multivariate factors.
;;; iflcs - factors of the leading coefficient of the univariate image of the
;;; polynomial, evaluated over the same ideal.

(define (correct-lcs uniqs imagelcs lc)
  (map
   (lambda (current-imagelc)
     (let ((res 1)
	   (lun (length uniqs)))
       (let loop ((i 0))
	 (cond ((and (not (equal? 1 lc)) (< i lun))
		(let* ((current (list-ref uniqs i))
		       (unique-prime (car current))
		       (fact (cadr current)))
		  (let loop1 ()
		    (cond ((and (zero? (remainder current-imagelc unique-prime))
				(poly:/? lc fact))
			   (set! res (poly:* fact res))
			   (set! current-imagelc
				 (quotient current-imagelc unique-prime))
			   (set! lc (poly:/ lc fact))
			   (loop1)))
		    (loop (+ 1 i)))))
	       (else
		res)))))
   imagelcs))

;;; Factorise square-free primitive multivariate polynomial over Z (sorted)
(define (poly:factorszpp ppoly)
  (if (number? ppoly)
      ppoly
      (let* ((vars (poly:vars ppoly))
	     (spec-var (car ppoly))
	     (maxdeg (poly:degree ppoly spec-var))
	     (ivars (del spec-var vars '()))
	     (nivars (length ivars))
	     (lcpoly (poly:leading-coeff ppoly spec-var))
	     (lcfactors (if (number? lcpoly)
			    (remove-duplicates (factor lcpoly))
			    (strip-powers (poly:factorz lcpoly) '())))
	     (lcnums
	      (apply append (map (lambda (x) (if (number? x) (list x) '()))
				 lcfactors)))
	     (nlcnums (length lcnums))
	     (nlcfs (length lcfactors)))
	(let loop ((start 1))
	  (let* ((image ppoly)
		 (iu
		  (let loopi ((mr+1 (+ nivars nlcnums 2))
			      (random-ideal (make-random-ideal
					     ivars lcnums (+ nivars nlcnums 3))))
		    (let* ((poly1 (poly:eval-ideal image random-ideal))
			   (elcfactors
			    (map (lambda (x)
				   (remove-duplicates
				    (factor (poly:eval-ideal x random-ideal))))
				 lcfactors))
			   (us (uniques elcfactors)))
		      (cond
		       ((or (unlucky? maxdeg poly1 spec-var) (some null? us))

			(if (> mr+1 (+ nivars nlcnums 100))
			    (math:error 'poly:factorszpp
					(- mr+1 (+ nivars nlcnums))
					" tries on" lcnums)
			    (loopi (+ mr+1 1)
				   (make-random-ideal ivars lcnums mr+1))))
		       (else
			(set! image poly1)
			(list random-ideal
			      (if (eqv? 1 lcpoly)
				  (make-list nlcfs '(1 1))
				  (map list (map car us) lcfactors))))))))
		 (ideal (car iu))
		 (uniqs (cadr iu))
		 (p (let loopp ((cp 3))
		      (cond ((and (= maxdeg (ff:degree cp image))
				  (every (lambda (x) (eqv? x 1))
					 (map cadr (ff:sff cp image))))
			     cp)
			    ((> cp 1000)
			     (math:error 'poly:factorszpp
					 " tried all primes up to "
					 cp))
			    (else (loopp (car (primes> (+ 1 cp) 1)))))))
		 (image-factors
		  (let* ((slpoly (sign (univ:lc image)))
			 (cpoly (univ:cont image))
			 (factors (poly:sort-factors (u:factorsz image))))
		    (if (and (= cpoly 1) (= slpoly 1))
			factors
			(cons (list spec-var (* slpoly cpoly)) factors))))
		 (imagelcs (map (lambda (p) (univ:lc p)) image-factors))
		 (k (u:prime-power image p)))
	    (if (= (length image-factors) 1)
		(list ppoly)
		(let* ((clcs (correct-lcs uniqs imagelcs lcpoly))
		       (res (hen:mhenseln ppoly ideal p k image-factors clcs)))
		  (if (not res)
		      (if (> start 30)
			  (math:error 'poly:factorszpp "too many tries." start)
			  (loop (+ 1 start)))
		      res))))))))

;;; Find a modulus good for factoring a square-free univariate polynomial
(define (squarefreeness-preserving-modulus poly)
  (define var (u:var poly))
  (define poly-degree (u:degree poly))
  (let loop ((prime 3))
    (if (or (not (= poly-degree (ff:degree prime poly)))
	    (not (u:one? (ff:euclid-gcd prime (ff:diff prime poly var)
					(ff:unorm prime poly)))))
	(loop (car (primes> (+ 1 prime) 1)))
	prime)))

;;; Factorise a square-free univariate polynomial over the integers
(define (u:factorsz f1)
  (let* ((var (u:var f1))
	 (lf  (univ:lc f1))
	 (p (squarefreeness-preserving-modulus f1))
	 (pfs (ff:berlekamp p (fluid-let ((*modulus* (symmetric:modulus p)))
				(univ:make-monic f1))))
	 (n (length pfs))
	 (answer '()))
    (cond
     ((eqv? 1 n) (list f1))
     (else
      (let* ((k (u:prime-power f1 p))
	     (p^k (integer-expt p k))
	     (s-p^k (symmetric:modulus p^k))
	     (factors
	      (case n
		((2)  (hen:ulhensel2 f1 (car pfs) (cadr pfs) p k))
		((3)  (hen:ulhensel3 f1 (car pfs) (cadr pfs) (caddr pfs) p k))
		(else (hen:ulhenseln f1 pfs p k)))))
	(for-each (lambda (x)
		    (let ((x*lf (fluid-let ((*modulus* s-p^k))
				  (poly:times-const lf x))))
		      (cond ((eqv? 0 (univ:prem (poly:* f1 lf) x*lf))
			     (set! answer (cons (u:primz x*lf) answer))
			     (set! factors (delete x factors))
			     (set! n (+ -1 n))))))
		  factors)
	(cond
	 ((null? factors) answer)
	 (else
	  (case (length pfs)
	    ((2)  (list f1))
	    ((3)  (cons (u:primz
			 (fluid-let ((*modulus* s-p^k))
			   (reduce-init univ:* (list var lf) factors)))
			answer))
	    (else (call-with-current-continuation
		   (lambda (exit)
		     (let loop ((combine 2))
		       (cond
			((<= (* 2 combine) n)
			 (for-each
			  (lambda (u)
			    (let ((g*lf (fluid-let ((*modulus* s-p^k))
					  (reduce-init univ:*
						       (list var lf) u))))
			      (cond
			       ((eqv? 0 (univ:prem f1 g*lf))
				(set! answer (cons (u:primz g*lf) answer))
				(for-each (lambda (x)
					    (set! factors (delete x factors)))
					  u)
				(set! n (- n combine))
				(if (> (* 2 combine) n) (exit #t))))))
			  (combinations factors combine))
;;; I (jaffer) am unable to find an example to exercise this LOOP.
			 (jacal:found-bug 'u:factorsz 'loop)
			 (loop (+ combine 1))
			 )))))
;;; At this point the code tests for (null? factors) and returns
;;; answer if true.  This doesn't seem to happen.
		  (if (null? factors)
		      (jacal:found-bug 'u:factorsz 'got-null-factors answer)
		      (cons (u:primz
			     (fluid-let ((*modulus* s-p^k))
			       (reduce-init univ:* (list var lf) factors)))
			    answer)))))))))))

;;(load "debug") (trace-all "hensel.scm") (trace poly:eval-ideal lcsubst hen:multivariate-diophantine hen:mhenseln uniques poly:factorszpp)	;poly:evaln make-random-ideal
