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

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

* empty log message *

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