Changeset 4312 for branches/f4grobner

Timestamp:

2016-06-04T22:56:30-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

Added ring classes

Location:

branches/f4grobner

Files:

• 5am-buchberger.lisp (modified) (2 diffs)
• 5am-criterion.lisp (modified) (1 diff)
• 5am-division.lisp (modified) (4 diffs)
• copy.lisp (modified) (1 diff)
• criterion.lisp (modified) (3 diffs)
• integer-ring.lisp (modified) (1 diff)
• pair-queue.lisp (modified) (2 diffs)

branches/f4grobner/5am-buchberger.lisp

@@ -78 +78 @@
     (is-true (grobner-test gb fl))
     (is (every #'universal-equalp (buchberger fl) gb))
-    (is (every #'universal-equalp (parallel-buchberger fl) gb))
+    ;;(is (every #'universal-equalp (parallel-buchberger fl) gb))
     )
   )
@@ -121 +121 @@
   (with-fixture buchberger-advanced-context ()
     (is-true (grobner-test gb fl))
-    ;;(is (every #'universal-equalp (buchberger fl) gb))
+    (is (every #'universal-equalp (buchberger fl) gb))
     ;;(is (every #'universal-equalp (parallel-buchberger fl) gb))
     ))

branches/f4grobner/5am-criterion.lisp

@@ -103 +103 @@
          (pair (make-instance 'critical-pair :first f :second g))
          (b-done (make-hash-table :test #'equal))
-         (partial-basis (list h)))
+         (partial-basis (list f g h)))
     ;; Initialize the lookup table of done pairs
-    (setf (gethash (list h f) b-done) t
-          (gethash (list h g) b-done) t)
+    (setf ;;(gethash (list h f) b-done) t
+          (gethash (list f h) b-done) t
+          ;;(gethash (list h g) b-done) t
+          (gethash (list g h) b-done) t
+          )
     (&body)))
 

branches/f4grobner/5am-division.lisp

@@ -44 +44 @@
   (require :utils "utils")
   (require :copy "copy")
+  (require :ring "ring")
+  (require :integer-ring "integer-ring")
   (require :monom "monom")
   (require :polynomial "polynomial")
@@ -51 +53 @@
 
 (defpackage #:5am-division
-  (:use :cl :it.bese.fiveam :monom :polynomial :infix :symbolic-polynomial :division))
+  (:use :cl :it.bese.fiveam :monom :polynomial :infix :symbolic-polynomial :division :integer-ring))
 
 (in-package :5am-division)
@@ -73 +75 @@
          (y-sq (string->poly "y^2" '(x y)))
          (fl (cdr (string->poly "[x+y,x-2*y]" '(x y))))
-         (quotients (cdr (string->poly "[x-y,0]" '(x y)))))
+         (quotients (cdr (string->poly "[x-y,0]" '(x y))))
+         (one (make-instance 'integer-ring :value 1)))
     (&body)))
 
@@ -79 +82 @@
   "Normal form"
   (with-fixture division-context ()
-    (is (universal-equalp (multiple-value-list (normal-form f fl)) (list y-sq 1 2)))
-    (is (universal-equalp (multiple-value-list (poly-pseudo-divide f fl))
-                          (list quotients y-sq 1 2)))
-    (is-false (buchberger-criterion fl))))
+    (is (universal-equalp (multiple-value-list (normal-form f fl)) (list y-sq one 2)))
+    (is (universal-equalp (multiple-value-list (poly-pseudo-divide f fl)) (list quotients y-sq one 2)))
+    (is-false (buchberger-criterion fl))
+    )
+  )
 
 (test normal-form-easy

branches/f4grobner/copy.lisp

@@ -38 +38 @@
 ;; NOTE: This is a shallow copy. Add an around method for classes which need deep copy of the slots.
 (defgeneric copy-instance (object &rest initargs &key &allow-other-keys)
-  (:method ((object number) &rest initargs &key &allow-other-keys) 
-    (declare (ignore initargs))
-    object)
-  (:method ((object cons) &rest initargs &key &allow-other-keys) 
-    (declare (ignore initargs))
-    (copy-seq object))
   (:documentation "Makes and returns a shallow copy of OBJECT.
-
   An uninitialized object of the same class as OBJECT is allocated by
   calling ALLOCATE-INSTANCE.  For all slots returned by

branches/f4grobner/criterion.lisp

@@ -30 +30 @@
 (in-package :criterion)
 
-(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
+;;(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
 
 (defgeneric criterion-1 (pair)
@@ -61 +61 @@
     ;; appear in the hash table B-done
     (dolist (h partial-basis nil)
-      (format t "Considering H:~S~%" h)
       (cond
         ((eq h f)
@@ -79 +78 @@
                          ((:before :in-the-middle) (list h g))
                          (:after (list g h)))
-                       b-done))
+                       b-done)
+              )
          (debug-cgb ":2")
          (return-from criterion-2 t))))))

branches/f4grobner/integer-ring.lisp

@@ -57 +57 @@
       (1 self)
       (-1 self)
-      (otherwise 
+      (t
        (unary-inverse (change-class self 'rational-field))))))
 

branches/f4grobner/pair-queue.lisp

@@ -25 +25 @@
            "CRITICAL-PAIR-FIRST"
            "CRITICAL-PAIR-SECOND"
+           "CRITICAL-PAIR-DATA"
            "CRITICAL-PAIR-QUEUE"
            "SELECTION-STRATEGY"
@@ -42 +43 @@
   ((first :initform nil  :initarg :first :accessor critical-pair-first :type poly)
    (second :initform nil :initarg :second :accessor critical-pair-second :type poly)
-   (data :initform nil :accessor critical-pair-division-data))
+   (data :initform nil :accessor critical-pair-data))
   (:documentation "Represents a critical pair, i.e. a pair of two
 polynomials. The derived classes may add extra data used in computing