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


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

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

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


desc
@@


1.3
log
@*** empty log message ***
@
text
@;;; -*- Mode: Common-Lisp; Package: String-Grobner; Base: 10 -*-
#|
	$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 "STRING-GROBNER"
  (:export
   string-normal-form
   string-grobner	
   string-colon-ideal	
   string-ideal-polysaturation-1
   string-ideal-saturation-1
   string-ideal-polysaturation
   string-ideal-saturation
   string-poly-lcm
   string-ideal-intersection
   string-elimination-ideal
   string-read-poly)
 (:use "ORDER" "MONOM" "PARSE" "PRINTER" "GROBNER" "TERM" "POLY"
	       "COEFFICIENT-RING" "COMMON-LISP"))

(in-package "STRING-GROBNER")

#+debug(proclaim '(optimize (speed 0) (debug 3)))
#-debug(proclaim '(optimize (speed 3) (debug 0)))

(defun string-normal-form (f fl vars
			   &key
			   (stream t)
			   (print t)
			   (order #'lex>)
			   (top-reduction-only nil)
			   (ring *coefficient-ring*)
			   (suppress-value t)
			   &aux (vars (read-vars vars)))
  (let ((f (parse-string-to-sorted-alist f vars order))
	(fl (parse-string-to-sorted-alist fl vars order)))
    (format stream "~&Args:")
    (poly-print fl vars stream)
    (let ((nf (normal-form (copy-tree f) (rest fl) order top-reduction-only ring)))
      (terpri stream)
      (when print
	(poly-print
	 nf
	 vars
	 stream))
      (if suppress-value (values) nf))))

(defun string-grobner (plist vars
		       &key (order #'lex>)
			    (start 0)
			    (stream t)
			    (reduce t)
			    (reduce-before t)
			    (suppress-value t)
			    (top-reduction-only nil)
			    (ring *coefficient-ring*)
			    (print t)
		       &aux (vars (read-vars vars)))
  ;; Turn on some phancy tracing to see the action better
  (let ((grobner-fun
	 (if reduce #'reduced-grobner #'grobner))
	(plist (parse-string-to-sorted-alist plist vars order)))
    (format stream "~&Args:")
    (poly-print plist vars stream)
    (setf plist (rest plist))
    (when reduce-before (setf plist (reduction plist order ring)))
    (let ((gb (funcall grobner-fun plist order start top-reduction-only ring)))
      (terpri stream)
      (when print
	(poly-print
	 (cons '[ gb)
	 vars
	 stream))
      (if suppress-value (values) gb))))

(defun string-elimination-ideal (flist vars k
				 &key (stream t)
				      (key #'identity)
				      (primary-order #'grevlex>)
				      (secondary-order #'grevlex>)
				      (suppress-value t)
				      (order (elimination-order
					      k
					      :primary-order primary-order
					      :secondary-order secondary-order
					      ))
				 &aux (vars (read-vars vars)))
  (let ((id (ring-intersection
	     (string-grobner flist vars
			     :order order
			     :suppress-value nil
			     :stream stream
			     :print nil)
	     k :key key)))
    (poly-print (cons '[ id) vars stream)
    (if suppress-value (values) id)))


(defun string-ideal-intersection (f g vars
				  &key (order #'lex>)
				       (top-reduction-only nil)
				       (ring *coefficient-ring*)
				       (stream t)
				       (suppress-value t)
				  &aux (vars (read-vars vars))
				       (f (parse-string-to-sorted-alist
					   f vars order))
				       (g (parse-string-to-sorted-alist
					   g vars order)))
  (let ((id (ideal-intersection (rest f) (rest g) order top-reduction-only ring)))
    (poly-print (cons '[ id) vars stream)
    (if suppress-value (values) id)))

(defun string-poly-lcm (f g vars
			&key (order #'lex>)
			     (ring *coefficient-ring*)
			     (stream t)
			     (suppress-value t)
			&aux (vars (read-vars vars))
			     (f (parse-string-to-sorted-alist
				 f vars order))
			     (g (parse-string-to-sorted-alist
				 g vars order)))
  (let ((lcm (poly-lcm f g order ring)))
    (poly-print lcm vars stream)
    (if suppress-value (values) lcm)))

(defun string-ideal-saturation-1 (F p vars
				  &key (order #'lex>) (start 0)
				       (top-reduction-only nil)
				       (ring *coefficient-ring*)
				       (stream t)
				       (suppress-value t)
				  &aux (vars (read-vars vars))
				       (F (parse-string-to-sorted-alist
					   F vars order))
				       (p (parse-string-to-sorted-alist
					   p vars order)))
  (let ((id (ideal-saturation-1 (rest F) p order start top-reduction-only ring)))
    (poly-print (cons '[ id) vars stream)
    (if suppress-value (values) id)))

(defun string-ideal-polysaturation-1 (F plist vars
				      &key (order #'lex>) (start 0)
					   (top-reduction-only nil)
					   (ring *coefficient-ring*)
					   (stream t)
					   (suppress-value t)
				      &aux (vars (read-vars vars))
					   (F (parse-string-to-sorted-alist
					       F vars order))
					   (plist (parse-string-to-sorted-alist
						   plist vars order)))
  (format stream "~&Args1:")
  (poly-print F vars stream)
  (format stream "~&Args2:")
  (poly-print plist vars stream)
  (terpri stream)
  (let ((id (ideal-polysaturation-1 (rest F) (rest plist) order start top-reduction-only ring)))
    (poly-print (cons '[ id) vars stream)
    (if suppress-value (values) id)))

(defun string-ideal-saturation (F G vars
				&key (order #'lex>) (start 0)
				     (top-reduction-only nil)
				     (ring *coefficient-ring*)
				     (stream t)
				     (suppress-value t)
				&aux (vars (read-vars vars))
				     (F (parse-string-to-sorted-alist
					 F vars order))
				     (G (parse-string-to-sorted-alist
					 G vars order)))
  (let ((id (ideal-saturation (rest F) (rest G) order start top-reduction-only ring)))
    (poly-print (cons '[ id) vars stream)
    (if suppress-value (values) id)))

(defun string-ideal-polysaturation (F ideal-list vars
				    &key (order #'lex>) (start 0)
					 (top-reduction-only nil)
					 (ring *coefficient-ring*)
					 (stream t)
					 (suppress-value t)
				    &aux (vars (read-vars vars))
					 (F (parse-string-to-sorted-alist
					     F vars order))
					 (ideal-list
					  (mapcar #'(lambda (G) (parse-string-to-sorted-alist
								 G vars order))
						  ideal-list)))
  (format stream "~&Args1:")
  (poly-print F vars stream)
  (format stream "~&Args2:")
  (dolist (G ideal-list)
    (poly-print G vars stream))
  (terpri stream)
  (let ((id (ideal-polysaturation (rest F) (mapcar #'rest ideal-list) order start top-reduction-only ring)))
    (poly-print (cons '[ id) vars stream)
    (if suppress-value (values) id)))



(defun string-colon-ideal (F G vars
			   &key (top-reduction-only nil)
				(ring *coefficient-ring*)
				(stream t)
				(order #'lex>)
				(suppress-value t)
			   &aux (vars (read-vars vars))
				(F (parse-string-to-sorted-alist
				    F vars order))
				(G (parse-string-to-sorted-alist
				    G vars order)))
  (format stream "~&Args1:")
  (poly-print F vars stream)
  (format stream "~&Args2:")
  (poly-print G vars stream)
  (let ((id (colon-ideal (rest F) (rest G) order top-reduction-only ring)))
    (poly-print (cons '[ id) vars stream)
    (if suppress-value (values) id)))

;;----------------------------------------------------------------
;; An enhanced polynomial reader
;;----------------------------------------------------------------
(defun string-read-poly (F vars
			 &key (order #'lex>)
			      (suppress-value nil)
			      (stream t)
			      (convert-rational-to-integer t)
			 &aux (vars (read-vars vars))
			      (F (parse-string-to-sorted-alist F vars order)))
  (when convert-rational-to-integer
    (if (eq (car F) '[)
	(setf F (cons (car F) (mapcar #'poly-rational-to-integer (rest F))))
      (setf F (poly-rational-to-integer F))))
  (format stream "~&Args:")
  (poly-print F vars stream)
  (terpri stream)
  (if suppress-value (values) F))


;; Multiply by lcm of denominators of coefficients
(defun poly-rational-to-integer (p &optional (ring *coefficient-ring*))
  (let ((c (apply (ring-lcm ring) (mapcar (ring-denominator ring) (mapcar #'cdr p)))))
    (scalar-times-poly c p ring)))

(defun read-vars (string-or-list)
  "Read a list of variables, specified either as a list of symbols or a string
listing variables in the form of a comma-separated list, delimited by [,]"
  (typecase string-or-list
    (list string-or-list)
    (string (with-input-from-string (s string-or-list) (rest (parse s))))))@


1.2
log
@*** empty log message ***
@
text
@d32 2
a33 2
;;(proclaim '(optimize (speed 0) (debug 3)))
(proclaim '(optimize (speed 3) (debug 0)))
@


1.1
log
@Initial revision
@
text
@d3 1
a3 1
	$Id: string-grobner.lisp,v 1.34 1997/12/13 16:05:50 marek Exp $
d32 2
a33 1
(proclaim '(optimize (speed 0) (debug 3)))
@