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.

source: branches/f4grobner/fast-add.lisp@ 4449

Last change on this file since 4449 was 4447, checked in by Marek Rychlik, 9 years ago
File size: 1.7 KB
Line 
1(in-package "POLYNOMIAL")
2
3(defun fast-and-risky-add (p q order-fn add-fn &aux result result-last)
4 (when (and p q (eq p q)) (warn "FAST-AND-RISKY-ADD: ~S is EQ to ~S" p q))
5 (flet ((add-to-result (x)
6 (assert (consp x))
7 (setf (cdr x) nil)
8 (if (endp result)
9 (setf result x
10 result-last x)
11 (setf (cdr result-last) x
12 result-last (cdr result-last)))))
13 (loop
14 (cond
15 ((endp p) (unless (endp q) (add-to-result q)) (return result))
16 ((endp q) (unless (endp p) (add-to-result p)) (return result))
17 (t
18 (multiple-value-bind
19 (greater-p equal-p)
20 (funcall order-fn (car p) (car q))
21 (cond
22 (greater-p ; (> (car p) (car q))
23 (let ((tmp (cdr p)))
24 (add-to-result p)
25 (setf p tmp)))
26 (equal-p ; (= (car p)) (car q))
27 (let ((s (funcall add-fn (lc p) (lc q))))
28 (cond
29 ((universal-zerop s)
30 ;; Terms cancel, discard both
31 (setf p (cdr p)
32 q (cdr q)))
33 (t
34 ;; Terms do not cancel, store the
35 ;; sum of coefficients in (lc p)
36 (setf (lc p) s)
37 (let ((tmp (cdr p)))
38 (add-to-result p)
39 (setf p tmp
40 q (cdr q)))))))
41 (t ;(< (car p) (car q))
42 (let ((tmp (cdr q)))
43 (add-to-result q)
44 (setf q tmp))
45 ))))))))
46
47(defun fast-add (p q order-fn add-fn)
48 (let ((r1 (slow-add p q order-fn add-fn))
49 (r2 (fast-and-risky-add p q order-fn add-fn)))
50 (unless (every #'universal-equalp r1 r2)
51 (format t "~&Error in addition of ~%~A~% and~%~A~% should be:~%" (mapcar #'->list p) (mapcar #'->list q))
52 (princ (mapcar #'->list r1))
53 (format t "~&Actually is:~%")
54 (princ (mapcar #'->list r2))
55 )
56 r2))
57
58
59
Note: See TracBrowser for help on using the repository browser.