close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

source: branches/f4grobner/termlist.lisp@ 429

Last change on this file since 429 was 411, checked in by Marek Rychlik, 10 years ago

* empty log message *
File size: 7.0 KB
RevLine 
[150]1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*-
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;;
4;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
5;;;
6;;; This program is free software; you can redistribute it and/or modify
7;;; it under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 2 of the License, or
9;;; (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19;;;
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21
[411]22(defpackage "TERMLIST"
23 (:use :cl :term)
24 (:export "TERMLIST-SUGAR"
25 "TERMLIST-CONTRACT"
26 "TERMLIST-EXTEND"
27 "TERMLIST-ADD-VARIABLES"
28 "TERMLIST-LT"
29 "TERMLIST-LM"
30 "TERMLIST-LC"
31 "SCALAR-MUL"
32 "SCALAR-TIMES-TERMLIST"
33 "TERM-MUL-LST"
34 "TERMLIST-TIMES-TERM"
35 "TERM-TIMES-TERMLIST"
36 "MONOM-TIMES-TERM"
37 "MONOM-TIMES-TERMLIST"
38 "TERMLIST-UMINUS"
39 "TERMLIST-ADD"
40 "TERMLIST-SUB"
41 "TERMLIST-MUL"
42 "TERMLIST-UNIT"
43 "TERMLIST-EXPT"))
[150]44
[401]45(defun termlist-sugar (p &aux (sugar -1))
46 (declare (fixnum sugar))
47 (dolist (term p sugar)
48 (setf sugar (max sugar (term-sugar term)))))
49
50(defun termlist-contract (p &optional (k 1))
51 "Eliminate first K variables from a polynomial P."
52 (mapcar #'(lambda (term) (make-term (monom-contract k (term-monom term))
53 (term-coeff term)))
54 p))
55
56(defun termlist-extend (p &optional (m (make-monom 1 :initial-element 0)))
57 "Extend every monomial in a polynomial P by inserting at the
58beginning of every monomial the list of powers M."
59 (mapcar #'(lambda (term) (make-term (monom-append m (term-monom term))
60 (term-coeff term)))
61 p))
62
63(defun termlist-add-variables (p n)
64 "Add N variables to a polynomial P by inserting zero powers
65at the beginning of each monomial."
66 (declare (fixnum n))
67 (mapcar #'(lambda (term)
68 (make-term (monom-append (make-monom n :initial-element 0)
69 (term-monom term))
70 (term-coeff term)))
71 p))
72
73
[150]74;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75;;
76;; Low-level polynomial arithmetic done on
77;; lists of terms
78;;
79;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80
81(defmacro termlist-lt (p) `(car ,p))
82(defun termlist-lm (p) (term-monom (termlist-lt p)))
83(defun termlist-lc (p) (term-coeff (termlist-lt p)))
84
85(define-modify-macro scalar-mul (c) coeff-mul)
86
87(defun scalar-times-termlist (ring c p)
88 "Multiply scalar C by a polynomial P. This function works
89even if there are divisors of 0."
90 (mapcan
91 #'(lambda (term)
92 (let ((c1 (funcall (ring-mul ring) c (term-coeff term))))
93 (unless (funcall (ring-zerop ring) c1)
94 (list (make-term (term-monom term) c1)))))
95 p))
96
97
[379]98(defun term-mul-lst (ring term1 term2)
[380]99 "A special version of term multiplication. Returns (LIST TERM) where
100TERM is the product of the terms TERM1 TERM2, or NIL when the product
101is 0. This definition takes care of divisors of 0 in the coefficient
102ring."
[150]103 (let ((c (funcall (ring-mul ring) (term-coeff term1) (term-coeff term2))))
104 (unless (funcall (ring-zerop ring) c)
105 (list (make-term (monom-mul (term-monom term1) (term-monom term2)) c)))))
106
107(defun term-times-termlist (ring term f)
108 (declare (type ring ring))
[379]109 (mapcan #'(lambda (term-f) (term-mul-lst ring term term-f)) f))
[150]110
111(defun termlist-times-term (ring f term)
[379]112 (mapcan #'(lambda (term-f) (term-mul-lst ring term-f term)) f))
[150]113
114(defun monom-times-term (m term)
115 (make-term (monom-mul m (term-monom term)) (term-coeff term)))
116
117(defun monom-times-termlist (m f)
118 (cond
119 ((null f) nil)
120 (t
121 (mapcar #'(lambda (x) (monom-times-term m x)) f))))
122
123(defun termlist-uminus (ring f)
124 (mapcar #'(lambda (x)
125 (make-term (term-monom x) (funcall (ring-uminus ring) (term-coeff x))))
126 f))
127
128(defun termlist-add (ring p q)
129 (declare (type list p q))
130 (do (r)
131 ((cond
132 ((endp p)
133 (setf r (revappend r q)) t)
134 ((endp q)
135 (setf r (revappend r p)) t)
136 (t
137 (multiple-value-bind
138 (lm-greater lm-equal)
139 (monomial-order (termlist-lm p) (termlist-lm q))
140 (cond
141 (lm-equal
142 (let ((s (funcall (ring-add ring) (termlist-lc p) (termlist-lc q))))
143 (unless (funcall (ring-zerop ring) s) ;check for cancellation
144 (setf r (cons (make-term (termlist-lm p) s) r)))
145 (setf p (cdr p) q (cdr q))))
146 (lm-greater
147 (setf r (cons (car p) r)
148 p (cdr p)))
149 (t (setf r (cons (car q) r)
150 q (cdr q)))))
151 nil))
152 r)))
153
154(defun termlist-sub (ring p q)
155 (declare (type list p q))
156 (do (r)
157 ((cond
158 ((endp p)
159 (setf r (revappend r (termlist-uminus ring q)))
160 t)
161 ((endp q)
162 (setf r (revappend r p))
163 t)
164 (t
165 (multiple-value-bind
166 (mgreater mequal)
167 (monomial-order (termlist-lm p) (termlist-lm q))
168 (cond
169 (mequal
170 (let ((s (funcall (ring-sub ring) (termlist-lc p) (termlist-lc q))))
171 (unless (funcall (ring-zerop ring) s) ;check for cancellation
172 (setf r (cons (make-term (termlist-lm p) s) r)))
173 (setf p (cdr p) q (cdr q))))
174 (mgreater
175 (setf r (cons (car p) r)
176 p (cdr p)))
177 (t (setf r (cons (make-term (termlist-lm q) (funcall (ring-uminus ring) (termlist-lc q))) r)
178 q (cdr q)))))
179 nil))
180 r)))
181
182;; Multiplication of polynomials
183;; Non-destructive version
184(defun termlist-mul (ring p q)
185 (cond ((or (endp p) (endp q)) nil) ;p or q is 0 (represented by NIL)
186 ;; If p=p0+p1 and q=q0+q1 then pq=p0q0+p0q1+p1q
187 ((endp (cdr p))
188 (term-times-termlist ring (car p) q))
189 ((endp (cdr q))
190 (termlist-times-term ring p (car q)))
191 (t
[379]192 (let ((head (term-mul-lst ring (termlist-lt p) (termlist-lt q)))
[150]193 (tail (termlist-add ring (term-times-termlist ring (car p) (cdr q))
194 (termlist-mul ring (cdr p) q))))
195 (cond ((null head) tail)
196 ((null tail) head)
197 (t (nconc head tail)))))))
198
199(defun termlist-unit (ring dimension)
200 (declare (fixnum dimension))
201 (list (make-term (make-monom dimension :initial-element 0)
202 (funcall (ring-unit ring)))))
203
204(defun termlist-expt (ring poly n &aux (dim (monom-dimension (termlist-lm poly))))
205 (declare (type fixnum n dim))
206 (cond
207 ((minusp n) (error "termlist-expt: Negative exponent."))
208 ((endp poly) (if (zerop n) (termlist-unit ring dim) nil))
209 (t
210 (do ((k 1 (ash k 1))
211 (q poly (termlist-mul ring q q)) ;keep squaring
212 (p (termlist-unit ring dim) (if (not (zerop (logand k n))) (termlist-mul ring p q) p)))
213 ((> k n) p)
214 (declare (fixnum k))))))
Note: See TracBrowser for help on using the repository browser.