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

Last change on this file since 386 was 380, checked in by Marek Rychlik, 9 years ago

* empty log message *

File size: 5.6 KB
Line 
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
22(in-package :ngrobner)
23
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25;;
26;; Low-level polynomial arithmetic done on
27;; lists of terms
28;;
29;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30
31(defmacro termlist-lt (p) `(car ,p))
32(defun termlist-lm (p) (term-monom (termlist-lt p)))
33(defun termlist-lc (p) (term-coeff (termlist-lt p)))
34
35(define-modify-macro scalar-mul (c) coeff-mul)
36
37(defun scalar-times-termlist (ring c p)
38 "Multiply scalar C by a polynomial P. This function works
39even if there are divisors of 0."
40 (mapcan
41 #'(lambda (term)
42 (let ((c1 (funcall (ring-mul ring) c (term-coeff term))))
43 (unless (funcall (ring-zerop ring) c1)
44 (list (make-term (term-monom term) c1)))))
45 p))
46
47
48(defun term-mul-lst (ring term1 term2)
49 "A special version of term multiplication. Returns (LIST TERM) where
50TERM is the product of the terms TERM1 TERM2, or NIL when the product
51is 0. This definition takes care of divisors of 0 in the coefficient
52ring."
53 (let ((c (funcall (ring-mul ring) (term-coeff term1) (term-coeff term2))))
54 (unless (funcall (ring-zerop ring) c)
55 (list (make-term (monom-mul (term-monom term1) (term-monom term2)) c)))))
56
57(defun term-times-termlist (ring term f)
58 (declare (type ring ring))
59 (mapcan #'(lambda (term-f) (term-mul-lst ring term term-f)) f))
60
61(defun termlist-times-term (ring f term)
62 (mapcan #'(lambda (term-f) (term-mul-lst ring term-f term)) f))
63
64(defun monom-times-term (m term)
65 (make-term (monom-mul m (term-monom term)) (term-coeff term)))
66
67(defun monom-times-termlist (m f)
68 (cond
69 ((null f) nil)
70 (t
71 (mapcar #'(lambda (x) (monom-times-term m x)) f))))
72
73(defun termlist-uminus (ring f)
74 (mapcar #'(lambda (x)
75 (make-term (term-monom x) (funcall (ring-uminus ring) (term-coeff x))))
76 f))
77
78(defun termlist-add (ring p q)
79 (declare (type list p q))
80 (do (r)
81 ((cond
82 ((endp p)
83 (setf r (revappend r q)) t)
84 ((endp q)
85 (setf r (revappend r p)) t)
86 (t
87 (multiple-value-bind
88 (lm-greater lm-equal)
89 (monomial-order (termlist-lm p) (termlist-lm q))
90 (cond
91 (lm-equal
92 (let ((s (funcall (ring-add ring) (termlist-lc p) (termlist-lc q))))
93 (unless (funcall (ring-zerop ring) s) ;check for cancellation
94 (setf r (cons (make-term (termlist-lm p) s) r)))
95 (setf p (cdr p) q (cdr q))))
96 (lm-greater
97 (setf r (cons (car p) r)
98 p (cdr p)))
99 (t (setf r (cons (car q) r)
100 q (cdr q)))))
101 nil))
102 r)))
103
104(defun termlist-sub (ring p q)
105 (declare (type list p q))
106 (do (r)
107 ((cond
108 ((endp p)
109 (setf r (revappend r (termlist-uminus ring q)))
110 t)
111 ((endp q)
112 (setf r (revappend r p))
113 t)
114 (t
115 (multiple-value-bind
116 (mgreater mequal)
117 (monomial-order (termlist-lm p) (termlist-lm q))
118 (cond
119 (mequal
120 (let ((s (funcall (ring-sub ring) (termlist-lc p) (termlist-lc q))))
121 (unless (funcall (ring-zerop ring) s) ;check for cancellation
122 (setf r (cons (make-term (termlist-lm p) s) r)))
123 (setf p (cdr p) q (cdr q))))
124 (mgreater
125 (setf r (cons (car p) r)
126 p (cdr p)))
127 (t (setf r (cons (make-term (termlist-lm q) (funcall (ring-uminus ring) (termlist-lc q))) r)
128 q (cdr q)))))
129 nil))
130 r)))
131
132;; Multiplication of polynomials
133;; Non-destructive version
134(defun termlist-mul (ring p q)
135 (cond ((or (endp p) (endp q)) nil) ;p or q is 0 (represented by NIL)
136 ;; If p=p0+p1 and q=q0+q1 then pq=p0q0+p0q1+p1q
137 ((endp (cdr p))
138 (term-times-termlist ring (car p) q))
139 ((endp (cdr q))
140 (termlist-times-term ring p (car q)))
141 (t
142 (let ((head (term-mul-lst ring (termlist-lt p) (termlist-lt q)))
143 (tail (termlist-add ring (term-times-termlist ring (car p) (cdr q))
144 (termlist-mul ring (cdr p) q))))
145 (cond ((null head) tail)
146 ((null tail) head)
147 (t (nconc head tail)))))))
148
149(defun termlist-unit (ring dimension)
150 (declare (fixnum dimension))
151 (list (make-term (make-monom dimension :initial-element 0)
152 (funcall (ring-unit ring)))))
153
154(defun termlist-expt (ring poly n &aux (dim (monom-dimension (termlist-lm poly))))
155 (declare (type fixnum n dim))
156 (cond
157 ((minusp n) (error "termlist-expt: Negative exponent."))
158 ((endp poly) (if (zerop n) (termlist-unit ring dim) nil))
159 (t
160 (do ((k 1 (ash k 1))
161 (q poly (termlist-mul ring q q)) ;keep squaring
162 (p (termlist-unit ring dim) (if (not (zerop (logand k n))) (termlist-mul ring p q) p)))
163 ((> k n) p)
164 (declare (fixnum k))))))
Note: See TracBrowser for help on using the repository browser.