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/5am-poly.lisp

Last change on this file was 4442, checked in by Marek Rychlik, 8 years ago
File size: 8.7 KB
Line 
1;;; -*- Mode: Lisp -*-
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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23;;
24;; Run tests using 5am unit testing framework
25;;
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28;; We assume that QuickLisp package manager is installed.
29;; See :
30;; https://www.quicklisp.org/beta/
31;;
32
33;; The following is unnecessary after running:
34;; * (ql:add-to-init-file)
35;; at lisp prompt:
36;;(load "~/quicklisp/setup")
37
38(ql:quickload :fiveam)
39
40(defpackage #:5am-poly
41 (:use :cl :it.bese.fiveam :monom :polynomial :ring))
42
43(in-package :5am-poly)
44
45(def-suite poly-suite
46 :description "Polynomial package suite")
47
48(in-suite poly-suite)
49
50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51;;
52;; POLY class tests
53;;
54;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55
56(def-fixture poly-add-context ()
57 (let ((p (make-instance 'poly))
58 (q (make-instance 'poly :order nil))
59 (p+q (make-instance 'poly))
60 (p-q (make-instance 'poly))
61 (p-uminus (make-instance 'poly)))
62 ;; Populate the polynomials; the lists of (exponents . coefficient) pairs
63 ;; must be in increasing order in Q, but Q is unordered (:ORDER NIL)
64 ;; so it will be automatically sorted.
65 (dolist (x '( ((2) . 22) ((4) . 44) ((5) . 55) ((8) . 88) ((9) . 99) ))
66 (poly-insert-term p (make-instance 'term :exponents (car x) :coeff (cdr x))))
67 (dolist (x '( ((9) . 90) ((0) . 11) ((2) . 20) ((3) . 33) ((4) . -44) ((7) . 77) ((8) . 88) ))
68 (poly-insert-term q (make-instance 'term :exponents (car x) :coeff (cdr x))))
69 ;; P+Q
70 (dolist (x '(((0) . 11) ((2) . 42) ((3) . 33) ((5) . 55) ((7) . 77) ((8) . 176) ((9) . 189) ))
71 (poly-insert-term p+q (make-instance 'term :exponents (car x) :coeff (cdr x))))
72 ;; P-Q
73 (dolist (x '(((0) . -11) ((2) . 2) ((3) . -33) ((4) . 88) ((5) . 55) ((7) . -77) ((9) . 9)))
74 (poly-insert-term p-q (make-instance 'term :exponents (car x) :coeff (cdr x))))
75 ;; -P
76 (dolist (x '( ((2) . -22) ((4) . -44) ((5) . -55) ((8) . -88) ((9) . -99)))
77 (poly-insert-term p-uminus (make-instance 'term :exponents (car x) :coeff (cdr x))))
78 ;;(print p) (print q) (print p+q) (print p-q)
79 (&body)))
80
81(test poly-add
82 "Polynomial addition"
83 (with-fixture poly-add-context () (is (universal-equalp (add-to p q) p+q)))
84 (with-fixture poly-add-context () (is (universal-equalp (add p q) p+q)))
85 (with-fixture poly-add-context () (is (universal-equalp (subtract-from p q) p-q)))
86 (with-fixture poly-add-context () (is (universal-equalp (subtract p q) p-q)))
87 (with-fixture poly-add-context () (is (universal-equalp (unary-minus p) p-uminus)))
88 )
89
90(test poly-add-more
91 "More polynomial addition"
92 (is (equal (poly->alist (add-to
93 (alist->poly '(((0) . 1)))
94 (alist->poly '(((1) . 2)))))
95 '(((1) . 2) ((0) . 1))))
96 (is (equal (poly->alist (add-to
97 (alist->poly '(((0) . 1)))
98 (alist->poly '(((0) . 2)))))
99 '(((0) . 3))))
100 (is (equal (poly->alist (add-to
101 (alist->poly '(((0) . 1) ((2) . 5)))
102 (alist->poly '(((1) . 2) ((3) . 7)))))
103 '(((3) . 7) ((2) . 5) ((1) . 2) ((0) . 1)))))
104
105(def-fixture poly-multiply-context ()
106 (let ((p (make-instance 'poly))
107 (q (make-instance 'poly :order nil))
108 (p*q (make-instance 'poly)))
109 ;; Populate the polynomials; the lists of (exponents . coefficient) pairs
110 ;; must be in increasing order in Q, but Q is unordered (:ORDER NIL)
111 ;; so it will be automatically sorted.
112 (dolist (x '( ((0) . 1) ((1) . 2) ))
113 (poly-insert-term p (make-instance 'term :exponents (car x) :coeff (cdr x))))
114 (dolist (x '( ((0) . 1) ((1) . 3) ))
115 (poly-insert-term q (make-instance 'term :exponents (car x) :coeff (cdr x))))
116 ;; P*Q
117 (dolist (x '( ((0) . 1) ((1) . 5) ((2) . 6)))
118 (poly-insert-term p*q (make-instance 'term :exponents (car x) :coeff (cdr x))))
119 (&body)))
120
121
122(test poly-multiply
123 "Polynomial multiplication"
124 (with-fixture poly-multiply-context () (is (universal-equalp (multiply p q) p*q)))
125 )
126
127(test poly-standard-extension
128 "Standard extension"
129 (let* ((p (alist->poly '( ((0) . 1) ((1) . 2))))
130 (q (alist->poly '( ((0) . 1) ((2) . 3))))
131 (plist (list p q))
132 (p-ext (alist->poly '( ((1 0 0) . 1) ((1 0 1) . 2))))
133 (q-ext (alist->poly '( ((0 1 0) . 1) ((0 1 2) . 3))))
134 (plist-st-ext (list p-ext q-ext)))
135 (is (universal-equalp (standard-extension plist) plist-st-ext))))
136
137(test poly-standard-extension-1
138 "Standard extension 1"
139 (let* ((p (alist->poly '( ((0) . 1) ((1) . 2))))
140 (q (alist->poly '( ((0) . 1) ((2) . 3))))
141 (plist (list p q))
142 (p-ext (alist->poly '( ((0 0 0) . -1) ((1 0 0) . 1) ((1 0 1) . 2))))
143 (q-ext (alist->poly '( ((0 0 0) . -1) ((0 1 0) . 1) ((0 1 2) . 3))))
144 (plist-st-ext (list p-ext q-ext)))
145 (is (universal-equalp (standard-extension-1 plist) plist-st-ext))))
146
147(test poly-standard-sum
148 "Standard sum"
149 (let* ((p (alist->poly '( ((0) . 1) ((1) . 2))))
150 (q (alist->poly '( ((0) . 1) ((2) . 3))))
151 (plist (list p q))
152 (std-sum (alist->poly '(((0 0 0) . -1) ((0 1 0) . 1) ((0 1 2) . 3)
153 ((1 0 0) . 1) ((1 0 1) . 2)))))
154 (is (universal-equalp (standard-sum plist) std-sum))))
155
156(test poly-s-polynomial
157 "S-Polynomial"
158 (let* ((f (alist->poly '( ((1 0 0) . 1) ((1 0 1) . 2)))) ;x+2*x*z |*y*z
159 (g (alist->poly '( ((0 1 0) . 1) ((0 1 2) . 2)))) ;y+2*y*z^2 |*x
160 (s-poly (alist->poly '( ((1 1 0) . -1) ((1 1 1) . 1)))); x*y*z - x*y
161 )
162 (is (universal-equalp (s-polynomial f g) s-poly))))
163
164(test poly-s-polynomial-alt
165 "S-Polynomial with non-coprime coeffs"
166 (let* ((f (alist->poly '( ((1 0 0) . 1) ((1 0 1) . 14)))) ;x+14*x*z |*3*y*z
167 (g (alist->poly '( ((0 1 0) . 1) ((0 1 2) . 21)))) ;y+21*y*z^2 |*2*x
168 (s-poly (alist->poly '( ((1 1 0) . -2) ((1 1 1) . 3)))) ;3*x*y*z - 2*x*y
169 )
170 (is (universal-equalp (s-polynomial f g) s-poly))))
171
172(test poly-content
173 "Poly-content"
174 (let* ((p (alist->poly '( ((1 0 0) . 12) ((1 0 1) . 15))))
175 (pc (make-instance 'integer-ring :value 3)))
176 (is (universal-equalp (poly-content p) pc))))
177
178(test poly-primitive-part
179 "Poly-primitive-part"
180 (let* ((p (alist->poly '( ((1 0 0) . 12) ((1 0 1) . 15))))
181 (pp (alist->poly '( ((1 0 0) . 4) ((1 0 1) . 5)))))
182 (is (universal-equalp (poly-primitive-part p) pp))))
183
184(test saturation-extension
185 "Saturation-extension"
186 (let* ((f (list (alist->poly '( ((1 0 0) . 2) ((1 0 1) . 3))) ;2*x+3*x*z
187 (alist->poly '( ((1 0 0) . 5) ((0 1 2) . 7)))) ;5*x+7*y*z^2
188 )
189 (p (alist->poly '( ((1 1 1) . 11) ((2 3 4) . 13)))) ;11*x*y*z+13*x^2*y^3*z^4
190 (sat-ext (list (alist->poly '( ((0 1 0 0) . 2) ((0 1 0 1) . 3)))
191 (alist->poly '( ((0 1 0 0) . 5) ((0 0 1 2) . 7)))
192 (alist->poly '( ((0 0 0 0) . -1) ((1 1 1 1) . 11) ((1 2 3 4) . 13) )))))
193 (is (universal-equalp (saturation-extension f (list p)) sat-ext))))
194
195(test saturation-extension-1
196 "Saturation-extension-1"
197 (let* ((f (list (alist->poly '( ((1 0 0) . 2) ((1 0 1) . 3))) ;2*x+3*x*z
198 (alist->poly '( ((1 0 0) . 5) ((0 1 2) . 7)))) ;5*x+7*y*z^2
199 )
200 (p (alist->poly '( ((1 1 1) . 11) ((2 3 4) . 13)))) ;11*x*y*z+13*x^2*y^3*z^4
201 (sat-ext-1 (list (alist->poly '( ((0 1 0 0) . 2) ((0 1 0 1) . 3)))
202 (alist->poly '( ((0 1 0 0) . 5) ((0 0 1 2) . 7)))
203 (alist->poly '( ((0 0 0 0) . -1) ((1 1 1 1) . 11) ((1 2 3 4) . 13) )))))
204 (is (universal-equalp (saturation-extension-1 f p) sat-ext-1))))
205
206(test universal-expt
207 "Universal-expt"
208 (let ((f (alist->poly '( ((0) . 1) ((1) . 1))))
209 (f2 (alist->poly '( ((0) . 1) ((1) . 2) ((2) . 1))))
210 (f3 (alist->poly '( ((0) . 1) ((1) . 3) ((2) . 3) ((3) . 1)))))
211 (is (universal-equalp (universal-expt f 2) f2))
212 (is (universal-equalp (universal-expt f 3) f3))))
213
214(run! 'poly-suite)
215(format t "All tests done!~%")
216
217
Note: See TracBrowser for help on using the repository browser.