;;; "ff.scm" Polynomial factorization.		-*-scheme-*-
;;; Copyright 1994, 1995 Mike Thomas
;;; See the file "COPYING" for terms applying to this program.

;;; AUTHOR
;;;	  Mike Thomas
;;;	  46 Harold Street
;;;	  STAFFORD  QLD	 4053
;;;	  AUSTRALIA
;;;
;;;	  Phone: Intl + 61 7 356 8494
;;;	  Email: mjt@octavia.anu.edu.au

;;; SOURCES
;;; These algorithms are drawn from:
;;;
;;; (GCL)
;;; Algorithms for Computer Algebra
;;;  by Keith O. Geddes, Stephen R. Czapor, George Labahn
;;;  (October 1992) Kluwer Academic Pub; ISBN: 0-7923-9259-0
;;;
;;; Computer Algebra: Systems and Algorithms for Algebraic Computation
;;;  by Y. Siret (Editor), E. Tournier, J. H. Davenport, F. Tournier
;;;  2nd edition (June 1993) Academic Press; ISBN: 0-122-04232-8
;;;
;;; The Art of Computer Programming : Seminumerical Algorithms (Vol 2)
;;;  by Donald Ervin Knuth
;;;  2nd Ed (1981) Addison-Wesley Pub Co; ISBN: 0-201-03822-6
;;; A new edition of this book is availble:
;;;  3rd Ed (November 1997) Addison-Wesley Pub Co; ISBN: 0-201-89684-2

;;; DEVELOPMENT LANGUAGE
;;; SCM 4e1, 4e2 compiled with DICE v 2.07.54

;;; DEVELOPMENT SYSTEM
;;; Amiga 1200, 2Mb Chip RAM, 4Mb Fast RAM, 50MHz 68030 CPU No FPU,
;;; Workbench 3.0 (until a power supply problem stuffed it that is.)

;;; DEPENDENCIES
;;; You need R4RS Scheme, SLIB and JACAL (latest versions).
;;; Multiargument *, +

;;; REPRESENTATIONS
;;; The modular homomorphism sym:sym maps the integers to a symmetric
;;; representation, following the numerous examples in GCL. This
;;; mapping does not seem to correspond with GCL's own definition of Z
;;; mod n using a simple remainder algorithm.

;;; The univariate polynomials expected and returned by the Scheme
;;; procedures are JACAL's list representation, not numbers by
;;; themselves.  There is no attempt to cover sparse polynomials yet.

;;; An ideal is a list of lists, each one specifying a variable and
;;; it's value eg '((y 1) (z 2) (p -1)).

;;; DESIGN PHILOSOPHY

;;; 1. Fun;

;;; 2. Correct operation for univariate and multivariate polynomials
;;;    over the rationals (Q), then maybe over algebraic number fields;

;;; 3. refine the algorithms for speed after they work correctly;

;;; 4. make the system workable even for smaller computers, based on the
;;;    crude and discriminatory assumption that people who want to
;;;    crack large problems can afford to buy or write larger systems;

;;; 5. and ideally, I want the system to handle investigation of
;;;    the stability of systems of differential equations
;;;    which requires algebraic solution of eigensystems,
;;;    and for an attempt on the Risch integration algorithm.

;;; I have therefore initially used Linear Hensel Lifting and the small prime
;;; Berlekamp Algorithm. I make no attempt yet, among other possibilities,
;;; to optimise the factorisation process dynamically by checking
;;; several primes or restarting the algorithm on testing for true factors
;;; after the Berlekamp process. Later. Perhaps.

;;; NAMING
;;;	     u: univariate polynomials, should be JACAL's univ:
;;;	    ff: polynomials over finite integer fields using the
;;;		symmetric representation
;;;	   sym: symmetric representation integers
;;;	  poly: Jacal poly types
;;;	   hen: Hensel lifting procedures

;;; ABBREVIATIONS
;;;	     Q:	The Rational numbers
;;;	     Z:	The integers

;;; ARGUMENT CODING CONVENTIONS
;;;	    ff: the modulus argument is the last in the argument list

;;; KNOWN BUGS

