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 103 for branches/f4grobner


Ignore:
Timestamp:
2015-06-05T12:01:13-07:00 (10 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/f4grobner/mx-grobner.lisp

    r102 r103  
    3232;;FUNCTS is loaded because it contains the definition of LCM
    3333($load "functs")
    34 
    35 
    36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    37 ;;
    38 ;; Debugging/tracing
    39 ;;
    40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    41 (defmacro debug-cgb (&rest args)
    42   `(when $poly_grobner_debug (format *terminal-io* ,@args)))
    43 
    44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    45 ;;
    46 ;; Selection of algorithm and pair heuristic
    47 ;;
    48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    49 
    50 (defun find-grobner-function (algorithm)
    51   "Return a function which calculates Grobner basis, based on its
    52 names. Names currently used are either Lisp symbols, Maxima symbols or
    53 keywords."
    54   (ecase algorithm
    55     ((buchberger :buchberger $buchberger) #'buchberger)
    56     ((parallel-buchberger :parallel-buchberger $parallel_buchberger) #'parallel-buchberger)
    57     ((gebauer-moeller :gebauer_moeller $gebauer_moeller) #'gebauer-moeller)))
    58 
    59 (defun grobner (ring f &optional (start 0) (top-reduction-only nil))
    60   ;;(setf F (sort F #'< :key #'sugar))
    61   (funcall
    62    (find-grobner-function $poly_grobner_algorithm)
    63    ring f start top-reduction-only))
    64 
    65 (defun reduced-grobner (ring f &optional (start 0) (top-reduction-only $poly_top_reduction_only))
    66   (reduction ring (grobner ring f start top-reduction-only)))
    67 
    68 (defun set-pair-heuristic (method)
    69   "Sets up variables *PAIR-KEY-FUNCTION* and *PAIR-ORDER* used
    70 to determine the priority of critical pairs in the priority queue."
    71   (ecase method
    72     ((sugar :sugar $sugar)
    73      (setf *pair-key-function* #'sugar-pair-key
    74            *pair-order* #'sugar-order))
    75 ;     ((minimal-mock-spoly :minimal-mock-spoly $minimal_mock_spoly)
    76 ;      (setf *pair-key-function* #'mock-spoly
    77 ;          *pair-order* #'mock-spoly-order))
    78     ((minimal-lcm :minimal-lcm $minimal_lcm)
    79      (setf *pair-key-function* #'(lambda (p q)
    80                                    (monom-lcm (poly-lm p) (poly-lm q)))
    81            *pair-order* #'reverse-monomial-order))
    82     ((minimal-total-degree :minimal-total-degree $minimal_total_degree)
    83      (setf *pair-key-function* #'(lambda (p q)
    84                                    (monom-total-degree
    85                                     (monom-lcm (poly-lm p) (poly-lm q))))
    86            *pair-order* #'<))
    87     ((minimal-length :minimal-length $minimal_length)
    88      (setf *pair-key-function* #'(lambda (p q)
    89                                    (+ (poly-length p) (poly-length q)))
    90            *pair-order* #'<))))
    91 
    92 
    93 
    94 
    95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    96 ;;
    97 ;; Set up the coefficients to be polynomials
    98 ;;
    99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    100 
    101 ;; (defun poly-ring (ring vars)
    102 ;;   (make-ring
    103 ;;    :parse #'(lambda (expr) (poly-eval ring expr vars))
    104 ;;    :unit #'(lambda () (poly-unit ring (length vars)))
    105 ;;    :zerop #'poly-zerop
    106 ;;    :add #'(lambda (x y) (poly-add ring x y))
    107 ;;    :sub #'(lambda (x y) (poly-sub ring x y))
    108 ;;    :uminus #'(lambda (x) (poly-uminus ring x))
    109 ;;    :mul #'(lambda (x y) (poly-mul ring x y))
    110 ;;    :div #'(lambda (x y) (poly-exact-divide ring x y))
    111 ;;    :lcm #'(lambda (x y) (poly-lcm ring x y))
    112 ;;    :ezgcd #'(lambda (x y &aux (gcd (poly-gcd ring x y)))
    113 ;;            (values gcd
    114 ;;                    (poly-exact-divide ring x gcd)
    115 ;;                    (poly-exact-divide ring y gcd)))
    116 ;;    :gcd #'(lambda (x y) (poly-gcd x y))))
    117 
    118 
    119 
    120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    121 ;;
    122 ;; Conversion from internal to infix form
    123 ;;
    124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    125 
    126 (defun coerce-to-infix (poly-type object vars)
    127   (case poly-type
    128     (:termlist
    129      `(+ ,@(mapcar #'(lambda (term) (coerce-to-infix :term term vars)) object)))
    130     (:polynomial
    131      (coerce-to-infix :termlist (poly-termlist object) vars))
    132     (:poly-list
    133      `([ ,@(mapcar #'(lambda (p) (coerce-to-infix :polynomial p vars)) object)))
    134     (:term
    135      `(* ,(term-coeff object)
    136          ,@(mapcar #'(lambda (var power) `(expt ,var ,power))
    137                    vars (monom-exponents (term-monom object)))))
    138     (otherwise
    139      object)))
    140 
    14134
    14235
Note: See TracChangeset for help on using the changeset viewer.