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


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

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

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


desc
@@


1.3
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 "POLY-WITH-SUGAR"
  (:export poly-with-sugar-poly
	   poly-with-sugar-tail
	   poly-with-sugar-sugar
	   monom-sugar
	   term-sugar
	   monom-times-poly-with-sugar
	   scalar-times-poly-with-sugar
	   term-times-poly-with-sugar
	   minus-poly-with-sugar
	   poly-with-sugar+
	   poly-with-sugar- 
	   poly-with-sugar-op
	   poly-with-sugar-zerop
	   poly-with-sugar-nreverse
	   poly-with-sugar-append
	   poly-with-sugar-lm
	   poly-with-sugar-lc
	   poly-with-sugar-lt
	   poly-add-sugar)
  (:use "ORDER" "MONOM" "TERM" "TERM" "POLY" "COEFFICIENT-RING" "COMMON-LISP"))

(in-package "POLY-WITH-SUGAR")

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

;;----------------------------------------------------------------
;; BASIC OPERATIONS ON POLYNOMIALS of many variables WITH SUGAR
;; Hybrid operations involving polynomials and monomials or terms
;;----------------------------------------------------------------
;; The representation is as follows:
;;
;;	polynomial-with-sugar:	(poly . sugar)
;;
;;----------------------------------------------------------------

(eval-when (compile)
  (proclaim '(inline poly-with-sugar-poly
	      poly-with-sugar-sugar
	      poly-with-sugar-tail)))

(defun poly-with-sugar-poly (p) (car p))
(defun poly-with-sugar-sugar (p) (cdr p))
(defun poly-with-sugar-tail (p) (cons (cdar p) (cdr p)))

(defsetf poly-with-sugar-poly (p) (poly)
  `(setf (car ,p) ,poly))

(defsetf poly-with-sugar-sugar (p) (sugar)
  `(setf (cdr ,p) ,sugar))

(defsetf poly-with-sugar-tail (p) (tail)
  `(setf (cdar ,p) ,tail))

;;----------------------------------------------------------------
;; Sugar of monomials and terms
;; The total degree is used
;;----------------------------------------------------------------
(defun monom-sugar (m)
  (total-degree m))

(defun coefficient-sugar (c ring)
  (funcall (ring-length ring) c))

(defun term-sugar (term ring)
  (declare (ignore ring))
  (monom-sugar (term-monom term)))

;;----------------------------------------------------------------
;; Initialize sugar of an ordinary polynomial
;;----------------------------------------------------------------
(defun poly-add-sugar (poly ring)
  (cons poly
	(apply #'max (mapcar #'(lambda (term) (term-sugar term ring)) poly))))

;; Multiplies scalar c by a polynomial p
(defun scalar-times-poly-with-sugar (c p ring)
  (cons (scalar-times-poly c (poly-with-sugar-poly p) ring)
	(poly-with-sugar-sugar p)))

;; Multiplies term m by a poly-with-sugar f
(defun term-times-poly-with-sugar (term f ring)
  (cons (term-times-poly term (poly-with-sugar-poly f) ring)
	(+ (poly-with-sugar-sugar f) (term-sugar term ring))))

;; Multiply a monom by a poly-with-sugarnomial
(defun monom-times-poly-with-sugar (m f)
  (cons
   (monom-times-poly m (poly-with-sugar-poly f))
   (+ (poly-with-sugar-sugar f) (monom-sugar m))))

;; Changes the sign of the polynomial f with sugar
(defun minus-poly-with-sugar (f ring)
  (cons
   (minus-poly (poly-with-sugar-poly f) ring)
   (poly-with-sugar-poly f)))

;; Addition and subtraction of polynomials with sugar
(defun poly-with-sugar+ (p q pred ring)
  (cons
   (poly+ (poly-with-sugar-poly p) (poly-with-sugar-poly q) pred ring)
   (max (poly-with-sugar-sugar p) (poly-with-sugar-sugar q))))

;; Addition and subtraction of polynomials with sugar
(defun poly-with-sugar- (p q pred ring)
  (cons
   (poly- (poly-with-sugar-poly p) (poly-with-sugar-poly q) pred ring)
   (max (poly-with-sugar-sugar p) (poly-with-sugar-sugar q))))

;; Implement f-term*g
(defun poly-with-sugar-op (f term g pred ring)
  (poly-with-sugar- f (term-times-poly-with-sugar term g ring) pred ring))


(eval-when (compile)
  (proclaim '(inline poly-with-sugar-nreverse poly-with-sugar-append
	      poly-with-sugar-zerop poly-with-sugar-lm
	      poly-with-sugar-lt poly-with-sugar-lc)))
;; Destructively reverse the order of terms in a polynomial with sugar
(defun poly-with-sugar-nreverse (p)
  (setf (poly-with-sugar-poly p) (nreverse (poly-with-sugar-poly p)))
  p)

;; Append two polynomials with sugar, which are assumed to be
;; sorted and all terms of q are smaller than terms of p
(defun poly-with-sugar-append (p q)
  (cons (append (poly-with-sugar-poly p) (poly-with-sugar-poly q))
	(max (poly-with-sugar-sugar p) (poly-with-sugar-sugar q))))

(defun poly-with-sugar-zerop (p)
  (poly-zerop (poly-with-sugar-poly p)))

(defun poly-with-sugar-lm (p)
  (lm (poly-with-sugar-poly p)))

(defun poly-with-sugar-lc (p)
  (lc (poly-with-sugar-poly p)))

(defun poly-with-sugar-lt (p)
  (lt (poly-with-sugar-poly p)))
@


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


1.1
log
@Initial revision
@
text
@d2 1
a2 1
	$Id: poly-with-sugar.lisp,v 1.33 1997/11/28 23:26:18 marek Exp $	
d35 2
a36 4
(eval-when (compile)
  (proclaim '(optimize (speed 3) (safety 0)))
  (proclaim '(inline monom-times-poly-with-sugar scalar-times-poly-with-sugar 
	      term-times-poly-with-sugar minus-poly-with-sugar poly-with-sugar-op)))
@