source: CGBLisp/src/RCS/colored-poly.lisp,v@ 1

head    1.12;
access;
symbols;
locks; strict;
comment @;;; @;


1.12
date    2009.01.24.11.07.32;    author marek;   state Exp;
branches;
next    1.11;

1.11
date    2009.01.23.10.35.00;    author marek;   state Exp;
branches;
next    1.10;

1.10
date    2009.01.23.10.32.52;    author marek;   state Exp;
branches;
next    1.9;

1.9
date    2009.01.23.10.29.59;    author marek;   state Exp;
branches;
next    1.8;

1.8
date    2009.01.22.04.00.23;    author marek;   state Exp;
branches;
next    1.7;

1.7
date    2009.01.19.09.24.38;    author marek;   state Exp;
branches;
next    1.6;

1.6
date    2009.01.19.08.45.45;    author marek;   state Exp;
branches;
next    1.5;

1.5
date    2009.01.19.06.59.21;    author marek;   state Exp;
branches;
next    1.4;

1.4
date    2009.01.19.06.58.36;    author marek;   state Exp;
branches;
next    1.3;

1.3
date    2009.01.19.06.57.46;    author marek;   state Exp;
branches;
next    1.2;

1.2
date    2009.01.19.06.51.04;    author marek;   state Exp;
branches;
next    1.1;

1.1
date    2009.01.19.06.48.06;    author marek;   state Exp;
branches;
next    ;


desc
@@


1.12
log
@*** empty log message ***
@
text
@#|
        $Id$    
  *--------------------------------------------------------------------------*
  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@@math.arizona.edu)    |
  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
  |                                                                          |
  | Everyone is permitted to copy, distribute and modify the code in this    |
  | directory, as long as this copyright note is preserved verbatim.         |
  *--------------------------------------------------------------------------*
|#
(defpackage "COLORED-POLY"
  (:use "MONOM" "ORDER" "PARSE" "PRINTER" "MAKELIST"
        "GROBNER"  "DIVISION" "POLY" "COEFFICIENT-RING" "COMMON-LISP")
  (:export make-colored-poly colored-poly-print colored-poly-print-list
           colored-poly-to-poly
           cond-print cond-system-print determine string-determine
           color-poly color-poly-list
           grobner-system totally-green-p cond-hm cond-normal-form
           cond-spoly make-colored-poly-list
           string-grobner-system string-cond string-cover 
           *colored-poly-debug*
           parse-to-colored-poly-list
           ))
(in-package "COLORED-POLY")
             
#+debug(proclaim '(optimize (speed 0) (debug 3)))
#-debug(proclaim '(optimize (speed 3) (debug 0)))

