;; "uv-hensel.scm" Univariate Hensel Lifting.	-*-scheme-*-
;; Copyright 1994, 1995 Mike Thomas
;; Copyright 2002 Aubrey Jaffer
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or (at
;; your option) any later version.
;; 
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(require 'hash-table)
(require 'fluid-let)
(require 'polynomial-factors)
(require-if '(and compiling (not inexact)) 'math-integer)
(require 'common-list-functions)

;;; =================== Memoize procedure calls ===================
;;; From Norvig "Artificial Intelligence Programming"
;;; Examples:
;;; (define fib
;;;   (memon (lambda (n)
;;;	 (if (<= n 1) 1
;;;	    (+ (fib (+ -1 n)) (fib (+ -2 n)))))))
;;;
;;; (define sum
;;;   (memon (lambda (x y)
;;;	 (+ x y))))
;;;
(define (memon fn)
  (let ((table (make-hash-table 100))
	(gethash (hash-inquirer equal?))
	(puthash (hash-associator equal?)))
    (lambda x
      (let ((val (gethash table x)))
	(if val
	    val
	    (let ((fx (apply fn x)))
	      (puthash table x fx)
	      fx))))))

;;;; GCL Algorithm 2.2 (p. 36)
;;;
;;; Extended Euclidean algorithm returns the list (g s t),
;;; where g is the gcd of a and b, and g = s*a + t*b.
;;; for univariate polynomials over Z mod n:
(define (ff:eea-gcd a b n)
  (define var (car a))
  (fluid-let ((*modulus* (symmetric:modulus n)))
    (letrec ((feg (lambda (c c1 c2 d d1 d2)
		    (if (univ:zero? d)
			(list c c1 c2)
			(let* ((qr (ff:p/p->qr n c d))
			       (r1 (number->poly
				    (poly:- c1 (univ:* (car qr) d1))
				    var))
			       (r2 (number->poly
				    (poly:- c2 (univ:* (car qr) d2))
				    var)))
			  (feg d d1 d2 (cadr qr) r1 r2))))))
      (let* ((aone (list var 1))
	     (azero (list var 0))
	     (result (feg (univ:make-monic a) aone azero
			  (univ:make-monic b) azero aone))
	     (c (car result)))
	(cons
	 (univ:make-monic c)
	 (list
	  (poly:* (cadr result)
		  (coef:invert (* (ff:lc n a) (ff:lc n c))))
	  (poly:* (caddr result)
		  (coef:invert (* (ff:lc n b) (ff:lc n c))))))))))

(define (check-ext-gcd caller a s b t p)
  (define x (car a))
  (set! s (ff:unorm p s))
  (set! t (ff:unorm p t))
  (cond
   ((not (< (univ:deg s) (univ:deg b)))
    (math:warn "(>= (univ:deg s) (univ:deg b))" s b))
   ((not (< (univ:deg t) (univ:deg a)))
    (math:warn "(>= (univ:deg t) (univ:deg a))" t a)))
  (fluid-let ((*modulus* p))
    (let ((inner-prod (ff:unorm
		       p
		       (number->poly (poly:+ (poly:* a s) (poly:* b t))
				     x))))
      (cond ((not (univ:one? inner-prod x))
	     (math:warn caller "result is not correct.")
	     (math:warn " a = " a)
	     (math:warn " b = " b)
	     (math:warn " s = " s)
	     (math:warn " t = " t)
	     (math:warn " inner-prod = " inner-prod)
	     (math:error " should be = " (list x 1)))))))

;;;; GCL Algorithm 6.3 (p. 271)
;;;
;;; hen:eea-lift computes s, t such that s * a + t * b = 1 (mod p^k),
;;; with deg(s) < deg(b), deg(t) < deg(a).
;;; Assumption: GCD(a mod p, b mod p) = 1 in Z_p[x],
;;; a and b must have the same variable and be univariate.
;;;
;;; 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)
     (define p^k (expt p k))
     (if (not (equal? (car a) (car b)))
	 (math:error 'hen:eea-lift "polys not in the same variable." a b))
     (let* ((x (car a))
	    (amodp (ff:unorm p a))
	    (bmodp (ff:unorm p b))
	    (g-s-t (ff:eea-gcd amodp bmodp p)) ;returns list (g s t)
	    (s (cadr g-s-t))
	    (t (caddr g-s-t))
	    (smodp s)
	    (tmodp t)
	    (modulus p))
       (cond ((not (univ:one? (car g-s-t) x))
	      (math:error 'ff:eea-gcd 'returned (car g-s-t))))
       (check-ext-gcd 'ff:eea-gcd a s b t p)
       (do ((j 1 (+ 1 j)))
	   ((>= j k)
;	    (check-ext-gcd 'hen:eea-lift amodp s bmodp t p^k)
	    (list s t))
	 (let* ((e  (number->poly
		     (poly:- (list x 1) (poly:+ (poly:* s a) (poly:* t b)))
		     x))
		(c  (ff:unorm p (univ/scalar 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-mel as p k result)
  (define p^k (expt p k))
  (fluid-let ((*modulus* (symmetric:modulus p^k)))
    (let* ((la (length as))
	   (x (car (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)))
	(cond ((not (univ:one? inner-prod x))
	       (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 Algorithm 6.3 (p. 270)
;;;
;;; Compute s_1, ..., s_r such that
;;;   S_1 * b_1 + ... + S_r * b_r = x^m (mod p^k)
;;; with deg(s_j) < deg(a_j) where, in terms of the given list of
;;; polynomials a_1, ..., a_r, the polynomials B_i are defined by:
;;;   b_i = a_1 * ... a_i-1 * a_i+1 * ... * a_r, i = 1, ..., r
;;;
;;; Conditions:
;;;   p must not divide lcoeff(a_i), i = 1, ..., r;
;;;   a_i mod p, i = 1, ..., r, must be pairwise relatively prime in Z_p[x].
(define hen:multiterm-eea-lift
  (memon (lambda (a p k)
	   (let* ((r (length a))
		  (var (car (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)))))


;;; Checks:
;;;   p must not divide lcoeff(a_i), i = 1, ..., r;
;;;   a_i mod p, i = 1, ..., r, must be pairwise relatively prime in Z_p[x].
(define (ff:check-pairwise-relatively-prime p a x1)
  (do ((as (map (lambda (a)
		  (cond ((eqv? 0 (modulo (univ:lc a) p))
			 (math:error 'lc-0-divider a)))
		  (ff:unorm p a))
		a)
	   (cdr as))
       (oas a (cdr oas)))
      ((null? as))
    (let ((af (car as))
	  (oaf (car oas)))
      (for-each (lambda (ao oao)
		  (define g-s-t (ff:eea-gcd af ao p))
		  (cond ((not (equal? x1 (car g-s-t)))
			 (math:warn oaf oao 'mod p)
			 (math:error 'not-relatively-prime
				     af ao '==> (car g-s-t)))))
		(cdr as)
		(cdr oas)))))

(define (check-hd as c p k result)
  (define p^k (expt p k))
  (fluid-let ((*modulus* (symmetric:modulus p^k)))
    (let* ((la (length as))
	   (x (car 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)
	       ))))))

;;; memoised diophantine equation solver is much faster
(define hen:diophantine
  (memon (lambda (a c p k)
	   (let* ((r     (length a))
		  (p^k   (expt p k))
		  (x1    (car c))
		  (dc    (univ:deg c))
		  (sigma (make-list r 0)))
	     (let loop ((m 1))
	       (if (<= (+ -1 m) dc)
		   (let* ((cm (list-ref c m))
			  (ds (hen:univariate-diophant 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-hd1 as x m p k result)
  (let* ((la (length as))
	 (p^k (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:univariate-diophant: 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 Algorithm 6.3 (p 270)
;;;
;;; Solve in Z_p^k[x] the univariate polynomial diophantine equation:
;;;    S_1 * b_1 + ... + S_r * b_r = x^m (mod p^k)
;;; where, in terms of the given list of polynomials a_1, ..., a_r,
;;; the polynomials b_i, i = 1, ..., r, are defined by:
;;;   b_i = a_1 * ... * a_i-1 * a_i+1 * ... a_r.
;;; The unique solution S_1, ..., S_r, will be computed such that
;;;   deg(S_i) < deg(a_i).
;;;
;;; Conditions:
;;;   p must not divide lcoeff(a_i), i = 1, ..., r;
;;;   a_i mod p, i = 1, ..., r, must be pairwise relatively prime in Z_p[x].
;;;
;;; The value returned is the list S = [S_1, ..., S_r].
(define hen:univariate-diophant
  (memon (lambda (a x m p k)
	   (ff:check-pairwise-relatively-prime p a (list x 1))
	   (let ((r (length a))
		 (p^k (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)))
			 ((>= 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))
			  (q-r (ff:p/p->qr p^k (poly:* xm (car s))
					   (car a)))
			  (q (car q-r))
			  (result (list (cadr q-r)
					(poly:+ (poly:* xm (cadr s)) ;ff:p+p p^k
						(poly:* q (cadr a))))))
		     (check-hd1 a x m p k result)
		     result)))))))

;;; 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 (car f)))
    (let loop ((i 2)
	       (modulus p)
	       (modulus*p (* p p)))
      (if (<= i k)
	  (let* ((discrepancy
		  (univ/scalar
		   (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 (car f)))
    (let loop ((l 2)
	       (modulus p)
	       (modulus*p (* p p)))
      (if (<= l k)
	  (let* ((diff
		  (univ/scalar
		   (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 (car f))
	(lf (univ:lc f)))
    (let loop ((l 2)
	       (modulus p)
	       (modulus*p (* p p)))
      (if (<= l k)
	  (let* ((diff
		  (univ/scalar
		   (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))))

;;;; 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))))
		(expt 2 (univ:deg p))))))))
   (else
    (require 'math-integer)
    (lambda (p)
      (abs (* 2
	      (integer-sqrt (apply + (map (lambda (x) (* x x)) (cdr p))))
	      (expt 2 (univ:deg 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)))

;;; Find a modulus good for factoring a square-free univariate polynomial
(define (squarefreeness-preserving-modulus poly)
  (define poly-degree (univ:deg poly))
  (let loop ((prime 3))
    (define ply (ff:unorm prime poly))
    (cond ((< 100 prime) (jacal:found-bug 'no-suitable-primes<100 poly))
	  ((or (not (= poly-degree (univ:deg ply)))
	       (not (univ:one? (ff:euclid-gcd prime
					      (ff:diff prime ply (car poly))
					      ply)
			       (car poly))))
	   (loop (car (primes> (+ 1 prime) 1))))
	  (math:debug (print 'squarefreeness-preserving-modulus prime))
	  (else prime))))

;;; Factorise a square-free univariate polynomial over the integers
(define (u:factorsz f1)
  (let* ((var (car 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 '()))
    (if (eqv? 1 n)
	(list f1)
	(let* ((k (u:prime-power f1 p))
	       (p^k (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)
	  (if (null? factors)
	      answer
	      (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))
;;; factor((x^5+y^5)^5-(x^5-y^5)^5);
;;; exercises this 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)))))))))

;;(require 'debug-jacal) (trace-all "hensel.scm") (trace poly:eval-ideal lcsubst hen:multivariate-diophant hen:multivariate-hensel) ;poly:evaln make-random-ideal
;;(require 'debug-jacal) (trace make-random-ideal unlucky?)