;;; -- factorq((2*z+y-x)*(y^3*z-a*x^2)*(b*z^2+y));
;;;    factorq((a*a*b*z+d)*(2*a*b*b*z+c)*((u+a)*z+1));
;;;    Hang my presently memory challenged computer during poly:sff
;;;	probably because of lack of room

;;; -- Parfrac worketh not. Wherefore? Because I trieth too hard to
;;;    be clevereth. This one can wait.

;;; -- The result is not always sorted or normalised.


;;; KNOWN MINOR PROBLEMS (FROM MY POINT OF VIEW)

;;; -- Output format sometimes gets misaligned.

;;; -- Speed is not great.  See DESIGN PHILOSOPHY above.

;;; -- Factorization over Q needs to return monic polynomials if it is
;;;    to produce complete unique unit normal factorisations. Factorisation
;;;    over Z and Q would also need to factorise numeric content in this case.

(require 'array)
(require 'array-for-each)
(require 'common-list-functions)
(require 'modular)
(require 'hash-table)
(require 'sort)
(require 'factor)

;;(load (in-vicinity jacal-vicinity "debug"))

(define sym:invert (lambda (m a) (modular:invert (quotient m -2) a)))
(define sym:sym (lambda (m a) (modular:normalize (quotient m -2) a)))

;;;; Here are scalar sorts of functions which MJT added.

(define (sign a)
  (if (negative? a) -1 1))

;;; (jaffer) printer for diagnostic information
(define (ff:print . args)
  (define result #f)
  (for-each (lambda (x) (set! result x) (display-diag x) (display #\ )) args)
  (newline-diag)
  result)

;;; Idea copied from SLIB on Aubrey Jaffer's suggestion
(define (poly:sort-factors fs)
  (sort! fs poly:factor<))

(define (poly:sort-merge-factors fs)
  (define factors-list (poly:sort-factors fs))
  (define (doit facts exp factors-list)
    (cond ((null? factors-list) (list (list (poly:sort-factors facts) exp)))
	  ((equal? exp (cadar factors-list))
	   (doit (append facts (caar factors-list)) exp (cdr factors-list)))
	  (else (cons (list (poly:sort-factors facts) exp)
		      (doit (caar factors-list)
			    (cadar factors-list)
			    (cdr factors-list))))))
  (doit (caar factors-list) (cadar factors-list) (cdr factors-list)))

(define (poly:factor< x y)
  (define (lnumber? x)
    (cond ((number? x) #t)
	  ((list? x) (and (= 1 (length x)) (number? (car x))))
	  (else #f)))
  (cond ((and (number? x) (number? y)) (< x y))
	((and (lnumber? x) (lnumber? y)) (< (car x) (car y)))
	((lnumber? x) #t)
	((lnumber? y) #f)
	((null? x) #t)
	((null? y) #f)
	((and (symbol? x) (symbol? y)) (string<? (symbol->string x)
						 (symbol->string y)))
	((vector? (car x))
	 (if (string<=? (vector-ref (car x) 1) (vector-ref (car y) 1))
	     (poly:factor< (cdr x) (cdr y)) #f))
	((> (length x) (length y)) #f)
	((< (length x) (length y)) #t)
	((and (list? x)
	      (list? y))
	 (cond
	  ((poly:factor< (univ:lc x) (univ:lc y)) #t)
	  ((poly:factor< (univ:lc y) (univ:lc x)) #f)
	  (else (poly:factor< (butlast x 1) (butlast y 1)))))
	((list? x)
	 (poly:factor< (but-last x 1) y))
	((list? y)
	 (poly:factor< x (but-last y 1)))
	(else
	 (slib:error "poly:factor<: unknown type" x y))))

;;; Memoize an n argument procedure fn 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))))))

;================================================================

(define (ff:degree n p)
  (- (length (ff:unorm n p)) 2))

(define (u:degree p)
  (- (length p) 2))

(define (ff:leading n p)
  (sym:sym n (univ:lc p)))

(define u:var car)

(define (u:zero? p)
  (and (= (length p) 2) (zero? (cadr p))))

(define (u:one? p)
  (and (= (length p) 2) (= (cadr p) 1)))

(define (u:number? p)
  (and (= (length p) 2) (number? (cadr p))))

;;; Return a polynomial in variable v if given a number, otherwise the
;;; polynomial.	 Assumes "otherwise" is a polynomial
(define (number->poly a v)
  (if (number? a) (list v a) a))

;;;================================================================
;;;================================================================
;;; Standard Euclidean algorithm for polynomial gcd over Z mod n
(define ff:euclid-gcd
  (lambda (modulus x y)
    (set! x (ff:unorm modulus x))
    (set! y (ff:unorm modulus y))
    (fluid-let ((*modulus* (symmetric:modulus modulus)))
      (cond
       ((u:zero? x) (univ:make-monic y))
       ((u:zero? y) (univ:make-monic x))
       (else
	(let ((ans (univ:fgcd x y)))
	  (if (number? ans) (list (car x) ans) ans)))))))

;;; Extended Euclidean algorithm returns the list (g s t),
;;; where g is the gcd of a and b, and g = s*a + t*b.
;;; GCL algorithm 2.2
;;; for univariate poly's over Z mod n:
(define (ff:eea-gcd a b n)
  (define var (u:var a))
  (fluid-let ((*modulus* (symmetric:modulus n)))
    (letrec ((feg (lambda (c c1 c2 d d1 d2)
		    (if (u: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:leading n a) (ff:leading n c))))
	  (poly:* (caddr result)
		  (coef:invert (* (ff:leading n b) (ff:leading n c))))))))
    ))

;;; Numeric content and primitive part of a univariate polynomial p
;;; u(p) returns the sign of the leading coefficient of p
(define (u:unitz p)
  (sign (univ:lc p)))

;;; This truncating divide uses quotient, not /
(define (u:p/c a c)
  (cons (u:var a) (map (lambda (x) (quotient x c)) (cdr a))))

(define (u:primz p)
  (u:p/c p (* (u:unitz p) (univ:cont p))))

;;; Polynomial sign, content and primitive part of a multivariate polynomial
;;; p, with respect to var.
;;; poly:unitz returns the sign of the leading coefficient of the polynomial p.
(define (poly:unitz p var)
  (sign (leading-number (poly:leading-coeff p var))))

(define (poly:primz p var)
  (if (number? p)
      (abs p)
      (unitcan (poly:/ p (unitcan (univ:cont p))))))

;;(trace poly:contz poly:primz poly:unitz)

;;; remove leading zeros of a poly with already modularised coefficients
(define (u:lose-lzeros p)
  (let* ((l  (length p))
	 (nl (do ((i  (+ -1 l) (+ -1 i)))
		 ((or (not (zero? (list-ref p i))) (< i 2)) (+ 1 i)))))
    (if (not (= nl l))
	(reverse (list-tail (reverse p) (- l nl)))
	p)))

;;; reduce univariate p mod n and remove any consequential leading
;;; zero coefficients
(define (ff:unorm n p)
  (u:lose-lzeros (cons (u:var p) (map (lambda (x) (sym:sym n x)) (cdr p)))))

;;; Same but ultivariate, uses poly:modularize in poly.scm
;;; and using sym:sym instead of modulo.
(define (ff:mnorm modulus poly)
  (poly:modularize (symmetric:modulus modulus) poly))

;;; Go through a polynomial and convert each zero degree polynomial coefficient
;;; to a number.
(define (poly:0-degree-norm p)
;;;(ff:print p)
  (cond
    ((number? p) p)
    ((= (length p) 2) (poly:0-degree-norm (cadr p)))
    (else
      (let ((end-bit (map-no-end-0s poly:0-degree-norm (cdr p))))
	(if (null? end-bit) 0
	  (cons (car p) end-bit))))))

(define ff:p/p->qr
  ;;(debug:check ff:p/p->qr-mjt
  (lambda (modulus x y)
    (set! x (ff:unorm modulus x))
    (set! y (ff:unorm modulus y))
    (if (< (length x) (length y))
	(list (list (car x) 0) (ff:unorm modulus x))
	(fluid-let ((*modulus* (symmetric:modulus modulus)))
	  (map (lambda (ans)
		 (if (number? ans) (list (car x) ans) ans))
	       (univ:fdiv x y)))))
  ;;'ff:p/p->qr-mjt
  ;;'univ:fdiv)
  )

(define (ff:p/p p a b)
  (let ((u (ff:unorm p a))
	(v (ff:unorm p b)))
    (let ((m (ff:degree p u))
	  (n (ff:degree p v)))
      (cond
       ((u:zero? v)
	(slib:error 'ff:p/p "Division by 0 is undefined."))
       (else
	(car (ff:p/p->qr p u v)))))))

;;; Given a primitive polynomial a(v) which is an element of a
;;; Unique Factorisation Domain in v, calculate the square free
;;; factorisation of a(v). A primitive polynomial has the content
;;; removed from its coefficients.  The content is the gcd of the
;;; coefficients.
;;; from page 340 of Geddes et al, Algorithms for Computer Algebra
;;;    - mjt
(define (u:sff a)
  (let* ((v (u:var a))
	 (b (poly:diff a v))
	 (c (unitcan (poly:gcd a b)))
	 (w (poly:/   a c))
	 (y 0)
	 (z 0)
	 (output '()))
    (poly:sort-factors
     (let loop ((i 1))
       (cond ((not (equal? c 1))
	      (set! y (unitcan (poly:gcd w c)))
	      (set! z (poly:/ w y))
;;;	      (ff:print "y = " y " w = " w " c = " c " z = " z)
	      (if (not (number? z))
		  (set! output (append output (list (list z i)))))
	      (set! w y)
	      (set! c (poly:/ c y))
;;;	      (ff:print "c = " c)
	      (loop (+ 1 i)))
	     (else (append output (list (list w i)))))))))

(define (poly:sff a)
  (if (number? a) (list (list a 1))
      (let* ((v (car a))
	     (b (poly:diff a v))
	     (c (unitcan (poly:gcd a b)))
	     (w (poly:/   a c))
	     (y 0)
	     (z 0)
	     (output '()))
	(poly:sort-factors
	 (let loop ((i 1))
	   (cond ((eqv? c 1)
		  (append output (list (list w i))))
		 (else
		  (set! y (unitcan (poly:gcd w c)))
		  (set! z (poly:/ w y))
		  (if (not (number? z))
		      (set! output (append output (list (list z i)))))
		  (set! w y)
		  (set! c (poly:/ c y))
		  (loop (+ 1 i)))))))))
;;;(trace poly:sff)

(define (ff:gfroot n p var)
  (let ((d (ff:degree n p)))
    (if (zero? (sym:sym n d))
	(let* ((u (quotient d n))
	       (v (make-vector (+ 1 u) 0)))
	  (vector-set! v u 1)
	  (vector-set! v 0 1)
	  (cons var (vector->list v)))
	(slib:error 'ff:gfroot "polynomial has no root." p))))

(define (ff:diff n p v)
  (if (equal? (u:var p) v)
      (do ((i (- (length p) 1) (+ -1 i))
	   (r '() (cons (sym:sym n (* (+ -1 i) (list-ref p i))) r)))
	  ((< i 2) (cons v r)))
      (list v 0)))

(define (ff:sff p a)
  (let* ((v (u:var a))
	 (b (ff:diff p a v))
	 (output '()))
    (cond ((not (equal? b (list v 0)))
	   (let* ((c (ff:euclid-gcd p a b))
		  (w (ff:p/p p a c))
		  (y 0)
		  (z 0))
	     (let loop ((i 1))
	       (cond ((not (equal? w (list v 1)))
		      (set! y (ff:euclid-gcd p w c))
		      (set! z (ff:p/p p w y))
		      (if (not (u:one? z))
			  (set! output (append output (list (list z i)))))
		      (set! w y)
		      (set! c (ff:p/p p c y))
		      (loop (+ 1 i)))))
	     (cond ((not (equal? c (list v 1)))
		    (set! c (ff:gfroot p c v))
		    (set! output (append output
					 (list (list (ff:sff p c) p))))))))
	  (else (set! a (ff:gfroot p a v))
		(set! output (append output (list (list (ff:sff p a) p))))))
    output))

(define (ff:q-matrix p a1)
  (let* ((a (ff:unorm p a1))
	 (n (ff:degree p a))
	 (n-1 (+ -1 n))
	 (q (create-array (As32 0) n n))
	 (r (create-array (As32 0) n))
	 (r1 (create-array (As32 0) n))
	 (u (* n-1 p))
	 (b (list->vector a)))
    (array-set! q 1 0 0)
    (array-set! r 1 0)
    (array-set! r1 1 0)
    (let loop ((i 1))
      (cond ((> i u) q)
	    (else
	     (array-set! r (* (vector-ref b 1) (- 0 (array-ref r1 n-1))) 0)
	     (let loop1 ((j 1))
	       (cond ((<= j n-1)
		      (array-set!
		       r (sym:sym p (- (array-ref r1 (+ -1 j))
				       (sym:sym p (* (vector-ref b (+ 1 j))
						     (array-ref r1 n-1)))))
		       j)
		      (loop1 (+ 1 j)))))
	     (array-map! r1 identity r)
	     (if (zero? (modular:normalize p i))
		 (array-map! (make-shared-array
			      q (lambda (j) (list (quotient i p) j)) n)
			     identity r))
	     ;;(ff:print i "  r = " r "  q = " q)
	     (loop (+ 1 i)))))))

;;; Knuth's null-space-basis, slower but works
(define (ff:null-space-basis p mo var)
  (let* ((n (car (array-dimensions mo)))
	 (m (create-array '#(#f) n n))
	 (c (make-vector n -1))
	 (ivec (array-indexes (create-array (Au16 1) n)))
	 (result '()))
    (array-map! ivec car ivec)
    (array-copy! mo m)
    (do ((k 0 (+ 1 k)))
	((>= k n))
      (let ((j (do ((b 0 (+ 1 b)))
		   ((or (>= b n)
			(and (negative? (vector-ref c b))
			     (not (zero? (array-ref m k b))))) b))))
	(if (< j n)
	    (let ((muinv  (* -1 (sym:invert p (array-ref m k j))))
		  (mcolj (make-shared-array m (lambda (a) (list a j)) n)))
	      (array-map! mcolj (lambda (x) (sym:sym p (* x muinv))) mcolj)
	      (vector-set! c j k)
	      (do ((i 0 (+ 1 i)))
		  ((>= i n))
		(if (not (= i j))
		    (let ((mcoli (make-shared-array
				  m (lambda (a) (list a i)) n))
			  (mki (array-ref m k i)))
		      (array-map! mcoli
				  (lambda (x y z)
				    (if (>= z k)
					(sym:sym p (+ x (* mki y)))
					x))
				  mcoli mcolj ivec)))))
	    (let ((vr (create-array (As32 0) n))
		  (cl (vector->list c)))
	      (array-map! vr
			  (lambda (i)
			    (let ((cl1 (memv i cl)))
			      (cond
			       ((= i k) 1)
			       (cl1 (array-ref m k (- n (length cl1))))
			       (else 0))))
			  ivec)
	      (set! result (append result
				   (list (u:lose-lzeros
					  (cons var (ravect->list vr))))))))))
    result))

;;; -- > (u:factorz p7)
;     ERROR: vector-ref: Argument out of range 2
;     ;Evaluation took 1934 mSec (601 in gc) 19181 cells work, 6439 bytes other
;     > p7
;     ;Evaluation took 1 mSec (0 in gc) 2 cells work, 31 bytes other
;     (x 1 -3 -1 -3 1 -3 1)
;     > (math)
;     type qed; to return to scheme, type help; for help.
;     e5 : factoruz(1-3*x-x^2-3*x^3+x^4-3*x^5 +x^6);
;     poly = (#(x x #f () #f ()) 1 -3 -1 -3 1 -3 1)
;     e1 = (#(x x #f () #f ()) 1 -3 -1 -3 1 -3 1)
;     Arithmetic Error; Last expression lost.
;;; This problem is caused by berlekamp expecting to find factors when
;;; there are none (ie the polynomial is irreducible).	This problem
;;; comes from the ff:null-space-basis-gcl-bug procedure below.	 This
;;; is the only occurrence of this problem I am aware of.
;;; Fixed by using Knuth's null space basis algorithm above.
;;; Unfortunately, this one is faster.
(define (ff:null-space-basis-gcl-bug p mo var)
  (let* ((n (car (array-dimensions mo)))
	 (m (create-array '#(#f) n n)))
    (ff:print " mo = " mo)
    (array-copy! mo m)
    (do ((k 0 (+ 1 k)))
	((>= k n))
      (let ((i (do ((b k (+ 1 b)))
		   ((or (>= b n) (not (zero? (array-ref m k b)))) b))))
	(if (< i n)
	    (let* ((u	  (array-ref m k i))
		   (uinv  (sym:invert p u))
		   (mcoli (make-shared-array m (lambda (a) (list a i)) n))
		   (mcolk (make-shared-array m (lambda (a) (list a k)) n))
		   (temp  (create-array '#(#f) n)))
	      (array-map! mcoli (lambda (x) (sym:sym p (* x uinv))) mcoli)
	      (array-map! temp	identity mcoli)
	      (array-map! mcoli identity mcolk)
	      (array-map! mcolk identity temp)
	      (do ((j 0 (+ 1 j)))
		  ((>= j n))
		(if (not (= j k))
		    (let ((mcolj (make-shared-array
				  m (lambda (a) (list a j)) n))
			  (mkj (array-ref m k j)))
		      (array-map! mcolj
				  (lambda (x y)
				    (sym:sym p (- x (sym:sym p (* mkj y)))))
				  mcolj mcolk))))
;;;(ff:print " m = " m)
	      ))))
    (let ((mdiag (make-shared-array m (lambda (a) (list a a)) n)))
      (array-map! mdiag (lambda (x) (sym:sym p (+ -1 x))) mdiag))
;;;    (ff:print "  After subtraction of 1 along the diagonal,	m = " m)
;;;	 (array-map! m (lambda (x) (sym:sym p (* -1 x))) m)
;;;    (ff:print "  After multiplication of -1 along the diagonal,  m = " m)
    (let (;;(i 0)
	  (ret '()))
      (let loop1 ((j 0))
	(if (< j n)
	    (let ((zerow (make-vector n 0)))
	      (let loop2 ()
		(if (< j n)
		    (let ((mrow (make-shared-array
				 m (lambda (a) (list j a)) n)))
		      (cond ((array-equal? mrow zerow)
			     (set! j (+ 1 j)) (loop2))))))
	      (if (< j n)
		  (let ((v (make-vector n 0))
			(mrowj (make-shared-array
				m (lambda (a) (list j a)) n)))
		    ;;(set! i (+ 1 i))
;;;			 (ff:print " mrowj = " mrowj)
		    (array-copy! mrowj v)
;;;			 (ff:print " v = " v)
		    (set! ret (cons v ret))
		    (loop1 (+ 1 j)))))))
;;;	  (ff:print " ret = " ret)
      (map (lambda (x) (ff:unorm p (cons var (vector->list x))))
	   (reverse ret)))))

;;; return an ordered list of elements of Z mod n (symmetric)
(define (ff:generate-field n)
  (define b (quotient (+ -1 n) 2))
  (do ((idx (+ -1 n) (+ -1 idx))
       (lst '() (cons (- idx b) lst)))
      ((negative? idx) lst)))

;;; return a sorted list of factors of a mod p, where a is square free
;;; and p is a prime number.
(define (ff:berlekamp p a)
  (let* ((q	(ff:q-matrix p a))
	 (n	(car (array-dimensions q)))
	 (var	(u:var a))
	 (qdiag (make-shared-array q (lambda (a) (list a a)) n)))
    (array-map! qdiag (lambda (x) (sym:sym p (+ -1 x))) qdiag)
    (let* ((vs	(list->vector (ff:null-space-basis p q var)))
	   (factors (list a))
	   (ffp (ff:generate-field p))
	   (k (vector-length vs)))
      (fluid-let ((*modulus* (symmetric:modulus p)))
	(do ((r 1 (+ 1 r)))
	    ((not (< (length factors) k))
	     (poly:sort-factors factors))
	  (do ((us factors (if start factors (cdr us)))
	       (start #f #f))
	      ((not (and (< (length factors) k) (not (null? us)))))
	    (let ((u (car us)))
	      (let loop3 ((ss ffp))
		(cond ((and (not (null? ss)) (< (length factors) k))
		       ;;(print '!)
		       (let ((g (ff:euclid-gcd p ;poly:gcd
				 (poly:- (vector-ref vs r) (car ss)) ;(list var )
				 u)))
			 (cond ((and (not (equal? g u))
				     (not (u:one? g)))
				(set! factors (delete u factors))
				(set! u (ff:p/p p u g))
				(set! factors (delete
					       '()
					       (append factors
						       (list u)
						       (list g))))
				(set! start #t))
			       (else (loop3 (cdr ss)))))))))))))))

;;; Evaluate simple univariate polynomials the naive way
(define (u:evaln p n)
  (let ((d+1 (+ 1 (u:degree p))))
    (let loop ((i 2) (i-1 1) (acc (cadr p)))
      (if (> i d+1)
	  acc
	  (loop (+ 1 i) i (+ acc (* (list-ref p i) (integer-expt n i-1))))))))

;;; Substitute n into a univariate polynomial p, without assuming
;;; that p is simple numbers in the coefficients.
(define (u:evalp p n)
 (let ((d+1 (+ 1 (u:degree p))))
  (let loop ((i 2) (i-1 1) (acc (cadr p)))
    (if (> i d+1)
      acc
      (loop (+ 1 i) i (poly:+ acc (poly:* (list-ref p i) (poly:^ n i-1))))))))

;;; Evaluate a polynomial, p, substituting a number n for the variable var
;;; Do some normalisation along the way
(define (poly:evaln p var n)
;;;(ff:print "p " p " var " var " n " n)
  (poly:0-degree-norm
   (cond
    ((number? p) p)
    ((u:number? p) (cadr p))
    ((equal? (car p) var)
     (if (poly:univariate? p)
	 (u:evaln p n)
	 (reduce poly:+
		 (map (lambda (x y) (if (number? x)
					(* x (integer-expt n y))
					(poly:* (poly:evaln x var n)
						(integer-expt n y))))
		      (cdr p)
		      (power-list p var)))))
    (else
     (cons (car p)
	   (map (lambda (x) (if (number? x)
				x (poly:evaln x var n)))
		(cdr p)))))))

;;; evaluate a polynomial p mod the ideal i
;;; (An evaluation homomorphism)
(define (poly:eval-ideal p i)
  (define pei
    (lambda (p i)
      (if (null? i) p (pei (poly:evaln p (caar i) (cadar i)) (cdr i)))))
  (pei p i))

;;; generate the powers of x for a poly
(define (power-list p v)
  (do ((idx (poly:degree p v) (+ -1 idx))
       (lst '() (cons idx lst)))
      ((negative? idx) lst)))

(define (ravect->list ara)
  (define lst '())
  (array-for-each (lambda (x) (set! lst (cons x lst))) ara)
  (reverse lst))

;;; FACTORS-LIST is a list of lists of a list of factors and exponent.
;;; FACT-EXPS is a list of lists of factor and exponent.
(define (factors->sexp factors-list)
  (apply sexp:*
	 (map (lambda (fact-exp)
		(sexp:^
		 (if (number? (car fact-exp))
		     (int:factor (car fact-exp))
		     (cano->sexp (car fact-exp) #f))
		 (cadr fact-exp)))
	      (poly:sort-factors (factors-list->fact-exps factors-list)))))

(define *sort-int-factors* #f)

;;; NUMCONT is the integer numeric content.
(define (u:prepend-integer-factor numcont factors)
  (cond ((one? numcont) factors)
	(*sort-int-factors* (append (int:factors numcont) factors))
	(else (cons (list (list numcont) 1) factors))))

(define (negate-factors-exps fact-exps)
  (reverse
   (map (lambda (fact-exp) (list (car fact-exp) (- (cadr fact-exp))))
	fact-exps)))

;;; Factorise over the Rationals (Q)
;;; return an sexp product of sorted factors of the polynomial POLY
;;; over the integers (Z)
(define (rat:factor->sexp poly)
  (fluid-let ((*sort-int-factors* #f))
    (cond ((rat? poly)
	   (let ((nu (num poly))
		 (de (denom poly)))
	     (sexp:over (if (number? nu)
			    (int:factor nu)
			    (factors->sexp (poly:factorz nu)))
			(if (number? de)
			    (int:factor de)
			    (factors->sexp (poly:factorz de))))))
	  (else (factors->sexp (poly:factorz poly))))))
(define (rat:factors poly)
  (fluid-let ((*sort-int-factors* #t))
    (poly:sort-merge-factors
     (cond ((rat? poly)
	    (append (poly:factorz (num poly))
		    (negate-factors-exps (poly:factorz (denom poly)))))
	   (else (poly:factorz poly))))))

;;; Partial fraction expansion of a rational univariate polynomial
;;; The denominator, dr, must be square free.
(define (u:partial-fraction-expand nr dr)
  (let* ((drfs1 (u:factorq dr))
	 (drfs (remove-exponents drfs1 '()))
	 (p 3)
	 (k 5)
	 (ss   (hen:diophantine drfs (list (u:var (car drfs)) 1) p k)))
    (let ((res (map (lambda (x y) (make-rat (poly:* nr x) y)) ss drfs)))
      (ff:print res)
      res)))

(define (remove-exponents fs fs1)
  (cond
    ((null? fs) fs1)
    ((number? (caar fs))
      (ff:print "n " (caar fs))
      (remove-exponents (cdr fs) (fs1)))
    (else
      (ff:print "e " (caar fs))
      (remove-exponents (cdr fs) (append (caar fs) fs1)))))

(define (ff:check-arg e)
  (cond ((not (poly:univariate? e))
	 (bltn:error 'Not-a-univariate-polynomial e))))

(define (ff:check-prime n)
  (cond ((not (prime? n))
	 (bltn:error 'Not-a-Prime-Number n))))

(defbltn 'sff
  (lambda (poly)
    (let ((e (licit->polxpr poly)))
      (if (not (eqv? 1 (unitcan (univ:cont e))))
	(bltn:error 'Not-a-primitive-polynomial poly)
	(poly:sff e)))))

(defbltn 'usff
  (lambda (poly)
    (let ((e (licit->polxpr poly)))
      (ff:check-arg e)
      (cond
       ((not (equal? e (u:primz e)))	   ;this test should be replaced
	(bltn:error 'Not-a-primitive-polynomial poly))
       (else (u:sff e))))))

(define (ff:monic? n p)
  (and (not (u:number? p)) (= (ff:leading n p) 1)))

(defbltn 'ffsff
  (lambda (poly pn . k1)
    (let ((p (licit->polxpr poly))
	  (n (licit->polxpr pn))
	  (k (licit->polxpr (if (null? k1) 1 (car k1)))))
      (ff:check-arg p)
      (ff:check-prime n)
      (cond
       ((not (ff:monic? n p))
	(bltn:error 'Not-monic-mod-n p))
       ((not (> k 0))
	(bltn:error 'Not-greater-than-zero k))
       (else (ff:sff (integer-expt n k) p))))))

(defbltn 'berl
  (lambda (poly pn)
    (let ((p (licit->polxpr poly))
	  (n (licit->polxpr pn)))
      (ff:check-arg p)
      (ff:check-prime n)
      (cond
       ((not (ff:monic? n p))
	(bltn:error 'Not-monic-mod-n p))
       ((not (= (u:degree p) (ff:degree n p)))
	(bltn:error 'Not-same-degree-when-reduced-mod-n (ff:norm p n)))
       (else (ff:berlekamp n p))))))

(defbltn 'parfrac
  (lambda (poly)
    (let ((e1 (expr:normalize poly)))
      (u:partial-fraction-expand (num e1) (denom e1)))))
