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/polynomial.lisp@ 52

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

* empty log message *

File size: 4.9 KB
Line 
1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;;
3;; Polynomials
4;;
5;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6
7(defstruct (poly
8 ;;
9 ;; BOA constructor, by default constructs zero polynomial
10 (:constructor make-poly-from-termlist (termlist &optional (sugar (termlist-sugar termlist))))
11 (:constructor make-poly-zero (&aux (termlist nil) (sugar -1)))
12 ;; Constructor of polynomials representing a variable
13 (:constructor make-variable (ring nvars pos &optional (power 1)
14 &aux
15 (termlist (list
16 (make-term-variable ring nvars pos power)))
17 (sugar power)))
18 (:constructor poly-unit (ring dimension
19 &aux
20 (termlist (termlist-unit ring dimension))
21 (sugar 0))))
22 (termlist nil :type list)
23 (sugar -1 :type fixnum))
24
25;; Leading term
26(defmacro poly-lt (p) `(car (poly-termlist ,p)))
27
28;; Second term
29(defmacro poly-second-lt (p) `(cadar (poly-termlist ,p)))
30
31;; Leading monomial
32(defun poly-lm (p) (term-monom (poly-lt p)))
33
34;; Second monomial
35(defun poly-second-lm (p) (term-monom (poly-second-lt p)))
36
37;; Leading coefficient
38(defun poly-lc (p) (term-coeff (poly-lt p)))
39
40;; Second coefficient
41(defun poly-second-lc (p) (term-coeff (poly-second-lt p)))
42
43;; Testing for a zero polynomial
44(defun poly-zerop (p) (null (poly-termlist p)))
45
46;; The number of terms
47(defun poly-length (p) (length (poly-termlist p)))
48
49(defun scalar-times-poly (ring c p)
50 (make-poly-from-termlist (scalar-times-termlist ring c (poly-termlist p)) (poly-sugar p)))
51
52;; The scalar product omitting the head term
53(defun scalar-times-poly-1 (ring c p)
54 (make-poly-from-termlist (scalar-times-termlist ring c (cdr (poly-termlist p))) (poly-sugar p)))
55
56(defun monom-times-poly (m p)
57 (make-poly-from-termlist (monom-times-termlist m (poly-termlist p)) (+ (poly-sugar p) (monom-sugar m))))
58
59(defun term-times-poly (ring term p)
60 (make-poly-from-termlist (term-times-termlist ring term (poly-termlist p)) (+ (poly-sugar p) (term-sugar term))))
61
62(defun poly-add (ring p q)
63 (make-poly-from-termlist (termlist-add ring (poly-termlist p) (poly-termlist q)) (max (poly-sugar p) (poly-sugar q))))
64
65(defun poly-sub (ring p q)
66 (make-poly-from-termlist (termlist-sub ring (poly-termlist p) (poly-termlist q)) (max (poly-sugar p) (poly-sugar q))))
67
68(defun poly-uminus (ring p)
69 (make-poly-from-termlist (termlist-uminus ring (poly-termlist p)) (poly-sugar p)))
70
71(defun poly-mul (ring p q)
72 (make-poly-from-termlist (termlist-mul ring (poly-termlist p) (poly-termlist q)) (+ (poly-sugar p) (poly-sugar q))))
73
74(defun poly-expt (ring p n)
75 (make-poly-from-termlist (termlist-expt ring (poly-termlist p) n) (* n (poly-sugar p))))
76
77(defun poly-append (&rest plist)
78 (make-poly-from-termlist (apply #'append (mapcar #'poly-termlist plist))
79 (apply #'max (mapcar #'poly-sugar plist))))
80
81(defun poly-nreverse (p)
82 (setf (poly-termlist p) (nreverse (poly-termlist p)))
83 p)
84
85(defun poly-contract (p &optional (k 1))
86 (make-poly-from-termlist (termlist-contract (poly-termlist p) k)
87 (poly-sugar p)))
88
89(defun poly-extend (p &optional (m (make-monom 1 :initial-element 0)))
90 (make-poly-from-termlist
91 (termlist-extend (poly-termlist p) m)
92 (+ (poly-sugar p) (monom-sugar m))))
93
94(defun poly-add-variables (p k)
95 (setf (poly-termlist p) (termlist-add-variables (poly-termlist p) k))
96 p)
97
98(defun poly-list-add-variables (plist k)
99 (mapcar #'(lambda (p) (poly-add-variables p k)) plist))
100
101(defun poly-standard-extension (plist &aux (k (length plist)))
102 "Calculate [U1*P1,U2*P2,...,UK*PK], where PLIST=[P1,P2,...,PK]."
103 (declare (list plist) (fixnum k))
104 (labels ((incf-power (g i)
105 (dolist (x (poly-termlist g))
106 (incf (monom-elt (term-monom x) i)))
107 (incf (poly-sugar g))))
108 (setf plist (poly-list-add-variables plist k))
109 (dotimes (i k plist)
110 (incf-power (nth i plist) i))))
111
112(defun saturation-extension (ring f plist &aux (k (length plist)) (d (monom-dimension (poly-lm (car plist)))))
113 "Calculate [F, U1*P1-1,U2*P2-1,...,UK*PK-1], where PLIST=[P1,P2,...,PK]."
114 (setf f (poly-list-add-variables f k)
115 plist (mapcar #'(lambda (x)
116 (setf (poly-termlist x) (nconc (poly-termlist x)
117 (list (make-term (make-monom d :initial-element 0)
118 (funcall (ring-uminus ring) (funcall (ring-unit ring)))))))
119 x)
120 (poly-standard-extension plist)))
121 (append f plist))
122
123
124(defun polysaturation-extension (ring f plist &aux (k (length plist))
125 (d (+ k (length (poly-lm (car plist))))))
126 "Calculate [F, U1*P1+U2*P2+...+UK*PK-1], where PLIST=[P1,P2,...,PK]."
127 (setf f (poly-list-add-variables f k)
128 plist (apply #'poly-append (poly-standard-extension plist))
129 (cdr (last (poly-termlist plist))) (list (make-term (make-monom d :initial-element 0)
130 (funcall (ring-uminus ring) (funcall (ring-unit ring))))))
131 (append f (list plist)))
132
133(defun saturation-extension-1 (ring f p) (polysaturation-extension ring f (list p)))
Note: See TracBrowser for help on using the repository browser.