Changeset 54
- Timestamp:
- 2015-06-05T11:16:40-07:00 (10 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/f4grobner/grobner.lisp
r47 r54 33 33 ($load "functs") 34 34 35 ;; Macros for making lists with iterators - an exammple of GENSYM 36 ;; MAKELIST-1 makes a list with one iterator, while MAKELIST accepts an 37 ;; arbitrary number of iterators 38 39 ;; Sample usage: 40 ;; Without a step: 41 ;; >(makelist-1 (* 2 i) i 0 10) 42 ;; (0 2 4 6 8 10 12 14 16 18 20) 43 ;; With a step of 3: 44 ;; >(makelist-1 (* 2 i) i 0 10 3) 45 ;; (0 6 12 18) 46 47 ;; Generate sums of squares of numbers between 1 and 4: 48 ;; >(makelist (+ (* i i) (* j j)) (i 1 4) (j 1 i)) 49 ;; (2 5 8 10 13 18 17 20 25 32) 50 ;; >(makelist (list i j '---> (+ (* i i) (* j j))) (i 1 4) (j 1 i)) 51 ;; ((1 1 ---> 2) (2 1 ---> 5) (2 2 ---> 8) (3 1 ---> 10) (3 2 ---> 13) 52 ;; (3 3 ---> 18) (4 1 ---> 17) (4 2 ---> 20) (4 3 ---> 25) (4 4 ---> 32)) 53 54 ;; Evaluate expression expr with variable set to lo, lo+1,... ,hi 55 ;; and put the results in a list. 56 (defmacro makelist-1 (expr var lo hi &optional (step 1)) 57 (let ((l (gensym))) 58 `(do ((,var ,lo (+ ,var ,step)) 59 (,l nil (cons ,expr ,l))) 60 ((> ,var ,hi) (reverse ,l)) 61 (declare (fixnum ,var))))) 62 63 (defmacro makelist (expr (var lo hi &optional (step 1)) &rest more) 64 (if (endp more) 65 `(makelist-1 ,expr ,var ,lo ,hi ,step) 66 (let* ((l (gensym))) 67 `(do ((,var ,lo (+ ,var ,step)) 68 (,l nil (nconc ,l `,(makelist ,expr ,@more)))) 69 ((> ,var ,hi) ,l) 70 (declare (fixnum ,var)))))) 71 72 ;;---------------------------------------------------------------- 73 ;; This package implements BASIC OPERATIONS ON MONOMIALS 74 ;;---------------------------------------------------------------- 75 ;; DATA STRUCTURES: Monomials are represented as lists: 76 ;; 77 ;; monom: (n1 n2 ... nk) where ni are non-negative integers 78 ;; 79 ;; However, lists may be implemented as other sequence types, 80 ;; so the flexibility to change the representation should be 81 ;; maintained in the code to use general operations on sequences 82 ;; whenever possible. The optimization for the actual representation 83 ;; should be left to declarations and the compiler. 84 ;;---------------------------------------------------------------- 85 ;; EXAMPLES: Suppose that variables are x and y. Then 86 ;; 87 ;; Monom x*y^2 ---> (1 2) 88 ;; 89 ;;---------------------------------------------------------------- 90 91 (deftype exponent () 92 "Type of exponent in a monomial." 93 'fixnum) 94 95 (deftype monom (&optional dim) 96 "Type of monomial." 97 `(simple-array exponent (,dim))) 98 99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 ;; 101 ;; Construction of monomials 102 ;; 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 105 (defmacro make-monom (dim &key (initial-contents nil initial-contents-supplied-p) 106 (initial-element 0 initial-element-supplied-p)) 107 "Make a monomial with DIM variables. Additional argument 108 INITIAL-CONTENTS specifies the list of powers of the consecutive 109 variables. The alternative additional argument INITIAL-ELEMENT 110 specifies the common power for all variables." 111 ;;(declare (fixnum dim)) 112 `(make-array ,dim 113 :element-type 'exponent 114 ,@(when initial-contents-supplied-p `(:initial-contents ,initial-contents)) 115 ,@(when initial-element-supplied-p `(:initial-element ,initial-element)))) 116 117 118 119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 ;; 121 ;; Operations on monomials 122 ;; 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 125 (defmacro monom-elt (m index) 126 "Return the power in the monomial M of variable number INDEX." 127 `(elt ,m ,index)) 128 129 (defun monom-dimension (m) 130 "Return the number of variables in the monomial M." 131 (length m)) 132 133 (defun monom-total-degree (m &optional (start 0) (end (length m))) 134 "Return the todal degree of a monomoal M. Optinally, a range 135 of variables may be specified with arguments START and END." 136 (declare (type monom m) (fixnum start end)) 137 (reduce #'+ m :start start :end end)) 138 139 (defun monom-sugar (m &aux (start 0) (end (length m))) 140 "Return the sugar of a monomial M. Optinally, a range 141 of variables may be specified with arguments START and END." 142 (declare (type monom m) (fixnum start end)) 143 (monom-total-degree m start end)) 144 145 (defun monom-div (m1 m2 &aux (result (copy-seq m1))) 146 "Divide monomial M1 by monomial M2." 147 (declare (type monom m1 m2 result)) 148 (map-into result #'- m1 m2)) 149 150 (defun monom-mul (m1 m2 &aux (result (copy-seq m1))) 151 "Multiply monomial M1 by monomial M2." 152 (declare (type monom m1 m2 result)) 153 (map-into result #'+ m1 m2)) 154 155 (defun monom-divides-p (m1 m2) 156 "Returns T if monomial M1 divides monomial M2, NIL otherwise." 157 (declare (type monom m1 m2)) 158 (every #'<= m1 m2)) 159 160 (defun monom-divides-monom-lcm-p (m1 m2 m3) 161 "Returns T if monomial M1 divides MONOM-LCM(M2,M3), NIL otherwise." 162 (declare (type monom m1 m2 m3)) 163 (every #'(lambda (x y z) (declare (type exponent x y z)) (<= x (max y z))) m1 m2 m3)) 164 165 (defun monom-lcm-divides-monom-lcm-p (m1 m2 m3 m4) 166 "Returns T if monomial MONOM-LCM(M1,M2) divides MONOM-LCM(M3,M4), NIL otherwise." 167 (declare (type monom m1 m2 m3 m4)) 168 (every #'(lambda (x y z w) (declare (type exponent x y z w)) (<= (max x y) (max z w))) m1 m2 m3 m4)) 169 170 (defun monom-lcm-equal-monom-lcm-p (m1 m2 m3 m4) 171 "Returns T if monomial MONOM-LCM(M1,M2) equals MONOM-LCM(M3,M4), NIL otherwise." 172 (declare (type monom m1 m2 m3 m4)) 173 (every #'(lambda (x y z w) (declare (type exponent x y z w)) (= (max x y) (max z w))) m1 m2 m3 m4)) 174 175 (defun monom-divisible-by-p (m1 m2) 176 "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise." 177 (declare (type monom m1 m2)) 178 (every #'>= m1 m2)) 179 180 (defun monom-rel-prime-p (m1 m2) 181 "Returns T if two monomials M1 and M2 are relatively prime (disjoint)." 182 (declare (type monom m1 m2)) 183 (every #'(lambda (x y) (declare (type exponent x y)) (zerop (min x y))) m1 m2)) 184 185 (defun monom-equal-p (m1 m2) 186 "Returns T if two monomials M1 and M2 are equal." 187 (declare (type monom m1 m2)) 188 (every #'= m1 m2)) 189 190 (defun monom-lcm (m1 m2 &aux (result (copy-seq m1))) 191 "Returns least common multiple of monomials M1 and M2." 192 (declare (type monom m1 m2)) 193 (map-into result #'max m1 m2)) 194 195 (defun monom-gcd (m1 m2 &aux (result (copy-seq m1))) 196 "Returns greatest common divisor of monomials M1 and M2." 197 (declare (type monom m1 m2)) 198 (map-into result #'min m1 m2)) 199 200 (defun monom-depends-p (m k) 201 "Return T if the monomial M depends on variable number K." 202 (declare (type monom m) (fixnum k)) 203 (plusp (elt m k))) 204 205 (defmacro monom-map (fun m &rest ml &aux (result `(copy-seq ,m))) 206 `(map-into ,result ,fun ,m ,@ml)) 207 208 (defmacro monom-append (m1 m2) 209 `(concatenate 'monom ,m1 ,m2)) 210 211 (defmacro monom-contract (k m) 212 `(subseq ,m ,k)) 213 214 (defun monom-exponents (m) 215 (declare (type monom m)) 216 (coerce m 'list)) 217 218 219 220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 221 ;; 222 ;; Implementations of various admissible monomial orders 223 ;; 224 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 225 226 ;; pure lexicographic 227 (defun lex> (p q &optional (start 0) (end (monom-dimension p))) 228 "Return T if P>Q with respect to lexicographic order, otherwise NIL. 229 The second returned value is T if P=Q, otherwise it is NIL." 230 (declare (type monom p q) (type fixnum start end)) 231 (do ((i start (1+ i))) 232 ((>= i end) (values nil t)) 233 (declare (type fixnum i)) 234 (cond 235 ((> (monom-elt p i) (monom-elt q i)) 236 (return-from lex> (values t nil))) 237 ((< (monom-elt p i) (monom-elt q i)) 238 (return-from lex> (values nil nil)))))) 239 240 ;; total degree order , ties broken by lexicographic 241 (defun grlex> (p q &optional (start 0) (end (monom-dimension p))) 242 "Return T if P>Q with respect to graded lexicographic order, otherwise NIL. 243 The second returned value is T if P=Q, otherwise it is NIL." 244 (declare (type monom p q) (type fixnum start end)) 245 (let ((d1 (monom-total-degree p start end)) 246 (d2 (monom-total-degree q start end))) 247 (cond 248 ((> d1 d2) (values t nil)) 249 ((< d1 d2) (values nil nil)) 250 (t 251 (lex> p q start end))))) 252 253 254 ;; total degree, ties broken by reverse lexicographic 255 (defun grevlex> (p q &optional (start 0) (end (monom-dimension p))) 256 "Return T if P>Q with respect to graded reverse lexicographic order, 257 NIL otherwise. The second returned value is T if P=Q, otherwise it is NIL." 258 (declare (type monom p q) (type fixnum start end)) 259 (let ((d1 (monom-total-degree p start end)) 260 (d2 (monom-total-degree q start end))) 261 (cond 262 ((> d1 d2) (values t nil)) 263 ((< d1 d2) (values nil nil)) 264 (t 265 (revlex> p q start end))))) 266 267 268 ;; reverse lexicographic 269 (defun revlex> (p q &optional (start 0) (end (monom-dimension p))) 270 "Return T if P>Q with respect to reverse lexicographic order, NIL 271 otherwise. The second returned value is T if P=Q, otherwise it is 272 NIL. This is not and admissible monomial order because some sets do 273 not have a minimal element. This order is useful in constructing other 274 orders." 275 (declare (type monom p q) (type fixnum start end)) 276 (do ((i (1- end) (1- i))) 277 ((< i start) (values nil t)) 278 (declare (type fixnum i)) 279 (cond 280 ((< (monom-elt p i) (monom-elt q i)) 281 (return-from revlex> (values t nil))) 282 ((> (monom-elt p i) (monom-elt q i)) 283 (return-from revlex> (values nil nil)))))) 284 285 286 (defun invlex> (p q &optional (start 0) (end (monom-dimension p))) 287 "Return T if P>Q with respect to inverse lexicographic order, NIL otherwise 288 The second returned value is T if P=Q, otherwise it is NIL." 289 (declare (type monom p q) (type fixnum start end)) 290 (do ((i (1- end) (1- i))) 291 ((< i start) (values nil t)) 292 (declare (type fixnum i)) 293 (cond 294 ((> (monom-elt p i) (monom-elt q i)) 295 (return-from invlex> (values t nil))) 296 ((< (monom-elt p i) (monom-elt q i)) 297 (return-from invlex> (values nil nil)))))) 298 299 300 301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 302 ;; 303 ;; Order making functions 304 ;; 305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 306 307 (defvar *monomial-order* #'lex> 308 "Default order for monomial comparisons") 309 310 (defmacro monomial-order (x y) 311 `(funcall *monomial-order* ,x ,y)) 312 313 (defun reverse-monomial-order (x y) 314 (monomial-order y x)) 315 316 (defvar *primary-elimination-order* #'lex>) 317 318 (defvar *secondary-elimination-order* #'lex>) 319 320 (defvar *elimination-order* nil 321 "Default elimination order used in elimination-based functions. 322 If not NIL, it is assumed to be a proper elimination order. If NIL, 323 we will construct an elimination order using the values of 324 *PRIMARY-ELIMINATION-ORDER* and *SECONDARY-ELIMINATION-ORDER*.") 325 326 (defun elimination-order (k) 327 "Return a predicate which compares monomials according to the 328 K-th elimination order. Two variables *PRIMARY-ELIMINATION-ORDER* 329 and *SECONDARY-ELIMINATION-ORDER* control the behavior on the first K 330 and the remaining variables, respectively." 331 (declare (type fixnum k)) 332 #'(lambda (p q &optional (start 0) (end (monom-dimension p))) 333 (declare (type monom p q) (type fixnum start end)) 334 (multiple-value-bind (primary equal) 335 (funcall *primary-elimination-order* p q start k) 336 (if equal 337 (funcall *secondary-elimination-order* p q k end) 338 (values primary nil))))) 339 340 (defun elimination-order-1 (p q &optional (start 0) (end (monom-dimension p))) 341 "Equivalent to the function returned by the call to (ELIMINATION-ORDER 1)." 342 (declare (type monom p q) (type fixnum start end)) 343 (cond 344 ((> (monom-elt p start) (monom-elt q start)) (values t nil)) 345 ((< (monom-elt p start) (monom-elt q start)) (values nil nil)) 346 (t (funcall *secondary-elimination-order* p q (1+ start) end)))) 347 348 349 350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 351 ;; 352 ;; Priority queue stuff 353 ;; 354 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 355 356 (defparameter *priority-queue-allocation-size* 16) 357 358 (defun priority-queue-make-heap (&key (element-type 'fixnum)) 359 (make-array *priority-queue-allocation-size* :element-type element-type :fill-pointer 1 360 :adjustable t)) 361 362 (defstruct (priority-queue (:constructor priority-queue-construct)) 363 (heap (priority-queue-make-heap)) 364 test) 365 366 (defun make-priority-queue (&key (element-type 'fixnum) 367 (test #'<=) 368 (element-key #'identity)) 369 (priority-queue-construct 370 :heap (priority-queue-make-heap :element-type element-type) 371 :test #'(lambda (x y) (funcall test (funcall element-key y) (funcall element-key x))))) 372 373 (defun priority-queue-insert (pq item) 374 (priority-queue-heap-insert (priority-queue-heap pq) item (priority-queue-test pq))) 375 376 (defun priority-queue-remove (pq) 377 (priority-queue-heap-remove (priority-queue-heap pq) (priority-queue-test pq))) 378 379 (defun priority-queue-empty-p (pq) 380 (priority-queue-heap-empty-p (priority-queue-heap pq))) 381 382 (defun priority-queue-size (pq) 383 (fill-pointer (priority-queue-heap pq))) 384 385 (defun priority-queue-upheap (a k 386 &optional 387 (test #'<=) 388 &aux (v (aref a k))) 389 (declare (fixnum k)) 390 (assert (< 0 k (fill-pointer a))) 391 (loop 392 (let ((parent (ash k -1))) 393 (when (zerop parent) (return)) 394 (unless (funcall test (aref a parent) v) 395 (return)) 396 (setf (aref a k) (aref a parent) 397 k parent))) 398 (setf (aref a k) v) 399 a) 400 401 402 (defun priority-queue-heap-insert (a item &optional (test #'<=)) 403 (vector-push-extend item a) 404 (priority-queue-upheap a (1- (fill-pointer a)) test)) 405 406 (defun priority-queue-downheap (a k 407 &optional 408 (test #'<=) 409 &aux (v (aref a k)) (j 0) (n (fill-pointer a))) 410 (declare (fixnum k n j)) 411 (loop 412 (unless (<= k (ash n -1)) 413 (return)) 414 (setf j (ash k 1)) 415 (if (and (< j n) (not (funcall test (aref a (1+ j)) (aref a j)))) 416 (incf j)) 417 (when (funcall test (aref a j) v) 418 (return)) 419 (setf (aref a k) (aref a j) 420 k j)) 421 (setf (aref a k) v) 422 a) 423 424 (defun priority-queue-heap-remove (a &optional (test #'<=) &aux (v (aref a 1))) 425 (when (<= (fill-pointer a) 1) (error "Empty queue.")) 426 (setf (aref a 1) (vector-pop a)) 427 (priority-queue-downheap a 1 test) 428 (values v a)) 429 430 (defun priority-queue-heap-empty-p (a) 431 (<= (fill-pointer a) 1)) 35 36 432 37 433 38 … … 530 135 ;; 531 136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 532 533 (defun make-term-variable (ring nvars pos534 &optional535 (power 1)536 (coeff (funcall (ring-unit ring)))537 &aux538 (monom (make-monom nvars :initial-element 0)))539 (declare (fixnum nvars pos power))540 (incf (monom-elt monom pos) power)541 (make-term monom coeff))542 543 (defstruct (term544 (:constructor make-term (monom coeff))545 ;;(:constructor make-term-variable)546 ;;(:type list)547 )548 (monom (make-monom 0) :type monom)549 (coeff nil))550 551 (defun term-sugar (term)552 (monom-sugar (term-monom term)))553 554 (defun termlist-sugar (p &aux (sugar -1))555 (declare (fixnum sugar))556 (dolist (term p sugar)557 (setf sugar (max sugar (term-sugar term)))))558 137 559 138 … … 703 282 704 283 705 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;706 ;;707 ;; Additional structure operations on a list of terms708 ;;709 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;710 711 (defun termlist-contract (p &optional (k 1))712 "Eliminate first K variables from a polynomial P."713 (mapcar #'(lambda (term) (make-term (monom-contract k (term-monom term))714 (term-coeff term)))715 p))716 717 (defun termlist-extend (p &optional (m (make-monom 1 :initial-element 0)))718 "Extend every monomial in a polynomial P by inserting at the719 beginning of every monomial the list of powers M."720 (mapcar #'(lambda (term) (make-term (monom-append m (term-monom term))721 (term-coeff term)))722 p))723 724 (defun termlist-add-variables (p n)725 "Add N variables to a polynomial P by inserting zero powers726 at the beginning of each monomial."727 (declare (fixnum n))728 (mapcar #'(lambda (term)729 (make-term (monom-append (make-monom n :initial-element 0)730 (term-monom term))731 (term-coeff term)))732 p))733 734 735 736 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;737 ;;738 ;; Arithmetic on polynomials739 ;;740 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;741 742 (defstruct (poly743 ;;BOA constructor, by default constructs zero polynomial744 (:constructor make-poly-from-termlist (termlist &optional (sugar (termlist-sugar termlist))))745 (:constructor make-poly-zero (&aux (termlist nil) (sugar -1)))746 ;;Constructor of polynomials representing a variable747 (:constructor make-variable (ring nvars pos &optional (power 1)748 &aux749 (termlist (list750 (make-term-variable ring nvars pos power)))751 (sugar power)))752 (:constructor poly-unit (ring dimension753 &aux754 (termlist (termlist-unit ring dimension))755 (sugar 0))))756 (termlist nil :type list)757 (sugar -1 :type fixnum))758 759 ;; Leading term760 (defmacro poly-lt (p) `(car (poly-termlist ,p)))761 762 ;; Second term763 (defmacro poly-second-lt (p) `(cadar (poly-termlist ,p)))764 765 ;; Leading monomial766 (defun poly-lm (p) (term-monom (poly-lt p)))767 768 ;; Second monomial769 (defun poly-second-lm (p) (term-monom (poly-second-lt p)))770 771 ;; Leading coefficient772 (defun poly-lc (p) (term-coeff (poly-lt p)))773 774 ;; Second coefficient775 (defun poly-second-lc (p) (term-coeff (poly-second-lt p)))776 777 ;; Testing for a zero polynomial778 (defun poly-zerop (p) (null (poly-termlist p)))779 780 ;; The number of terms781 (defun poly-length (p) (length (poly-termlist p)))782 783 (defun scalar-times-poly (ring c p)784 (make-poly-from-termlist (scalar-times-termlist ring c (poly-termlist p)) (poly-sugar p)))785 786 ;; The scalar product omitting the head term787 (defun scalar-times-poly-1 (ring c p)788 (make-poly-from-termlist (scalar-times-termlist ring c (cdr (poly-termlist p))) (poly-sugar p)))789 790 (defun monom-times-poly (m p)791 (make-poly-from-termlist (monom-times-termlist m (poly-termlist p)) (+ (poly-sugar p) (monom-sugar m))))792 793 (defun term-times-poly (ring term p)794 (make-poly-from-termlist (term-times-termlist ring term (poly-termlist p)) (+ (poly-sugar p) (term-sugar term))))795 796 (defun poly-add (ring p q)797 (make-poly-from-termlist (termlist-add ring (poly-termlist p) (poly-termlist q)) (max (poly-sugar p) (poly-sugar q))))798 799 (defun poly-sub (ring p q)800 (make-poly-from-termlist (termlist-sub ring (poly-termlist p) (poly-termlist q)) (max (poly-sugar p) (poly-sugar q))))801 802 (defun poly-uminus (ring p)803 (make-poly-from-termlist (termlist-uminus ring (poly-termlist p)) (poly-sugar p)))804 805 (defun poly-mul (ring p q)806 (make-poly-from-termlist (termlist-mul ring (poly-termlist p) (poly-termlist q)) (+ (poly-sugar p) (poly-sugar q))))807 808 (defun poly-expt (ring p n)809 (make-poly-from-termlist (termlist-expt ring (poly-termlist p) n) (* n (poly-sugar p))))810 811 (defun poly-append (&rest plist)812 (make-poly-from-termlist (apply #'append (mapcar #'poly-termlist plist))813 (apply #'max (mapcar #'poly-sugar plist))))814 815 (defun poly-nreverse (p)816 (setf (poly-termlist p) (nreverse (poly-termlist p)))817 p)818 819 (defun poly-contract (p &optional (k 1))820 (make-poly-from-termlist (termlist-contract (poly-termlist p) k)821 (poly-sugar p)))822 823 (defun poly-extend (p &optional (m (make-monom 1 :initial-element 0)))824 (make-poly-from-termlist825 (termlist-extend (poly-termlist p) m)826 (+ (poly-sugar p) (monom-sugar m))))827 828 (defun poly-add-variables (p k)829 (setf (poly-termlist p) (termlist-add-variables (poly-termlist p) k))830 p)831 832 (defun poly-list-add-variables (plist k)833 (mapcar #'(lambda (p) (poly-add-variables p k)) plist))834 835 (defun poly-standard-extension (plist &aux (k (length plist)))836 "Calculate [U1*P1,U2*P2,...,UK*PK], where PLIST=[P1,P2,...,PK]."837 (declare (list plist) (fixnum k))838 (labels ((incf-power (g i)839 (dolist (x (poly-termlist g))840 (incf (monom-elt (term-monom x) i)))841 (incf (poly-sugar g))))842 (setf plist (poly-list-add-variables plist k))843 (dotimes (i k plist)844 (incf-power (nth i plist) i))))845 846 (defun saturation-extension (ring f plist &aux (k (length plist)) (d (monom-dimension (poly-lm (car plist)))))847 "Calculate [F, U1*P1-1,U2*P2-1,...,UK*PK-1], where PLIST=[P1,P2,...,PK]."848 (setf f (poly-list-add-variables f k)849 plist (mapcar #'(lambda (x)850 (setf (poly-termlist x) (nconc (poly-termlist x)851 (list (make-term (make-monom d :initial-element 0)852 (funcall (ring-uminus ring) (funcall (ring-unit ring)))))))853 x)854 (poly-standard-extension plist)))855 (append f plist))856 857 858 (defun polysaturation-extension (ring f plist &aux (k (length plist))859 (d (+ k (length (poly-lm (car plist))))))860 "Calculate [F, U1*P1+U2*P2+...+UK*PK-1], where PLIST=[P1,P2,...,PK]."861 (setf f (poly-list-add-variables f k)862 plist (apply #'poly-append (poly-standard-extension plist))863 (cdr (last (poly-termlist plist))) (list (make-term (make-monom d :initial-element 0)864 (funcall (ring-uminus ring) (funcall (ring-unit ring))))))865 (append f (list plist)))866 867 (defun saturation-extension-1 (ring f p) (polysaturation-extension ring f (list p)))868 869 870 871 872 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;873 ;;874 ;; Evaluation of polynomial (prefix) expressions875 ;;876 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;877 878 (defun coerce-coeff (ring expr vars)879 "Coerce an element of the coefficient ring to a constant polynomial."880 ;; Modular arithmetic handler by rat881 (make-poly-from-termlist (list (make-term (make-monom (length vars) :initial-element 0)882 (funcall (ring-parse ring) expr)))883 0))884 885 (defun poly-eval (ring expr vars &optional (list-marker '[))886 (labels ((p-eval (arg) (poly-eval ring arg vars))887 (p-eval-list (args) (mapcar #'p-eval args))888 (p-add (x y) (poly-add ring x y)))889 (cond890 ((eql expr 0) (make-poly-zero))891 ((member expr vars :test #'equalp)892 (let ((pos (position expr vars :test #'equalp)))893 (make-variable ring (length vars) pos)))894 ((atom expr)895 (coerce-coeff ring expr vars))896 ((eq (car expr) list-marker)897 (cons list-marker (p-eval-list (cdr expr))))898 (t899 (case (car expr)900 (+ (reduce #'p-add (p-eval-list (cdr expr))))901 (- (case (length expr)902 (1 (make-poly-zero))903 (2 (poly-uminus ring (p-eval (cadr expr))))904 (3 (poly-sub ring (p-eval (cadr expr)) (p-eval (caddr expr))))905 (otherwise (poly-sub ring (p-eval (cadr expr))906 (reduce #'p-add (p-eval-list (cddr expr)))))))907 (*908 (if (endp (cddr expr)) ;unary909 (p-eval (cdr expr))910 (reduce #'(lambda (p q) (poly-mul ring p q)) (p-eval-list (cdr expr)))))911 (expt912 (cond913 ((member (cadr expr) vars :test #'equalp)914 ;;Special handling of (expt var pow)915 (let ((pos (position (cadr expr) vars :test #'equalp)))916 (make-variable ring (length vars) pos (caddr expr))))917 ((not (and (integerp (caddr expr)) (plusp (caddr expr))))918 ;; Negative power means division in coefficient ring919 ;; Non-integer power means non-polynomial coefficient920 (coerce-coeff ring expr vars))921 (t (poly-expt ring (p-eval (cadr expr)) (caddr expr)))))922 (otherwise923 (coerce-coeff ring expr vars)))))))924 925 284 926 285 … … 931 290 ;; 932 291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 933 934 935 936 292 (defmacro debug-cgb (&rest args) 937 293 `(when $poly_grobner_debug (format *terminal-io* ,@args)))
Note:
See TracChangeset
for help on using the changeset viewer.