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 4434


Ignore:
Timestamp:
2016-06-10T09:50:24-07:00 (8 years ago)
Author:
Marek Rychlik
Message:
 
Location:
branches/f4grobner
Files:
7 edited

Legend:

Unmodified
Added
Removed

  • branches/f4grobner/5am-infix-print.lisp

    r4411 r4434  
    6565  (is (equal (infix-print-to-string '(+ x (- y z))) "X+Y-Z"))
    6666  (is (equal (infix-print-to-string '(+ x (- y))) "X-Y"))
     67  (is (equal (infix-print-to-string '(- x (- y))) "X+Y"))
     68  (is (equal (infix-print-to-string '(- x (- y z))) "X-Y+Z"))
    6769  ;; Distinguich between unary and binary division
    6870  (is (equal (infix-print-to-string '(* x (/ y z))) "X*Y/Z"))
    6971  (is (equal (infix-print-to-string '(* x (/ y))) "X/Y"))
     72  ;; Handling negative numbers
     73  (is (equal (infix-print-to-string '(+ x -1 2 -3)) "X-1+2-3"))
     74  (is (equal (infix-print-to-string '(- x (- y 7))) "X-Y+7"))
     75  )
    7076
    71   )
    7277
    7378(run! 'infix-printer-suite)

  • branches/f4grobner/division.lisp

    r4310 r4434  
    4747  (declare (type monom m)
    4848           (type poly f g))
    49   #+grobner-check(universal-zerop
    50                   (subtract
    51                    (multiply c2 (leading-coefficient f))
    52                    (multiply c1 (leading-coefficient g))))
    53   #+grobner-check(universal-equalp (leading-monomial f) (multiply m (leading-monomial g)))
     49  (assert (universal-zerop
     50           (subtract
     51            (multiply c2 (leading-coefficient f))
     52            (multiply c1 (leading-coefficient g)))))
     53  (assert (universal-equalp (leading-monomial f) (multiply m (leading-monomial g))))
    5454  ;; Note that below we can drop the leading terms of f ang g for the
    5555  ;; purpose of polynomial arithmetic. 

  • 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

  • branches/f4grobner/infix-printer.lisp

    r4423 r4434  
    4444(defun inverse-op (op)
    4545  (ecase op
     46    (+ '-)
    4647    (- '+)
     48    (* '/)
    4749    (/ '*)))
    4850
    … …  
    5355                                     (beg t)
    5456                                     (count 0)
    55                                      true-sep)
     57                                     true-sep
     58                                     more-args)
    5659  "Print a list LST using SEP as separator, to stream STREAM. Every
    5760argument is printed usin OP as main operator. PRINT-LEVEL is used to
    … …  
    8790                 (> count 1)
    8891                 (consp arg)
    89                  (endp (cddr arg))
    9092                 (eq alt-op (car arg)))
    9193        (psetf arg (cadr arg)
    92                true-sep (if (eq op alt-op) (inverse-op op) alt-op)))
    93        
     94               more-args (cddr arg))
     95        (cond ((endp more-args)
     96               (setf true-sep (if (eq op alt-op) (inverse-op op) alt-op)))))
     97
     98
    9499      ;; Unless at the beginning, print the separator
    95100      (cond
    … …  
    106111      (infix-print-to-stream arg stream op print-level)
    107112
     113      ;; Print remaining arguments
     114      (unless (endp more-args)
     115        (let ((x-op (inverse-op op)))
     116          (format stream "~a" x-op)
     117          (infix-print-separated-list more-args x-op stream sep print-level x-op)))
    108118      )))
    109119  (values))

  • branches/f4grobner/ngrobner.asd

    r4369 r4434  
    2222                 (:file "polynomial")
    2323                 (:file "polynomial-eval" :depends-on ("polynomial"))
     24                 ;;(:file "fast-add" :depends-on ("polynomial"))
    2425                 (:file "infix")
    2526                 (:file "infix-printer")

  • branches/f4grobner/polynomial.lisp

    r4432 r4434  
    301301|#
    302302
     303
     304
     305
    303306#|
    304307(defun fast-add (p q order-fn add-fn)
    … …  
    337340          (t
    338341           (rotatef (cdr q) r q)))))))
    339 |#     
    340 
     342|#
    341343
    342344;; Getter/setter of leading coefficient
    … …  
    345347
    346348(defun fast-add (p q order-fn add-fn)
    347   ;; Requirement: (car p) > (car q)
    348   ;; (consp (cdr p))
    349   (do ((h p))
    350       ((endp q) p)
    351     (multiple-value-bind
    352           (greater-p equal-p)
    353         (funcall order-fn (cadr h) (car q))
    354       (cond
    355         (greater-p                      ; (> (cadr h) (car q))
    356          (setf h (cdr h))
    357          )
    358         (equal-p                        ; (= (cadr h)) (car q))
    359          (let ((s (funcall add-fn (lc h) (lc q))))
    360            (cond
    361              ((universal-zerop s)
    362               (setf h (cdr h)
    363                     q (cdr q)))
    364              (t
    365               ;; Adjust the lc of p
    366               (setf (lc h) s
    367                     h (cdr h)
    368                     q (cdr q))))))
    369         (t                       ;(< (cadr h) (car q))                 
    370          (let  ((tmp (cdr q)))
    371            (setf (cdr q) (cdr p)
    372                  (cdr h) q
    373                  q tmp)))))))
     349  (cond
     350    ((endp p) p)
     351    ((endp q) q)
     352    (t
     353     (multiple-value-bind
     354           (greater-p equal-p)
     355         (funcall order-fn (car p) (car q))
     356       (cond
     357         (greater-p                     ; (> (cadr h) (car q))
     358          (cons (car p) (fast-add (cdr p) q order-fn add-fn))
     359          )
     360         (equal-p                       ; (= (cadr h)) (car q))
     361          (let ((s (funcall add-fn (lc p) (lc q))))
     362            (cond
     363              ((universal-zerop s)
     364               (fast-add (cdr p) (cdr q) order-fn add-fn))
     365              (t
     366               ;; Adjust the lc of p
     367               (setf (lc p) s)
     368               (cons (car p) (fast-add (cdr p) (cdr q) order-fn add-fn))
     369               ))))
     370         (t                    ;(< (cadr h) (car q))                   
     371          (cons (car q) (fast-add p (cdr q) order-fn add-fn))
     372          ))))))
    374373
    375374

  • branches/f4grobner/test5.lisp

    r4401 r4434  
    1212
    1313(format t "~%")
    14 (format t "FL --> ~A~%" (poly->string (cons :[ fl)))
    15 (format t "REF-GB --> ~A~%" (poly->string (cons :[ ref-gb)))
     14(format t "FL --> ~A~2%" (poly->string (cons :[ fl)))
     15(format t "REF-GB --> ~A~2%" (poly->string (cons :[ ref-gb)))
    1616
    1717(loop for i from 0 below (length fl)
    … …  
    2020          do
    2121          (setf sp (s-polynomial (elt fl i) (elt fl j)))
    22           (format t "SPOLY(~A,~A) --> ~A~%"
     22          (format t "SPOLY(~A,~A) --> ~A~2%"
    2323                  (poly->string (elt fl i))
    2424                  (poly->string (elt fl j))
    2525                  (poly->string sp))
    2626          (setf sp-rem (normal-form sp fl))
    27           (format t "NORMAL-FORM(~A,~A) --> ~A~%"
     27          (format t "NORMAL-FORM(~A,~A) --> ~A~2%"
    2828                  (poly->string sp)
    2929                  (poly->string (cons :[ fl))
Note: See TracChangeset for help on using the changeset viewer.