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/ngrobner.lisp@ 501

Last change on this file since 501 was 467, checked in by Marek Rychlik, 9 years ago

* empty log message *

File size: 7.5 KB
Line 
1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*-
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;;
4;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
5;;;
6;;; This program is free software; you can redistribute it and/or modify
7;;; it under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 2 of the License, or
9;;; (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
19;;;
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21
22(in-package :ngrobner)
23
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25;;
26;; Global switches
27;;
28;; Can be used in Maxima just fine, as they observe the
29;; Maxima naming convention, i.e. all names visible at the
30;; Maxima toplevel begin with a '$'.
31;;
32;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33
34(defvar $poly_monomial_order '$lex
35 "This switch controls which monomial order is used in polynomial
36and Grobner basis calculations. If not set, LEX will be used")
37
38(defvar $poly_coefficient_ring '$expression_ring
39 "This switch indicates the coefficient ring of the polynomials
40that will be used in grobner calculations. If not set, Maxima's
41general expression ring will be used. This variable may be set
42to RING_OF_INTEGERS if desired.")
43
44(defvar $poly_primary_elimination_order nil
45 "Name of the default order for eliminated variables in elimination-based functions.
46If not set, LEX will be used.")
47
48(defvar $poly_secondary_elimination_order nil
49 "Name of the default order for kept variables in elimination-based functions.
50If not set, LEX will be used.")
51
52(defvar $poly_elimination_order nil
53 "Name of the default elimination order used in elimination calculations.
54If set, it overrides the settings in variables POLY_PRIMARY_ELIMINATION_ORDER
55and SECONDARY_ELIMINATION_ORDER. The user must ensure that this is a true
56elimination order valid for the number of eliminated variables.")
57
58(defvar $poly_return_term_list nil
59 "If set to T, all functions in this package will return each polynomial as a
60list of terms in the current monomial order rather than a Maxima general expression.")
61
62(defvar $poly_grobner_algorithm '$buchberger
63 "The name of the algorithm used to find grobner bases.")
64
65(defvar $poly_top_reduction_only nil
66 "If not FALSE, use top reduction only whenever possible.
67Top reduction means that division algorithm stops after the first reduction.")
68
69
70(defvar *ratdisrep-fun* #'identity
71 "A function applied to polynomials after conversion to Maxima representation.")
72
73
74
75;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
76;;
77;; This is how we perform operations on coefficients
78;; using Maxima functions.
79;;
80;; Functions and macros dealing with internal representation structure
81;;
82;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
83
84
85
86;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
87;;
88;; These are provided mostly for debugging purposes To enable
89;; verification of grobner bases with BUCHBERGER-CRITERION, do
90;; (pushnew :grobner-check *features*) and compile/load this file.
91;; With this feature, the calculations will slow down CONSIDERABLY.
92;;
93;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94
95(defun grobner-test (ring g f)
96 "Test whether G is a Grobner basis and F is contained in G. Return T
97upon success and NIL otherwise."
98 (debug-cgb "~&GROBNER CHECK: ")
99 (let (($poly_grobner_debug nil)
100 (stat1 (buchberger-criterion ring g))
101 (stat2
102 (every #'poly-zerop
103 (makelist (normal-form ring (copy-tree (elt f i)) g nil)
104 (i 0 (1- (length f)))))))
105 (unless stat1 (error "~&Buchberger criterion failed."))
106 (unless stat2
107 (error "~&Original polys not in ideal spanned by Grobner.")))
108 (debug-cgb "~&GROBNER CHECK END")
109 t)
110
111
112;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
113;;
114;; Selection of algorithm and pair heuristic
115;;
116;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
117
118(defun find-grobner-function (algorithm)
119 "Return a function which calculates Grobner basis, based on its
120names. Names currently used are either Lisp symbols, Maxima symbols or
121keywords."
122 (ecase algorithm
123 ((buchberger :buchberger $buchberger) #'buchberger)
124 ((parallel-buchberger :parallel-buchberger $parallel_buchberger) #'parallel-buchberger)
125 ((gebauer-moeller :gebauer_moeller $gebauer_moeller) #'gebauer-moeller)))
126
127(defun grobner (ring f &optional (start 0) (top-reduction-only nil))
128 ;;(setf F (sort F #'< :key #'sugar))
129 (funcall
130 (find-grobner-function $poly_grobner_algorithm)
131 ring f start top-reduction-only))
132
133(defun reduced-grobner (ring f &optional (start 0) (top-reduction-only $poly_top_reduction_only))
134 (reduction ring (grobner ring f start top-reduction-only)))
135
136;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
137;;
138;; Conversion from internal to infix form
139;;
140;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
141
142(defun coerce-to-infix (poly-type object vars)
143 (case poly-type
144 (:termlist
145 `(+ ,@(mapcar #'(lambda (term) (coerce-to-infix :term term vars)) object)))
146 (:polynomial
147 (coerce-to-infix :termlist (poly-termlist object) vars))
148 (:poly-list
149 `([ ,@(mapcar #'(lambda (p) (coerce-to-infix :polynomial p vars)) object)))
150 (:term
151 `(* ,(term-coeff object)
152 ,@(mapcar #'(lambda (var power) `(expt ,var ,power))
153 vars (monom-exponents (term-monom object)))))
154 (otherwise
155 object)))
156
157
158;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159;;
160;; Order utilities
161;;
162;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
163
164(defun find-order (order)
165 "This function returns the order function bases on its name."
166 (cond
167 ((null order) nil)
168 ((symbolp order)
169 (case order
170 ((lex :lex $lex) #'lex>)
171 ((grlex :grlex $grlex) #'grlex>)
172 ((grevlex :grevlex $grevlex) #'grevlex>)
173 ((invlex :invlex $invlex) #'invlex>)
174 ((elimination-order-1 :elimination-order-1 elimination_order_1) #'elimination-order-1)
175 (otherwise
176 (warn "~%Warning: Order ~A not found. Using default.~%" order))))
177 (t
178 (warn "~%Order specification ~A is not recognized. Using default.~%" order)
179 nil)))
180
181;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
182;;
183;; Ring utilities
184;;
185;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
186
187(defun find-ring (ring)
188 "This function returns the ring structure bases on input symbol."
189 (cond
190 ((null ring) nil)
191 ((symbolp ring)
192 (case ring
193 ((expression-ring :expression-ring $expression_ring) *expression-ring*)
194 ((ring-of-integers :ring-of-integers $ring_of_integers) *ring-of-integers*)
195 (otherwise
196 (warn "~%Warning: Ring ~A not found. Using default.~%" ring))))
197 (t
198 (warn "~%Ring specification ~A is not recognized. Using default.~%" ring)
199 nil)))
Note: See TracBrowser for help on using the repository browser.