#+debug(defvar *colored-poly-debug* nil "If true debugging output is on.")
#+debug
(defmacro debug-cgb (&rest args)
  `(when *colored-poly-debug* (format *trace-output* ,@@args)))

(defun make-colored-poly (poly k &key (key #'identity)
                                      (main-order #'lex>)
                                      (parameter-order #'lex>)
                          &aux l)
  "Colored poly is represented as a list
        (TERM1 TERM2 ... TERMS)
where each term is a triple
        (MONOM . (POLY . COLOR))
where monoms and polys have common number of variables while color is
one of the three: :RED, :GREEN or :WHITE.  This function translates an
ordinary polynomial into a colored one by dividing variables into K
and N-K, where N is the total number of variables in the polynomial
poly; the function KEY can be called to select variables in arbitrary
order."
  (when (endp poly) (return-from make-colored-poly))
  (setf l (length (caar poly)))
  (labels 
      ((monom-split-variables (monom)
         (values
          (makelist (elt monom (funcall key i)) (i 0 (1- k)))
          (makelist (elt monom (funcall key i)) (i k (1- l)))))
       (term-split-variables (term)
         (multiple-value-bind (main par)
             (monom-split-variables (car term))
           (cons main (cons par (cdr term)))))
       (collect-terms (p)
         (do ((p p (rest p))
              (q (mapcar #'(lambda (x) (cons x nil))
                         (remove-duplicates (mapcar #'car p)
                                            :test #'equal))))
             ((endp p) q)
           (push (cdar p) (cdr (assoc (caar p) q :test #'equal)))
           )))
    (mapcar #'(lambda (term)
                (cons (car term)
                      (cons (sort (cdr term) parameter-order :key #'car)
                            :white)))
            (collect-terms
             (sort (mapcar #'term-split-variables poly)
                   main-order :key #'car)))))

(defun make-colored-poly-list (plist &rest rest)
  "Translate a list of polynomials PLIST into a list of colored polynomials
by calling MAKE-COLORED-POLY. Returns the resulting list."
  (mapcar #'(lambda (p) (apply #'make-colored-poly (cons p rest)))
          plist))

(defun color-poly-list (flist &optional (cond (list nil nil)))
  "Add colors to an ordinary list of polynomials FLIST, according to a
condition COND. A condition is a pair of polynomial lists.  Each
polynomial in COND is a polynomial in parameters only.  The list
(FIRST COND) is called the ``green list'' and it consists of
polynomials which vanish for the parameters associated with the
condition. The list (SECOND COND) is called the ``red list'' and it
consists of the polynomials which do not vanish for the parameters
associated with the condition."
  (mapcar #'(lambda (f) (color-poly f cond)) flist))

(defun color-poly (f &optional (cond (list nil nil)))
  "Add color to a single polynomial F, according to condition COND.
See the documentation of COLOR-POLY-LIST."
  (mapcar
   #'(lambda (term) 
       (cons (car term)
             (cons (cadr term)
                   (cond
                     ((member (cadr term) (car cond) 
                              :test #'tree-equal) :green)
                     ((member (cadr term) (cadr cond)
                              :test #'tree-equal) :red)
                     (t :white)))))
   (cdr f)))

;;Conversion to ordinary polynomial
(defun colored-poly-to-poly (cpoly)
  "For a given colored polynomial CPOLY, removes the colors and
it returns the polynomial as an ordinary polynomial with
coefficients which are polynomials in parameters."
  (mapcan #'(lambda (term)
              (mapcar #'(lambda (x) (cons (append (car term) (car x)) (cdr x)))
                      (cadr term)))
          (cdr cpoly)))
                    
(defun colored-poly-print (poly vars
                           &key (stream t) (beg t)
                                (print-green-part nil)
                                (mark-coefficients nil))
  "Print a colored polynomial POLY. Use variables VARS to represent
the variables. Some of the variables are going to be used as
parameters, according to the length of the monomials in the main
monomial and coefficient part of each term in POLY. The key variable
STREAM may be used to redirect the output. If parameter
PRINT-GREEN-PART is set then the coefficients which have color :GREEN
will be printed, otherwise they are discarded silently. If
MARK-COEFFICIENTS is not NIL then every coefficient will be marked
according to its color, for instance G(U-1) would mean that U-1 is
in the green list. Returns P."
  (when (null poly)
    (when beg  (format stream "0") )
    (return-from colored-poly-print))
  (let* ((term (car poly))
         (color (cddr term))
         (n (length (car term))))
    (unless (and (not print-green-part) (eq color :green))
      (unless beg (format stream " + "))
      (if mark-coefficients 
          (format stream "~c(" 
                  (case color (:red #\R) (:green #\G) (:white #\W)))
        (format stream "("))
      (poly-print (cadr term) (subseq vars n))
      (format stream ")")
      (print-monom (car term) (subseq vars 0 n) stream)
      (setf beg nil)))
  (colored-poly-print (rest poly) vars :stream stream :beg beg
                      :print-green-part print-green-part
                      :mark-coefficients mark-coefficients))

(defun colored-poly-print-list (poly-list vars
                                          &key (stream t)
                                          (beg t)
                                          (print-green-part nil)
                                          (mark-coefficients nil))
  "Pring a list of colored polynomials via a call to
COLORED-POLY-PRINT."
  (when (endp poly-list)
    (when beg (format stream "["))
    (format stream " ]")
    (return-from colored-poly-print-list))
    (unless (or (endp (car poly-list))
              (and (not print-green-part) (endp (cond-part (car poly-list)))))
    (when beg (format stream "[ "))
    (unless beg (format stream ", "))
    (colored-poly-print (car poly-list) vars 
                        :stream stream 
                        :print-green-part print-green-part
                        :mark-coefficients mark-coefficients)
    (setf beg nil))
  (colored-poly-print-list (rest poly-list) vars 
                           :stream stream :beg beg
                           :print-green-part print-green-part
                           :mark-coefficients mark-coefficients))

(defun determine (F &optional (cond (list nil nil)) (order #'lex>) (ring *coefficient-ring*))
  "This function takes a list of colored polynomials F and a condition
COND, and it returns a list of pairs (COND' F') such that COND' cover
COND and F' is a ``determined'' version of the colored polynomial list
F, i.e. every polynomial has its leading coefficient determined. This
means that some of the initial coefficients in each polynomial in F'
are in the green list of COND, and the first non-green coefficient is
in the red list of COND. We note that F' differs from F only by
different colors: some of the terms marked :WHITE are now marked
either :GREEN or :RED. Coloring is done either by explicitly checking
membership in red or green list of COND, or implicitly by performing
Grobner basis calculations in the polynomial ring over the
parameters. The admissible monomial order ORDER is used only in the
parameter space. Also, the ring structure RING is used only for
calculations on polynomials of the parameters only."
  (cond 
   ((endp F) (list (list cond nil)))
   (t
    (let ((gs (mapcan #'(lambda (p &aux (cond1 (car p)) (F1 (cadr p)))
                          (determine-1 cond1 (car F) F1 nil order ring))
                      (determine (rest F) cond order ring))))
      #+debug(let ((l (length gs)))
               (when (> l 1) 
                 (debug-cgb "~&Determined ~d new case~:p." (1- l))))
      gs))))

(defun determine-1 (cond P end GP order ring)
  "Determine a single colored polynomial  P according to condition COND.
Prepend green part GP to P. Cons the result with END, which should be
a list of colored polynomials, and return the resulting list of polynomials.
This is an auxillary function of DETERMINE."
  (cond 
    ((endp P) (list (list cond (append (list GP) end))))
    ((eq (cddar P) :green)
     (determine-1 cond (rest P) end (append GP (list (car P))) order ring))
    ((eq (cddar P) :red)
     (list (list cond (append (list (append GP P)) end))))
    ;; white cases
    (t (determine-white-term cond (car P) (rest P) end GP order ring))))

#-use-saturation
(defun determine-white-term (cond term restP end GP order ring)
  "This is an auxillary function of DETERMINE.
In this function the parameter COND is a condition.
The parameters TERM, RESTP and GP are three parts of a polynomial being
processed, where TERM is colored :WHITE. By testing membership
in the red and green list of COND we try to determine whether the term
is :RED or :GREEN. If we are successful, we simply change the color
of the term and return the list ((COND P)) where P is obtained by
appending GP, (LIST TERM) and RESTP. If we cannot determine whether 
TERM is :RED or :GREEN, we return the list ((COND' P') (COND'' P ''))
where COND' is obtained by adding the coefficient of TERM to
the red list of COND and P' is obtained by appending
GP, (LIST TERM) and RESTP. COND'' is obtained by putting
the coefficient of TERM into the green list of COND and
P'' is obtaind by a recursive call to DETERMINE-1 on 
RESTP, together with GP and TERM which was marked :GREEN."
  (cond 
   ((member (cadr term) (car cond) :test #'tree-equal) ;green
    (determine-1 cond restP end
                 (append GP (list (list* (car term) (cadr term) :green))) 
                 order ring))
   ((or (member (cadr term) (cadr cond) :test #'tree-equal) ;red
        (poly-constant-p (cadr term)))
    (list
     (list cond 
           (append (list
                    (append GP                       ;green part
                            (list (list* (car term) (cadr term) :red));red term
                            restP))                  ;other terms
                   end))))
   (t                                                ;white
    (cons
     (list (list (car cond) (cons (cadr term) (cadr cond)))
           (append
            (list
             (append 
              GP 
              (list (cons (car term) (cons (cadr term) :red)))
              restP))
            end))
     (determine-1 
      (list (cons (cadr term) (car cond)) (cadr cond))
      restP
      end
      (append GP (list (cons (car term) (cons (cadr term) :green))))
      order ring)))))

;; In this version, push on red list literally and test membership
;; But keep green list to be a Grobner basis
#+use-saturation
(defun determine-white-term (cond term restP end GP order ring)
  "This is an auxillary function of DETERMINE.  In this function the
parameter COND is a condition.  The parameters TERM, RESTP and GP are
three parts of a polynomial being processed, where TERM is colored
:WHITE. We test the membership in the red and green list of COND we
try to determine whether the term is :RED or :GREEN. This is done by
performing ideal membership tests in the polynomial ring. Let C be the
coefficient of TERM.  Thus, C is a polynomial in parameters. We find
whether C is in the green list by performing a plain ideal membership
test. However, to test properly whether C is in the red list, one
needs a different strategy.  In fact, we test whether adding C to the
red list would produce a non-empty set of parameters in some algebraic
extension. The test is whether 1 belongs to the saturation ideal of
(FIRST COND) in (CONS C (SECOND COND)). Thus, we use POLY-SATURATION.
If we are successful in determining the color of TERM, we simply
change the color of the term and return the list ((COND P)) where P is
obtained by appending GP, (LIST TERM) and RESTP. If we cannot
determine whether TERM is :RED or :GREEN, we return the list ((COND'
P') (COND'' P'')) where COND' is obtained by adding the coefficient of
TERM to the red list of COND and P' is obtained by appending GP, (LIST
TERM) and RESTP. COND'' is obtained by putting the coefficient of TERM
into the green list of COND and P'' is obtaind by a recursive call to
DETERMINE-1 on RESTP, together with GP and TERM which was marked
:GREEN."
  (if (member (cadr term) (cadr cond) :test #'tree-equal)
      ;;Paint red and return  
      (list
       (list
        cond
        (append
         (list (append GP (list (list* (car term) (cadr term) :red)) restP))
         end)))
    (let ((green-sat (ideal-saturation-1 
                      (car cond)
                      (cadr term) order (length (car cond))
                      nil ring)))
      (if (some #'poly-constant-p green-sat) ; in the radical of green
          ;; paint the term green and determine the rest
          (determine-1
           cond restP end 
           (append GP (list (list* (car term) (cadr term) :green))) ;green term
           order ring)
        ;; else it does not contradict green and thus may be added to red list
        ;; so it should be added to either red or green list
        (cons
         ;; Add to red
         (list
          (list green-sat (append (cadr cond) (list (cadr term))))
          (append
           (list (append 
                  GP 
                  (list (list* (car term) (cadr term) :red))
                  restP))
           end))
         ;; Add to green
         (let ((sat (ideal-polysaturation-1
                     (append (car cond) (list (cadr term)))
                     (cadr cond)
                     order (length (car cond))
                     nil ring)))
           (unless (some #'poly-constant-p sat) ;contradiction after all
             (determine-1 
              (list sat (cadr cond))
              restP end
              (append GP (list (list* (car term) (cadr term) :green)))
              order ring))))))))



;; Print a conditional system, i.e. a list of pairs (gamma colored-poly-list)
(defun cond-system-print (system vars params 
                          &key (suppress-value t)
                               (print-green-part nil)
                               (mark-coefficients nil) 
                          &aux (label 0))
  "A conditional system SYSTEM is a list of pairs (COND PLIST), where COND
is a condition (a pair (GREEN-LIST RED-LIST)) and PLIST is a list
of colored polynomials. This function pretty-prints this list of
pairs. A conditional system is the data structure returned by 
GROBNER-SYSTEM. This function returns SYSTEM, if SUPPRESS-VALUE is non-NIL and 
no value otherwise. If MARK-COEFFICIENTS is non-NIL coefficients will be marked
as in G(u-1)*x+R(2)*y, which means that u-1 is :GREEN and 2 is :RED."
  (dolist (pair system (if suppress-value (values) system))
    (let ((cond (car pair))
          (basis (cadr pair)))
      (format t "~&------------------- CASE ~d -------------------"
              (incf label))
      (cond-print cond params)
      (format t "~&~1TBasis: ")
      (colored-poly-print-list basis (append vars params)
                               :print-green-part print-green-part
                               :mark-coefficients mark-coefficients))))
        
;; Print a condition
(defun cond-print (cond params)
  "Pretty-print a condition COND, using symbol list PARAMS as parameter names."
  (format t "~&Condition:")
  (format t "~&~2TGreen list: ")
  (poly-print (cons '[ (first cond)) params)
  (format t "~&~2TRed list: ")
  (poly-print (cons '[ (second cond)) params))


(defun add-pairs (gs pred)
  "The parameter GS shoud be a Grobner system, i.e. a set of pairs
(CONDITION POLY-LIST) This functions adds the third component: the
list of initial critical pairs (I J), as in the ordinary Grobner basis
algorithm. In addition, it adds the length of of the POLY-LIST, less
1, as the fourth component. The resulting list of quadruples is
returned."
  #-reorder-pairs(declare (ignore pred))
  (mapcar
   #'(lambda (gb  &aux (n (length (cadr gb))))
       (let ((B (makelist (list i j) (i 0 (- n 2)) (j (1+ i) (1- n)))))
         #+reorder-pairs
         (setf B (reorder-pairs B nil (cadr gb) pred t))
         (append gb (list B (1- n)))))
   gs))

(defun cond-part (p)
  "Find the part of a colored polynomial P starting with the first
  non-green term."
  (member :green p :test-not #'eq :key #'cddr))

(defun cond-hm (p)
  "Return the conditional head monomial of a colored polynomial P."
 (let ((cp (cond-part p)))
   (cond
     ((endp cp) (error "Zero conditional part."))
     ((eq (cddar cp) :red) (car cp))
     (t  (error "Head not determined.")))))

(defun delete-green-polys (gamma)
  "Delete totally green polynomials from in a grobner system GAMMA."
  (dolist (gb gamma gamma)
          (setf (cadr gb) (delete-if-not #'cond-part (cadr gb)))))

;; B is a cover (i.e. a list of conditions)
;; flist is a list of colored polynomials
(defun grobner-system (F &key
                         (cover (list '(nil nil)))
                         (main-order #'lex>)
                         (parameter-order #'lex>)
                         (reduce t)
                         (green-reduce t)
                         (top-reduction-only nil)
                         (ring *coefficient-ring*)
                       &aux 
                       (cover      #-use-saturation cover
                                   #+use-saturation
                                   (saturate-cover cover parameter-order ring))
                       (gamma (delete-green-polys
                               (mapcan #'(lambda (cond) 
                                           (determine F cond
                                                      parameter-order ring))
                                       cover))))
  "This function returns a grobner system, given a list of colored polynomials F,
Other parameters are:
A cover COVER, i.e. a list of conditions, i.e. pairs of the form (GREEN-LIST RED-LIST), where
GREEN-LIST and RED-LIST are to lists of ordinary polynomials in parameters.
A monomial order MAIN-ORDER used on main variables (not parameters).
A monomial order PARAMETER-ORDER used in calculations with parameters only.
REDUCE, a flag deciding whether COLORED-REDUCTION will be performed on the resulting
grobner system.
GREEN-REDUCE, a flag deciding whether the green list of each condition will be reduced in
a form of a reduced Grobner basis.
TOP-REDUCTION-ONLY, a flag deciding whether in the internal calculations in the space of parameters
top reduction only will be used.
RING, a structure as in the package COEFFICIENT-RING, used in operations on the coefficients
of the polynomials in parameters."
  #+debug(debug-cgb "~&Initially ~d open case~:p." (length gamma))
  (do ((open  (add-pairs gamma main-order)) 
       closed) 
      ((endp open) 
       ;; Post-process Grobner system
       (tidy-grobner-system
        (mapcar #'(lambda (gp) (butlast gp 2)) closed)
        main-order parameter-order reduce green-reduce ring))
    #+debug(debug-cgb "~&Currently ~d open case~:p." (length open))
    (let*  ((gb (pop open))  (cond (car gb))  (G (cadr gb))  (B (caddr gb))
            (s (cadddr gb)))
      (declare (fixnum s))
      (assert (= (length G) (1+ s)))
      #+debug(debug-cgb "~&Colored case of ~d polynomials and ~d pairs."
                        (1+ s) (length B))
      (cond 
       ((endp B)                        ;no more pairs in this tuple
        (push gb closed))
       ((let* ((pair (car B))
               (i (car pair))
               (j (cadr pair)))
          (declare (fixnum i j))
          (or
           ;;Buchberger criterion 1 or 2 succeeds
           (colored-Criterion-1 i j G) 
           (colored-Criterion-2 i j G (rest B) s)))
        (push (list cond G (rest B) s) open))
       (t                               ;Grobner step - S-polynomial
        (do* ((pair (car B))
              (i (car pair))
              (j (cadr pair))
              (h (cond-spoly (elt G i) (elt G j) 
                             main-order parameter-order ring))
              (SP (cond-normal-form h G main-order parameter-order top-reduction-only ring))
              (delta (determine (list SP) cond parameter-order ring)
                     (rest delta))) 
            ((endp delta))
          (declare (fixnum i j))
          (let ((cond1 (caar delta))
                (SP1 (caadar delta)))
            (cond
             ((cond-part SP1)           ;SP1 is not green
              (let* ((G1 (append G (list SP1)))
                     (s1 (1+ s))
                     (Bnew (makelist (list k s1) (k 0 (1- s1))))
                     B1)
                (assert (= (length G1) (1+ s1)))
                #+reorder-pairs
                (setf B1 (reorder-pairs (rest B) Bnew G1 main-order nil))
                #-reorder-pairs
                (setf B1 (append (rest B) Bnew))
                (push (list cond1 G1 B1 s1) open)))
             (t                         ;SP1 is totally green
              (assert (= (length G) (1+ s)))
              (push (list cond1 G (rest B) s) open))))))))))

;; This is destructive to B and Bnew
#+reorder-pairs
(defun reorder-pairs (B Bnew G pred &optional (sort-first nil))
  "Reorder pairs according to some heuristic. The heuristic at this time is ad hoc,
in the future it should be replaced with sugar strategy and a mechanism for implementing
new heuristic strategies, as in the GROBNER package."
  (let ((order 
         #'(lambda (p1 p2)
             (let* ((m1 (monom-lcm (cond-lm (elt G (car p1)))
                                   (cond-lm (elt G (cadr p1)))))
                    (m2 (monom-lcm (cond-lm (elt G (car p2)))
                                   (cond-lm (elt G (cadr p2)))))
                    (d1 (total-degree m1))
                    (d2 (total-degree m2)))
               (cond ((< d1 d2) t)
                     ((= d1 d2) (funcall pred m2 m1))
                     (t nil))))))
    (when sort-first (setf B (sort (copy-list B) order)))
    (if Bnew 
        (setf B (merge 'list (sort Bnew order) (copy-list B) order))
      B)))

(defun colored-Criterion-1 (i j F)
  "Buchberger criterion 1 for colored polynomials."
  (declare (fixnum i j))
  (let ((v (monom-rel-prime (cond-lm (elt F i))
                            (cond-lm (elt F j)))))
    #+debug(when v (debug-cgb "~&~2TColored Buchberger1 succeded."))
    v))

(defun colored-Criterion-2 (i j F B s)
  "Buchberger criterion 2 for colored polynomials."
  (declare (fixnum i j s))
  (labels ((pair (i j)
             (declare (fixnum i j))
             (if (< i j) (list i j) (list j i))))
    (do ((k 1 (1+ k)))
        ((>= k s))
      (when (and (/= k i)
                 (/= k j)
                 (not (member (pair i k) B :test #'equal))
                 (not (member (pair j k) B :test #'equal))
                 (monom-divides-p (cond-lm (elt F k))
                                  (monom-lcm (cond-lm (elt F i))
                                             (cond-lm (elt F j)))))
        #+debug(debug-cgb "~&~2TColored Buchberger2 succeded.")
        (return-from colored-Criterion-2 t)))))
          

(defun cond-normal-form (f fl main-order parameter-order top-reduction-only ring)
  "Returns the conditional normal form of a colored polynomial F with respect to
the list of colored polynomials FL. The list FL is assumed to consist of determined
polynomials, i.e. such that the first term which is not marked :GREEN is
:RED."
  ;; Remove all zero (i.e totally green) polys from plist
  ;; (setf fl (remove nil fl :key #'cond-part))
  (do (r (division-count 0)
         (p f))
      ((or (endp p) (and top-reduction-only r))
       #+debug(debug-cgb "~&~3T~d conditional reductions" division-count)
       #+debug(when (endp r) (debug-cgb " ---> 0"))
       (values (reverse r) division-count))
    (cond
      ((eq (cddar p) :green)
       (setf r (cons (car p) r)
             p (rest p)))
      (t 
       ;; Find a divisor
       (do ((fl fl (rest fl)))          ;scan list of divisors
           ((cond 
              ((endp fl)
               ;; no division occurred
               (setf r (cons (car p) r) ;move term to remainder
                     p (rest p))        ;remove car from p
               t)
              ((monom-divides-p (cond-lm (car fl))
                                (caar p))
               (incf division-count)
               (let* (#-colored-poly-use-grobner
                      (c1 (cons (make-list (length (caar fl))
                                           :initial-element 0)
                                (cond-lc (car fl))))
                      #+colored-poly-use-grobner
                      (lcm (poly-lcm (car (cond-lc (car fl))) (cadar p)
                                     parameter-order ring))
                      #+colored-poly-use-grobner
                      (c1 (cons (make-list (length (cond-lm (car fl)))
                                           :initial-element 0)
                                (cons (poly-exact-divide lcm (cadar p) parameter-order ring) :red)))
                      #+colored-poly-use-grobner
                      (c2 (poly-exact-divide 
                           lcm 
                           (car (cond-lc (car fl)))
                           parameter-order ring))
                      #-colored-poly-use-grobner
                      (c2 (cadar p))
                      ;; This works for both
                      (quot (cons (monom/ (caar p) (cond-lm (car fl)))
                                  (cons c2 (cddr p)))))
                 ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
                 (setf r (colored-term-times-poly c1 r parameter-order ring)
                       p (colored-poly- 
                          (colored-term-times-poly c1 p parameter-order ring) 
                          (colored-term-times-poly quot (car fl) parameter-order ring)
                          main-order parameter-order ring)))
               t))))))))



(defun cond-spoly (f g main-order parameter-order ring)
  "Returns the conditional S-polynomial of two colored polynomials F and G.
Both polynomials are assumed to be determined."
  (let* ((lcm (monom-lcm (cond-lm f) (cond-lm g)))
         (m1 (monom/ lcm (cond-lm f)))
         (m2 (monom/ lcm (cond-lm g))))
    #-colored-poly-use-grobner
    (colored-poly-
     (colored-term-times-poly (cons m1 (cond-lc g)) (rest f)
                              parameter-order ring)
     (colored-term-times-poly (cons m2 (cond-lc f)) (rest g)
                              parameter-order ring)
     main-order parameter-order ring)

    #+colored-poly-use-grobner
    (let* ((lcm-2 (poly-lcm (car (cond-lc f)) (car (cond-lc g))
                            parameter-order ring))
           (lcf (cond-lc f))
           (lcg (cond-lc g))
           (cf (cons (poly-exact-divide lcm-2 (car lcf) parameter-order ring)
                     :red))
           (cg (cons (poly-exact-divide lcm-2 (car lcg) parameter-order ring)
                     :red)))
      (colored-poly-
       (colored-term-times-poly (cons m1 cf) f parameter-order ring)
       (colored-term-times-poly (cons m2 cg) g parameter-order ring)
       main-order parameter-order ring))
    ))

(defun cond-lm (f)
  "Returns the conditional leading monomial of a colored polynomial F,
which is assumed to be determined."
  (car (cond-hm f)))

;; Conditional leading coefficient; (poly . color)
(defun cond-lc (f)
  "Returns the conditional leading coefficient of a colored polynomial F,
which is assumed to be determined."
  (cdr (cond-hm f)))


(defun colored-term-times-poly (term f order ring)
  "Returns the product of a colored term TERM and a colored polynomial F."
  (mapcar #'(lambda (x) (colored-term* term x order ring)) f))


(defun colored-scalar-times-poly (c f ring)
  "Returns the product of an element of the coefficient ring C a colored polynomial F."
  (mapcar #'(lambda (x)
              (cons (car x)
                    (cons (scalar-times-poly c (cadr x) ring)
                          (cddr x))))
          f))

(defun colored-term* (term1 term2 order ring)
  "Returns the product of two colored terms TERM1 and TERM2."
  (cons 
   (monom* (car term1) (car term2))
   (cons (poly* (cadr term1) (cadr term2) order ring)
         (color* (cddr term1) (cddr term2)))))

(defun color* (c1 c2)
  "Returns a product of two colores. Rules:
:red * :red yields :red
any * :green yields :green
otherwise the result is :white."
  (cond 
    ((and (eq c1 :red) (eq c2 :red)) :red)
    ((or (eq c1 :green) (eq c2 :green)) :green)
    (t :white)))

(defun color+ (c1 c2)
  "Returns a sum of colors. Rules:
:green + :green yields :green,
:red + :green yields :red
any other result is :white."
  (cond 
    ((and (eq c1 :green) (eq c2 :green)) :green)
    ((and (eq c1 :red) (eq c2 :green)) :red)
    ((and (eq c2 :red) (eq c1 :green)) :red)
    (t :white)))

(defun color- (c1 c2)
  "Identical to COLOR+."
  (color+ c1 c2))

(defun colored-poly+ (p q main-order parameter-order ring)
  "Returns the sum of colored polynomials P and Q."
  (cond 
    ((endp p) q)
    ((endp q) p)
    (t 
     (multiple-value-bind 
           (mgreater mequal)
         (funcall main-order (caar p) (caar q))
       (cond
         (mequal
          (let ((s (poly+ (cadar p) (cadar q) parameter-order ring)))
            (if (endp s)                ;check for cancellation
                (colored-poly+ (cdr p) (cdr q) main-order parameter-order ring)
              (cons (cons (caar p) (cons s (color+ (cddar p) (cddar q))))
                    (colored-poly+ (cdr p) (cdr q) main-order
                                   parameter-order ring)))))
         (mgreater
          (cons (car p)
                (colored-poly+ (cdr p) q main-order parameter-order ring)))
         (t (cons (cons (caar q) (cons (cadar q) (cddar q)))
                  (colored-poly+ p (cdr q) main-order parameter-order ring))))))))

(defun colored-poly- (p q main-order parameter-order ring)
  "Returns the difference of colored polynomials P and Q."
  (do (r)
      (nil)
    (cond 
      ((endp p) (return (nreconc r (colored-minus-poly q ring))))
      ((endp q) (return (nreconc r p)))
      (t 
       (multiple-value-bind 
             (mgreater mequal)
           (funcall main-order (caar p) (caar q))
         (cond
           (mequal
            (let ((s (poly- (cadar p) (cadar q) parameter-order ring)))
              (unless (endp s)          ;check for cancellation
                (setf r (cons (cons (caar p) (cons s (color- (cddar p) (cddar q)))) r)))
              (setf p (cdr p) q (cdr q))))
           (mgreater
            (setf r (cons (car p) r)
                  p (cdr p)))
           (t (setf r (cons (cons (caar q) (cons (minus-poly (cadar q) ring) (cddar q))) r)
                    q (cdr q)))))))))

(defun colored-term-uminus (term ring)
  "Returns the negation of a colored term TERM."
  (cons (car term) (cons (minus-poly (cadr term) ring) (cddr term))))

(defun colored-minus-poly (p ring)
  "Returns the negation of a colored polynomial P."
  (mapcar #'(lambda (x) (colored-term-uminus x ring)) p))

(defun string-grobner-system (F vars params
                              &key (cover (list (list "[]" "[]")))
                                   (main-order #'lex>)
                                   (parameter-order #'lex>)
                                   (ring *coefficient-ring*)
                                   (suppress-value t)
                                   (suppress-printing nil)
                                   (mark-coefficients nil)
                                   (reduce t)
                                   (green-reduce t)
                              &aux
                              (F (parse-to-colored-poly-list
                                  F vars params main-order parameter-order))
                              (cover (string-cover cover params parameter-order)))
  "An interface to GROBNER-SYSTEM in which polynomials can be specified in infix notations
as strings. Lists of polynomials are comma-separated list marked by a matchfix operators []"
  (let ((gs (grobner-system F :cover cover :main-order main-order
                            :parameter-order parameter-order
                            :ring ring
                            :green-reduce green-reduce
                            :reduce reduce)))
    (unless suppress-printing
      (cond-system-print gs vars params :mark-coefficients mark-coefficients))
    (if suppress-value (values) gs)))


(defun string-cond (cond params &optional (order #'lex>))
  "Return the internal representation of a condition COND, specified
as pairs of strings (GREEN-LIST RED-LIST). GREEN-LIST and RED-LIST in
the input are assumed to be strings which parse to two lists of
polynomials with respect to variables whose names are in the list of
symbols PARAMS. ORDER is the predicate used to sort the terms of
the polynomials."
  (list
   (rest (parse-string-to-sorted-alist (car cond) params order))
   (rest (parse-string-to-sorted-alist (cadr cond) params order))))

(defun string-cover (cover params &optional (order #'lex>))
  "Returns the internal representation of COVER, given in the form of
a list of conditions. See STRING-COND for description of a condition." 
  (cond 
   ((endp cover) nil)
   (t (cons (string-cond (car cover) params order)
            (string-cover (cdr cover) params order)))))

(defun saturate-cover (cover order ring)
  "Brings every condition of a list of conditions COVER to the form (G R)
where G is saturated with respect to R and G is a Grobner basis
We could reduce R so that the elements of R are relatively prime,
but this is not currently done."
  (remove nil (mapcar #'(lambda (cond) (saturate-cond cond order ring)) cover)))

(defun saturate-cond (cond order ring)
  "Saturate a single condition COND. An auxillary function of SATURATE-COVER."
  (let* ((green-sat (ideal-polysaturation-1 (car cond) (cadr cond) order 0 nil ring)))
    (if (some #'poly-constant-p green-sat)
        nil
      (list green-sat (cadr cond)))))
                       
(defun string-determine (F vars params
                         &key (cond '("[]" "[]"))
                              (main-order #'lex>)
                              (parameter-order #'lex>)
                              (suppress-value t)
                              (suppress-printing nil)
                              (mark-coefficients nil)
                              (ring *coefficient-ring*)
                         &aux 
                         (F (parse-to-colored-poly-list
                             F vars params main-order parameter-order))
                         (cond (string-cond cond params parameter-order)))
  "A string interface to DETERMINE. See the documentation of STRING-GROBNER-SYSTEM."
  (let ((gs (determine F cond parameter-order ring)))
    (unless suppress-printing
      (cond-system-print gs vars params :mark-coefficients mark-coefficients))
    (if suppress-value (values) gs)))

(defun tidy-grobner-system (gs main-order parameter-order
                               reduce green-reduce ring)
  "Apply TIDY-PAIR to every pair of a Grobner system."
  (mapcan #'(lambda (p) (tidy-pair p main-order parameter-order reduce green-reduce
                                   ring))
          gs))


(defun tidy-pair (pair main-order parameter-order
                       reduce green-reduce ring
                       &aux gs)
  "Make the output of Grobner system more readable by performing
certain simplifications on an element of a Grobner system.
If REDUCE is non-NIL then COLORED-reduction will be performed.
In addition TIDY-COND is called on the condition part of the pair PAIR."
  (if reduce
      (setf gs (colored-reduction (car pair) (cadr pair)
                                  main-order parameter-order ring))
    (setf gs (list pair)))
  (setf gs 
        (mapcar #'(lambda (pair) 
                    (list (tidy-cond (car pair) parameter-order
                                     ring)
                          (cadr pair)))
                gs))
  (when green-reduce
    (setf gs (cond-system-green-reduce gs parameter-order ring)))
  gs)

(defun tidy-cond (cond order ring)
  "Currently saturates condition COND and does RED-REDUCTION on the red list."
  (let ((cond1 (saturate-cond cond order ring)))
    (list (reduction (car cond1) order ring)
          (red-reduction (cadr cond1) order ring))))

(defun colored-reduction (cond P main-order parameter-order ring
                          &aux (open (list (list cond nil P))) closed)
  "Reduce a list of colored polynomials P.  The difficulty as compared
to the usual Buchberger algorithm is that the polys may have the same
leading monomial which may result in cancellations and polynomials
which may not be determined. Thus, when we find those, we will have to
split the condition by calling determine. Returns a list of pairs
(COND' P') where P' is a reduced grobner basis with respect to any
parameter choice compatible with condition COND'. Moreover, COND' form
a cover of COND."
  ;;We form a list of tripples (CONDITION G U) where G is reduced and U
  ;;is the unreduced part of the basis and operate on these
  (do ()
      ((endp open) closed)
    (let* ((tuple (pop open))
           (cond1 (car tuple))
           (G  (cadr tuple))
           (U (caddr tuple)))
      (cond
       ((endp U)                        ;no-more undetermined
        (push (list cond1 G)
              closed))
       (t
        (let ((f (car U)))
          (multiple-value-bind (k div-count)
              (cond-normal-form f (append G (cdr U))
                                main-order parameter-order nil ring)
            (cond
             ((zerop div-count)
              (push (list cond1 (append G (list f)) (cdr U)) open))
             (t
              (do ((delta (determine (list k) cond1 parameter-order ring)
                          (rest delta)))
                  ((endp delta))
                (let* ((eps   (caar delta))
                       (k1    (caadar delta)))
                  (cond
                   ((cond-part k1)      ;does not reduce to 0
                    ;; Replace f with k1 and start all over
                    (push (list eps nil (append G (list k1) (cdr U)))
                          open))
                   (t 
                    ;; f reduces to 0 so just drop f
                    (push (list eps G (cdr U)) 
                          open))))))))))))))


(defun green-reduce-colored-poly (cond f parameter-order ring)
  "It takes a colored polynomial F and it returns a modified
polynomial obtained by reducing coefficient of F modulo green list of
the condition COND."
  (dotimes (i (length f) f)
    (multiple-value-bind (nf division-count c)
      (normal-form (cadr (nth i f)) (car cond) parameter-order nil ring)
      (declare (ignore division-count))
      (unless (endp nf)
        (setf f (colored-scalar-times-poly c f ring)))
      (setf (cadr (nth i f)) nf))))
    
                                        
(defun green-reduce-colored-list (cond fl parameter-order ring)
  "Apply GREEN-REDUCE-COLORED-POLY to a list of polynomials FL."
  (remove-if 
   #'endp
   (cond
     ((endp fl) nil) 
     (t
      (cons 
       (green-reduce-colored-poly cond (car fl) parameter-order ring)
       (green-reduce-colored-list cond (rest fl) parameter-order ring))))))

(defun cond-system-green-reduce (gs parameter-order ring)
  "Apply GREEN-REDUCE-COLORED-LIST to every pair of
a grobner system GS."
  (cond 
    ((endp  gs) nil)
    (t (cons
        (list (caar gs) (green-reduce-colored-list 
                         (caar gs) (cadar gs) parameter-order ring))
        (cond-system-green-reduce (rest gs) parameter-order ring)))))


(defun parse-to-colored-poly-list (F vars params main-order parameter-order
                                     &aux (k (length vars))
                                     (vars-params (append vars params)))
  "Parse a list of polynomials F, given as a string, with respect to
a list of variables VARS, given as a list of symbols, to the internal
representation of a colored polynomial. The polynomials will be properly
sorted by MAIN-ORDER, with the coefficients, which are polynomials in
parameters, sorted by PARAMETER-ORDER. Both orders must be admissible
monomial orders. This form is suitable for parsing polynomials with integer
coefficients."
  (make-colored-poly-list 
   (rest (parse-string-to-alist F vars-params))
   k :main-order main-order :parameter-order parameter-order))
(defun red-reduction (P pred ring
                      &aux
                      (P (remove-if #'poly-constant-p P)))
  "Takes a family of polynomials and produce a list whose prime factors 
are the same but they are relatively prime
Repetitively used the following procedure: it finds two elements f, g of
P which are not relatively prime; it replaces f and g with f/GCD(f,g),
 g/ GCD(f,f) and GCD(f,g)."
  (when (endp P) (return-from red-reduction))
  (do ((found t))
      ((or (endp (cdr P)) (not found))
       (mapcar #'(lambda (x) (grobner-primitive-part x ring)) P))
    (setf found nil)
    (tagbody
      (do ((Q1 P (rest Q1)))
          ((endp Q1))
        (do ((Q2 (rest Q1) (rest Q2)))
            ((endp Q2))
          (let* ((f (car Q1))
                 (g (car Q2))
                 (h (grobner-gcd f g pred ring)))
            (unless (poly-constant-p h)
              (setf found t
                    P (remove f P)
                    P (remove G P)
                    P (cons h P))
              (let ((f1 (poly-exact-divide f h pred ring))
                    (g1 (poly-exact-divide g h pred ring)))
                (unless (poly-constant-p f1) (push f1 P))
                (unless (poly-constant-p g1) (push g1 P)))
              (go found)))))
     found)))
@


1.11
log
@*** empty log message ***
@
text
@d377 1
@


1.10
log
@*** empty log message ***
@
text
@a376 1
  (declare (ignore pred))
a497 1
  (declare (ignore pred))
@


1.9
log
@*** empty log message ***
@
text
@d499 1
@


1.8
log
@*** empty log message ***
@
text
@d377 1
@


1.7
log
@*** empty log message ***
@
text
@d26 2
a27 2
;;(proclaim '(optimize (speed 0) (debug 3)))
(proclaim '(optimize (speed 3) (debug 0)))
@


1.6
log
@*** empty log message ***
@
text
@d26 2
a27 1
(proclaim '(optimize (speed 0) (debug 3)))
@


1.5
log
@*** empty log message ***
@
text
@d26 1
a26 11
(eval-when (compile)
  (proclaim '(optimize (speed 3) (safety 0)))
  (proclaim '(inline make-colored-poly-list color-poly-list color-poly
              colored-poly-to-poly cond-print add-pairs
              cond-part cond-hm delete-green-polys
              colored-Criterion-1 colored-Criterion-2
              cond-lm cond-lc colored-term-times-poly
              colored-scalar-times-poly
              colored-term* color* color+ color-
              colored-term-uminus colore-minus-poly
              )))
a816 4

(eval-when (compile)
  (proclaim '(inline tidy-grobner-system tidy-pair tidy-cond)))

@


1.4
log
@*** empty log message ***
@
text
@d294 1
a294 1
P') (COND'' P"")) where COND' is obtained by adding the coefficient of
@


1.3
log
@*** empty log message ***
@
text
@d235 1
a235 1
TERM is :RED or :GREEN, we return the list ((COND' P') (COND'' P \"\"))
@


1.2
log
@*** empty log message ***
@
text
@d96 1
a96 1
condition. The list (SECOND COND) is called the ``red list"" and it
d235 1
a235 1
TERM is :RED or :GREEN, we return the list ((COND' P') (COND'' P""))
@


1.1
log
@Initial revision
@
text
@d2 1
a2 1
        $Id: colored-poly.lisp,v 1.41 1997/12/25 01:24:24 marek Exp $   
d722 1
a722 1
      ()
@