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 4205 for branches


Ignore:
Timestamp:
2016-06-04T11:30:39-07:00 (8 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/buchberger.lisp

    r4194 r4205  
    8484        (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair)) b-done)
    8585              t)))))
    86 
    87 (defun parallel-buchberger (f
    88                             &optional
    89                               (start 0)
    90                               (top-reduction-only $poly_top_reduction_only))
    91   "An implementation of the Buchberger algorithm. Return Grobner basis
    92 of the ideal generated by the polynomial list F.  Polynomials 0 to
    93 START-1 are assumed to be a Grobner basis already, so that certain
    94 critical pairs will not be examined. If TOP-REDUCTION-ONLY set, top
    95 reduction will be preformed."
    96   (declare (ignore top-reduction-only)
    97            (type fixnum start))
    98   (when (endp f) (return-from parallel-buchberger f)) ;cut startup costs
    99   (debug-cgb "~&GROBNER BASIS - PARALLEL-BUCHBERGER ALGORITHM")
    100   (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
    101   #+grobner-check  (when (plusp start)
    102                      (grobner-test (subseq f 0 start) (subseq f 0 start)))
    103   ;;Initialize critical pairs
    104   (let ((b (make-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)))))
    108     (declare (type priority-queue b)
    109              (type hash-table b-done))
    110     (dotimes (i (1- start))
    111       (do ((j (1+ i) (1+ j))) ((>= j start))
    112         (declare (type fixnum j))
    113         (setf (gethash (list (elt f i) (elt f j)) b-done) t)))
    114     (do ()
    115         ((queue-empty-p b)
    116          #+grobner-check(grobner-test f f)
    117          (debug-cgb "~&GROBNER END")
    118          f)
    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)))
    127         (cond
    128           ((criterion-1 pair) nil)
    129           ((criterion-2 pair b-done f) nil)
    130           (t
    131            (let* ((dd (critical-pair-data pair))
    132                   (p (first dd))
    133                   (sp (second dd))
    134                   (c (third dd))
    135                   (division-count (fourth dd)))
    136              (cond
    137                ((universal-zerop p)     ;normal form completed
    138                 (debug-cgb "~&~3T~d reduction~:p" division-count)
    139                 (cond
    140                   ((universal-zerop sp)
    141                    (debug-cgb " ---> 0")
    142                    nil)
    143                   (t
    144                    (setf sp (poly-primitive-part sp)
    145                          f (nconc f (list sp)))
    146                    ;; Add new critical pairs
    147                    (dolist (h f)
    148                      (enqueue b (make-instance 'critical-pair :first h :second sp)))
    149                    (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Pairs done: ~d;"
    150                               (length f) (queue-size b)
    151                               (hash-table-count b-done))))
    152                 (setf (gethash (list (critical-pair-first pair) (critical-pair-second pair))
    153                                b-done) t))
    154                (t                               ;normal form not complete
    155                 (do ()
    156                     ((cond
    157                        ((universal-zerop p)
    158                         (debug-cgb ".")
    159                         t)
    160                        (t nil))
    161                      (setf (first dd) p
    162                            (second dd) sp
    163                            (third dd) c
    164                            (fourth dd) division-count)
    165                      (enqueue b pair))
    166                   (multiple-value-setq (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.