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.

Changeset 4192 for branches/f4grobner


Ignore:
Timestamp:
2016-06-03T19:32:47-07:00 (9 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/f4grobner/buchberger.lisp

    r4170 r4192  
    4848                    (grobner-test (subseq f 0 start) (subseq f 0 start)))
    4949  ;;Initialize critical pairs
    50   (let ((b (make-critical-pair-queue f start))
     50  (let ((b (make-instance 'critical-pair-queue *normal-strategy* f start))
    5151        (b-done (make-hash-table :test #'equal)))
    52     (declare (type priority-queue b) (type hash-table b-done))
     52    (declare (type critical-pair-queue b) (type hash-table b-done))
    5353    (dotimes (i (1- start))
    5454      (do ((j (1+ i) (1+ j))) ((>= j start))
    5555        (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
    5656    (do ()
    57         ((pair-queue-empty-p b)
    58          #+grobner-check(grobner-test ring-and-order f f)
     57        ((queue-empty-p b)
     58         #+grobner-check(grobner-test f f)
    5959         (debug-cgb "~&GROBNER END")
    6060         f)
    61       (let ((pair (pair-queue-remove b)))
    62         (declare (type pair pair))
     61      (let ((pair (dequeue b)))
     62        (declare (type critical-pair pair))
    6363        (cond
    6464          ((criterion-1 pair) nil)
    6565          ((criterion-2 pair b-done f) nil)
    6666          (t
    67            (let ((sp (normal-form ring-and-order
    68                                   (spoly ring-and-order
    69                                          (pair-first pair)
    70                                          (pair-second pair))
     67           (let ((sp (normal-form (s-polynomial
     68                                   (critical-pair-first pair)
     69                                   (critical-pair-second pair))
    7170                                  f top-reduction-only)))
    7271             (declare (type poly sp))
    7372             (cond
    74                ((poly-zerop sp)
     73               ((universal-zerop sp)
    7574                nil)
    7675               (t
    … …  
    7978                ;; Add new critical pairs
    8079                (dolist (h f)
    81                   (pair-queue-insert b (make-pair h sp)))
    82                 (debug-cgb "~&Sugar: ~d Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
    83                            (pair-sugar pair) (length f) (pair-queue-size b)
     80                  (enqueue b (make-instance 'critical-pair h sp)))
     81                (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
     82                           (length f) (queue-size b)
    8483                           (hash-table-count b-done)))))))
    85         (setf (gethash (list (pair-first pair) (pair-second pair)) b-done)
     84        (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair)) b-done)
    8685              t)))))
    8786
    … …  
    103102                     (grobner-test (subseq f 0 start) (subseq f 0 start)))
    104103  ;;Initialize critical pairs
    105   (let ((b (pair-queue-initialize (make-pair-queue) f start))
    106         (b-done (make-hash-table :test #'equal)))
     104  (let ((b (make-instance 'critical-pair-queue *normal-strategy* f start))
     105        (b-done (make-hash-table :test #'equal))
     106        (coeff-zero (make-zero-for (leading-coefficient (car f))))
     107        (coeff-unit (make-unit-for (leading-coefficient (car f)))))
    107108    (declare (type priority-queue b)
    108109             (type hash-table b-done))
    … …  
    112113        (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
    113114    (do ()
    114         ((pair-queue-empty-p b)
     115        ((queue-empty-p b)
    115116         #+grobner-check(grobner-test f f)
    116117         (debug-cgb "~&GROBNER END")
    117118         f)
    118       (let ((pair (pair-queue-remove b)))
    119         (when (null (pair-division-data pair))
    120           (setf (pair-division-data pair) (list (s-polynomial
    121                                                        (pair-first pair)
    122                                                        (pair-second pair))
    123                                                 (make-poly-zero)
    124                                                 (funcall (ring-unit ring))
    125                                                 0)))
     119      (let ((pair (dequeue b)))
     120        (when (null (critical-pair-data pair))
     121          (setf (critical-pair-data pair) (list (s-polynomial
     122                                                          (critical-pair-first pair)
     123                                                          (critical-pair-second pair))
     124                                                         coeff-zero
     125                                                         coeff-unit
     126                                                         0)))
    126127        (cond
    127128          ((criterion-1 pair) nil)
    128129          ((criterion-2 pair b-done f) nil)
    129130          (t
    130            (let* ((dd (pair-division-data pair))
     131           (let* ((dd (critical-pair-data pair))
    131132                  (p (first dd))
    132133                  (sp (second dd))
    … …  
    134135                  (division-count (fourth dd)))
    135136             (cond
    136                ((poly-zerop p)          ;normal form completed
     137               ((universal-zerop p)     ;normal form completed
    137138                (debug-cgb "~&~3T~d reduction~:p" division-count)
    138139                (cond
    139                   ((poly-zerop sp)
     140                  ((universal-zerop sp)
    140141                   (debug-cgb " ---> 0")
    141142                   nil)
    142143                  (t
    143                    (setf sp (poly-nreverse sp)
    144                          sp (poly-primitive-part ring sp)
     144                   (setf sp (poly-primitive-part sp)
    145145                         f (nconc f (list sp)))
    146146                   ;; Add new critical pairs
    147147                   (dolist (h f)
    148                      (pair-queue-insert b (make-pair h sp)))
    149                    (debug-cgb "~&Sugar: ~d Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
    150                               (pair-sugar pair) (length f) (pair-queue-size b)
     148                     (enqueue b (make-instance 'critical-pair h sp)))
     149                   (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
     150                              (length f) (queue-size b)
    151151                              (hash-table-count b-done))))
    152                 (setf (gethash (list (pair-first pair) (pair-second pair))
     152                (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair))
    153153                               b-done) t))
    154154               (t                               ;normal form not complete
    155155                (do ()
    156156                    ((cond
    157                        ((> (poly-sugar sp) (pair-sugar pair))
    158                         (debug-cgb "(~a)?" (poly-sugar sp))
    159                         t)
    160                        ((poly-zerop p)
     157                       ((universal-zerop p)
    161158                        (debug-cgb ".")
    162159                        t)
    … …  
    165162                           (second dd) sp
    166163                           (third dd) c
    167                            (fourth dd) division-count
    168                            (pair-sugar pair) (poly-sugar sp))
    169                      (pair-queue-insert b pair))
     164                           (fourth dd) division-count)
     165                     (enqueue b pair))
    170166                  (multiple-value-setq (p sp c division-count)
    171                     (normal-form-step ring-and-order f p sp c division-count))))))))))))
     167                    (normal-form-step f p sp c division-count))))))))))))
Note: See TracChangeset for help on using the changeset viewer.