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@ 518

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

* empty log message *

File size: 6.2 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 *ratdisrep-fun* #'identity
63 "A function applied to polynomials after conversion to Maxima representation.")
64
65
66
67;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
68;;
69;; This is how we perform operations on coefficients
70;; using Maxima functions.
71;;
72;; Functions and macros dealing with internal representation structure
73;;
74;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75
76
77
78;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
79;;
80;; These are provided mostly for debugging purposes To enable
81;; verification of grobner bases with BUCHBERGER-CRITERION, do
82;; (pushnew :grobner-check *features*) and compile/load this file.
83;; With this feature, the calculations will slow down CONSIDERABLY.
84;;
85;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86
87(defun grobner-test (ring g f)
88 "Test whether G is a Grobner basis and F is contained in G. Return T
89upon success and NIL otherwise."
90 (debug-cgb "~&GROBNER CHECK: ")
91 (let (($poly_grobner_debug nil)
92 (stat1 (buchberger-criterion ring g))
93 (stat2
94 (every #'poly-zerop
95 (makelist (normal-form ring (copy-tree (elt f i)) g nil)
96 (i 0 (1- (length f)))))))
97 (unless stat1 (error "~&Buchberger criterion failed."))
98 (unless stat2
99 (error "~&Original polys not in ideal spanned by Grobner.")))
100 (debug-cgb "~&GROBNER CHECK END")
101 t)
102
103
104
105;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
106;;
107;; Conversion from internal to infix form
108;;
109;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
110
111(defun coerce-to-infix (poly-type object vars)
112 (case poly-type
113 (:termlist
114 `(+ ,@(mapcar #'(lambda (term) (coerce-to-infix :term term vars)) object)))
115 (:polynomial
116 (coerce-to-infix :termlist (poly-termlist object) vars))
117 (:poly-list
118 `([ ,@(mapcar #'(lambda (p) (coerce-to-infix :polynomial p vars)) object)))
119 (:term
120 `(* ,(term-coeff object)
121 ,@(mapcar #'(lambda (var power) `(expt ,var ,power))
122 vars (monom-exponents (term-monom object)))))
123 (otherwise
124 object)))
125
126
127;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
128;;
129;; Order utilities
130;;
131;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
132
133(defun find-order (order)
134 "This function returns the order function bases on its name."
135 (cond
136 ((null order) nil)
137 ((symbolp order)
138 (case order
139 ((lex :lex $lex) #'lex>)
140 ((grlex :grlex $grlex) #'grlex>)
141 ((grevlex :grevlex $grevlex) #'grevlex>)
142 ((invlex :invlex $invlex) #'invlex>)
143 ((elimination-order-1 :elimination-order-1 elimination_order_1) #'elimination-order-1)
144 (otherwise
145 (warn "~%Warning: Order ~A not found. Using default.~%" order))))
146 (t
147 (warn "~%Order specification ~A is not recognized. Using default.~%" order)
148 nil)))
149
150;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
151;;
152;; Ring utilities
153;;
154;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
155
156(defun find-ring (ring)
157 "This function returns the ring structure bases on input symbol."
158 (cond
159 ((null ring) nil)
160 ((symbolp ring)
161 (case ring
162 ((expression-ring :expression-ring $expression_ring) *expression-ring*)
163 ((ring-of-integers :ring-of-integers $ring_of_integers) *ring-of-integers*)
164 (otherwise
165 (warn "~%Warning: Ring ~A not found. Using default.~%" ring))))
166 (t
167 (warn "~%Ring specification ~A is not recognized. Using default.~%" ring)
168 nil)))
Note: See TracBrowser for help on using the repository browser.