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.

Ignore:
Timestamp:
2016-06-10T09:50:24-07:00 (8 years ago)
Author:
Marek Rychlik
Message:
 
File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/f4grobner/fast-add.lisp

    r4431 r4434  
    1 (load "boot")
    2 
    3 (use-package :polynomial)
    4 (use-package :monom)
    5 
    6 ;;(shadow '(fast-add) "POLYNOMIAL")
     1(in-package :polynomial)
    72
    83;; Getter/setter of leading coefficient
    … …  
    105(defun (setf lc) (new-value x) (setf (term-coeff (car x)) new-value))
    116
    12 (defvar order-fn #'lex>)
    13 (defvar add-fn #'add-to)
     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))
     15       (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          ))))))
    1432
    15 (defun fast-add-helper (p q)
    16   (do ((h p))
    17       ((endp q) p)
    18     (multiple-value-bind
    19           (greater-p equal-p)
    20         (funcall order-fn (car h) (car q))
    21       (cond
    22         (greater-p                      ; (> (lm h) (lm q))
    23          (setf h (cdr h))
    24          )
    25         (equal-p                        ; (= (lm h) (lm q))
    26          (let ((s (funcall add-fn (lc h) (lc q))))
    27            (cond
    28              ((universal-zerop s)
    29               (cond
    30                 (setf h (cdr h)
    31                       q (cdr q))))
    32              (t
    33               ;; Adjust the lc of p
    34               (setf (lc h) s)
    35               (setf h (cdr h)
    36                        q (cdr q))))))
    3733
    38         (t                       ;(< (lm h) (lm q))                     
    39          
     34
    4035
    4136
Note: See TracChangeset for help on using the changeset viewer.