Changeset 4441
- Timestamp:
- 2016-06-10T19:07:59-07:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/f4grobner/fast-add.lisp
r4434 r4441 1 (in-package :polynomial)1 (in-package "POLYNOMIAL") 2 2 3 ;; Getter/setter of leading coefficient 4 (defun lc (x) (term-coeff (car x))) 5 (defun (setf lc) (new-value x) (setf (term-coeff (car x)) new-value)) 6 7 (defun fast-add (p q order-fn add-fn) 8 (cond 9 ((endp p) p) 10 ((endp q) q) 11 (t 12 (multiple-value-bind 13 (greater-p equal-p) 14 (funcall order-fn (car p) (car q)) 3 (defun fast-add (p q order-fn add-fn &aux result result-last) 4 (flet ((add-to-result (x) 5 (assert (consp x)) 6 (setf (cdr x) nil) 7 (if (endp result) 8 (setf result x 9 result-last x) 10 (setf (cdr result-last) x 11 result-last (cdr result-last))))) 12 (loop 15 13 (cond 16 (greater-p ; (> (cadr h) (car q)) 17 (cons (car p) (fast-add (cdr p) q order-fn add-fn)) 18 ) 19 (equal-p ; (= (cadr h)) (car q)) 20 (let ((s (funcall add-fn (lc p) (lc q)))) 21 (cond 22 ((universal-zerop s) 23 (fast-add (cdr p) (cdr q) order-fn add-fn)) 24 (t 25 ;; Adjust the lc of p 26 (setf (lc p) s) 27 (cons (car p) (fast-add (cdr p) (cdr q) order-fn add-fn)) 28 )))) 29 (t ;(< (cadr h) (car q)) 30 (cons (car q) (fast-add p (cdr q) order-fn add-fn)) 31 )))))) 32 33 34 35 36 37 38 39 14 ((endp p) (unless (endp q) (add-to-result q)) (return result)) 15 ((endp q) (unless (endp p) (add-to-result p)) (return result)) 16 (t 17 (multiple-value-bind 18 (greater-p equal-p) 19 (funcall order-fn (car p) (car q)) 20 (cond 21 (greater-p ; (> (car p) (car q)) 22 (let ((tmp (cdr p))) 23 (add-to-result p) 24 (setf p tmp))) 25 (equal-p ; (= (car p)) (car q)) 26 (let ((s (funcall add-fn (lc p) (lc q)))) 27 (cond 28 ((universal-zerop s) 29 ;; Terms cancel, discard both 30 (setf p (cdr p) 31 q (cdr q))) 32 (t 33 ;; Terms do not cancel, store the 34 ;; sum of coefficients in (lc p) 35 (setf (lc p) s) 36 (let ((tmp (cdr p))) 37 (add-to-result p) 38 (setf p tmp 39 q (cdr q))))))) 40 (t ;(< (car p) (car q)) 41 (let ((tmp (cdr q))) 42 (add-to-result q) 43 (setf q tmp)) 44 ))))))))
Note:
See TracChangeset
for help on using the changeset viewer.