Changeset 4173
- Timestamp:
- 2016-06-03T09:57:35-07:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/f4grobner/criterion.lisp
r4125 r4173 32 32 (proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0))) 33 33 34 (defun criterion-1 (pair) 35 "Returns T if the leading monomials of the two polynomials 36 in G pointed to by the integers in PAIR have disjoint (relatively prime) 37 monomials. This test is known as the first Buchberger criterion." 38 (declare (type critical-pair pair)) 39 (let ((f (critical-pair-first pair)) 40 (g (critical-pair-second pair))) 41 (when (rel-prime-p (leading-monomial f) (leading-monomial g)) 42 (debug-cgb ":1") 43 (return-from criterion-1 t)))) 34 (defgeneric criterion-1 (pair) 35 (:documentation "Returns T if the leading monomials of the two 36 polynomials in G pointed to by the integers in PAIR have 37 disjoint (relatively prime) monomials. This test is known as the first 38 Buchberger criterion.") 39 (:method ((pair critical-pair)) 40 (let ((f (critical-pair-first pair)) 41 (g (critical-pair-second pair))) 42 (when (rel-prime-p (leading-monomial f) (leading-monomial g)) 43 (debug-cgb ":1") 44 (return-from criterion-1 t))))) 44 45 45 (defun criterion-2 (pair b-done partial-basis 46 &aux (f (critical-pair-first pair)) (g (critical-pair-second pair)) 47 (place :before)) 48 "Returns T if the leading monomial of some element P of 49 PARTIAL-BASIS divides the LCM of the leading monomials of the two 46 (defgeneric criterion-2 (pair b-done partial-basis) 47 (:documentation "Returns T if the leading monomial of some element P 48 of PARTIAL-BASIS divides the LCM of the leading monomials of the two 50 49 polynomials in the polynomial list PARTIAL-BASIS, and P paired with 51 50 each of the polynomials pointed to by the the PAIR has already been 52 treated, as indicated by the absence in the hash table B-done." 53 (declare (type critical-pair pair) (type hash-table b-done) 54 (type poly f g)) 55 ;; In the code below we assume that pairs are ordered as follows: 56 ;; if PAIR is (I J) then I appears before J in the PARTIAL-BASIS. 57 ;; We traverse the list PARTIAL-BASIS and keep track of where we 58 ;; are, so that we can produce the pairs in the correct order 59 ;; when we check whether they have been processed, i.e they 60 ;; appear in the hash table B-done 61 (dolist (h partial-basis nil) 62 (cond 63 ((eq h f) 64 #+grobner-check(assert (eq place :before)) 65 (setf place :in-the-middle)) 66 ((eq h g) 67 #+grobner-check(assert (eq place :in-the-middle)) 68 (setf place :after)) 69 ((and (divides-lcm-p (leading-monomial h) (leading-monomial f) (leading-monomial g)) 70 (gethash (case place 71 (:before (list h f)) 72 ((:in-the-middle :after) (list f h))) 73 b-done) 74 (gethash (case place 75 ((:before :in-the-middle) (list h g)) 76 (:after (list g h))) 77 b-done)) 78 (debug-cgb ":2") 79 (return-from criterion-2 t))))) 51 treated, as indicated by the absence in the hash table B-done.") 52 (:method ((pair critical-pair) (b-done hash-table) partial-basis 53 &aux (f (critical-pair-first pair)) (g (critical-pair-second pair)) 54 (place :before)) 55 (declare (type poly f g)) 56 ;; In the code below we assume that pairs are ordered as follows: 57 ;; if PAIR is (I J) then I appears before J in the PARTIAL-BASIS. 58 ;; We traverse the list PARTIAL-BASIS and keep track of where we 59 ;; are, so that we can produce the pairs in the correct order 60 ;; when we check whether they have been processed, i.e they 61 ;; appear in the hash table B-done 62 (dolist (h partial-basis nil) 63 (cond 64 ((eq h f) 65 #+grobner-check(assert (eq place :before)) 66 (setf place :in-the-middle)) 67 ((eq h g) 68 #+grobner-check(assert (eq place :in-the-middle)) 69 (setf place :after)) 70 ((and (divides-lcm-p (leading-monomial h) 71 (leading-monomial f) 72 (leading-monomial g)) 73 (gethash (case place 74 (:before (list h f)) 75 ((:in-the-middle :after) (list f h))) 76 b-done) 77 (gethash (case place 78 ((:before :in-the-middle) (list h g)) 79 (:after (list g h))) 80 b-done)) 81 (debug-cgb ":2") 82 (return-from criterion-2 t)))))) 80 83
Note:
See TracChangeset
for help on using the changeset viewer.