Changeset 4173 for branches

Timestamp:

2016-06-03T09:57:35-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/criterion.lisp (modified) (1 diff)

branches/f4grobner/criterion.lisp

@@ -32 +32 @@
 (proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
 
-(defun criterion-1 (pair)
-  "Returns T if the leading monomials of the two polynomials
-in G pointed to by the integers in PAIR have disjoint (relatively prime)
-monomials. This test is known as the first Buchberger criterion."
-  (declare (type critical-pair pair))
-  (let ((f (critical-pair-first pair))
-        (g (critical-pair-second pair)))
-    (when (rel-prime-p (leading-monomial f) (leading-monomial g))
-      (debug-cgb ":1")
-      (return-from criterion-1 t))))
+(defgeneric criterion-1 (pair)
+  (:documentation "Returns T if the leading monomials of the two
+polynomials in G pointed to by the integers in PAIR have
+disjoint (relatively prime) monomials. This test is known as the first
+Buchberger criterion.")
+  (:method ((pair critical-pair))
+    (let ((f (critical-pair-first pair))
+          (g (critical-pair-second pair)))
+      (when (rel-prime-p (leading-monomial f) (leading-monomial g))
+        (debug-cgb ":1")
+        (return-from criterion-1 t)))))
 
-(defun criterion-2 (pair b-done partial-basis
-                    &aux (f (critical-pair-first pair)) (g (critical-pair-second pair))
-                         (place :before))
-  "Returns T if the leading monomial of some element P of
-PARTIAL-BASIS divides the LCM of the leading monomials of the two
+(defgeneric criterion-2 (pair b-done partial-basis)
+  (:documentation "Returns T if the leading monomial of some element P
+of PARTIAL-BASIS divides the LCM of the leading monomials of the two
 polynomials in the polynomial list PARTIAL-BASIS, and P paired with
 each of the polynomials pointed to by the the PAIR has already been
-treated, as indicated by the absence in the hash table B-done."
-  (declare (type critical-pair pair) (type hash-table b-done)
-           (type poly f g))
-  ;; In the code below we assume that pairs are ordered as follows: 
-  ;; if PAIR is (I J) then I appears before J in the PARTIAL-BASIS.
-  ;; We traverse the list PARTIAL-BASIS and keep track of where we
-  ;; are, so that we can produce the pairs in the correct order
-  ;; when we check whether they have been processed, i.e they
-  ;; appear in the hash table B-done
-  (dolist (h partial-basis nil)
-    (cond
-     ((eq h f)
-      #+grobner-check(assert (eq place :before))
-      (setf place :in-the-middle))
-     ((eq h g)
-      #+grobner-check(assert (eq place :in-the-middle))
-      (setf place :after))
-     ((and (divides-lcm-p (leading-monomial h) (leading-monomial f) (leading-monomial g))
-           (gethash (case place
-                      (:before (list h f))
-                      ((:in-the-middle :after) (list f h)))
-                    b-done)
-           (gethash (case place
-                      ((:before :in-the-middle) (list h g))
-                      (:after (list g h)))
-                    b-done))
-      (debug-cgb ":2")
-      (return-from criterion-2 t)))))
+treated, as indicated by the absence in the hash table B-done.")
+  (:method ((pair critical-pair) (b-done hash-table) partial-basis
+            &aux (f (critical-pair-first pair)) (g (critical-pair-second pair))
+              (place :before))
+    (declare (type poly f g))
+    ;; In the code below we assume that pairs are ordered as follows: 
+    ;; if PAIR is (I J) then I appears before J in the PARTIAL-BASIS.
+    ;; We traverse the list PARTIAL-BASIS and keep track of where we
+    ;; are, so that we can produce the pairs in the correct order
+    ;; when we check whether they have been processed, i.e they
+    ;; appear in the hash table B-done
+    (dolist (h partial-basis nil)
+      (cond
+        ((eq h f)
+         #+grobner-check(assert (eq place :before))
+         (setf place :in-the-middle))
+        ((eq h g)
+         #+grobner-check(assert (eq place :in-the-middle))
+         (setf place :after))
+        ((and (divides-lcm-p (leading-monomial h) 
+                             (leading-monomial f)
+                             (leading-monomial g))
+              (gethash (case place
+                         (:before (list h f))
+                         ((:in-the-middle :after) (list f h)))
+                       b-done)
+              (gethash (case place
+                         ((:before :in-the-middle) (list h g))
+                         (:after (list g h)))
+                       b-done))
+         (debug-cgb ":2")
+         (return-from criterion-2 t))))))