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

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)))
@