source: CGBLisp/trunk/src/poly-with-sugar.lisp@ 14

#|
        $Id: poly-with-sugar.lisp,v 1.3 2009/01/22 04:06:12 marek Exp $ 
  *--------------------------------------------------------------------------*
  |  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")

(proclaim '(optimize (speed 0) (debug 3)))

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

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


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