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/polynomial-sugar.lisp@ 4523

Last change on this file since 4523 was 4523, checked in by Marek Rychlik, 8 years ago

* empty log message *

File size: 6.1 KB
Line 
1;;----------------------------------------------------------------
2;;; -*- Mode: Lisp -*-
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;;
5;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
6;;;
7;;; This program is free software; you can redistribute it and/or modify
8;;; it under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 2 of the License, or
10;;; (at your option) any later version.
11;;;
12;;; This program is distributed in the hope that it will be useful,
13;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with this program; if not, write to the Free Software
19;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
20;;;
21;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22
23(defpackage "POLYNOMIAL-SUGAR"
24 (:use :cl :utils :monom :copy :ring :polynomial)
25 (:export "MONOM-WITH-SUGAR"
26 "TERM-WITH-SUGAR"
27 "POLY-WITH-SUGAR"
28 "STATIC-SUGAR"
29 "SUGAR"
30 "SUGAR-VALUE"
31 "POLY-INSERT-TERM"
32 "ADD-TO"
33 "MULTIPLY-BY"
34 )
35 (:documentation "Implements 'sugar'."))
36
37(in-package "POLYNOMIAL-SUGAR")
38
39;;(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
40
41(defgeneric static-sugar (object)
42 (:documentation "Return statically calculated sugar of object
43OBJECT. That is, the sugar value which does not assume that the object
44is a result of any prior calculations.")
45 (:method ((object monom))
46 "Static sugar of a monom OBJECT is simply the total degree."
47 (total-degree object))
48 (:method ((object poly))
49 "Static sugar of a poly OBJECT is the maximum sugar of its terms."
50 (with-slots (termlist)
51 object
52 (loop for trm in termlist maximize (static-sugar trm)))))
53
54(defclass sugar ()
55 ((value :initarg :value :initform -1 :accessor sugar-value :type fixnum))
56 (:documentation "Sugar is a quantity added to various objects, such as monomials, terms and polynomials."))
57
58(defclass monom-with-sugar (monom sugar) ())
59
60(defmethod print-object ((self monom-with-sugar) stream)
61 (print-unreadable-object (self stream :type t :identity t)
62 (with-accessors ((exponents monom-exponents) (value sugar-value))
63 self
64 (format stream "EXPONENTS=~A SUGAR=~A"
65 exponents value))))
66
67
68(defmethod shared-initialize :after ((self monom-with-sugar) slot-names &rest initargs &key)
69 "Initialize sugar value based on the exponents."
70 (declare (ignore slot-names initargs))
71 (setf (slot-value self 'value) (static-sugar self)))
72
73(defmethod update-instance-for-different-class :after ((old monom) (new monom-with-sugar) &key)
74 "Add sugar."
75 (reinitialize-instance new :value (static-sugar new)))
76
77
78(defmethod multiply-by :after ((self sugar) (other sugar))
79 (with-slots (value)
80 self
81 (with-slots ((other-value value))
82 other
83 (incf value other-value)))
84 self)
85
86(defmethod divide-by :after ((self sugar) (other sugar))
87 (with-slots (value)
88 self
89 (with-slots ((other-value value))
90 other
91 (decf value other-value)))
92 self)
93
94(defclass term-with-sugar (term sugar) ())
95
96(defmethod print-object ((self term-with-sugar) stream)
97 (print-unreadable-object (self stream :type t :identity t)
98 (with-accessors ((exponents monom-exponents) (value sugar-value) (coeff term-coeff))
99 self
100 (format stream "EXPONENTS=~A COEFF=~A SUGAR=~A"
101 exponents coeff value))))
102
103(defmethod shared-initialize :after ((self term-with-sugar) slot-names &rest initargs &key)
104 (declare (ignore slot-names initargs))
105 (setf (slot-value self 'value) (static-sugar self)))
106
107
108(defmethod update-instance-for-different-class :after ((old term) (new term-with-sugar) &key)
109 "Add sugar."
110 (reinitialize-instance new :value (static-sugar new)))
111
112(defclass poly-with-sugar (poly sugar) ())
113
114(defmethod print-object ((self poly-with-sugar) stream)
115 (print-unreadable-object (self stream :type t :identity t)
116 (with-accessors ((termlist poly-termlist)
117 (order poly-term-order)
118 (value sugar-value))
119 self
120 (format stream "TERMLIST=~A ORDER=~A SUGAR=~A"
121 termlist order value))))
122
123
124(defmethod shared-initialize :after ((self poly-with-sugar) slot-names &rest initargs &key)
125 "Initialize sugar to its static value, which is the maximum of sugar values of the terms."
126 (declare (ignore slot-names initargs))
127 (setf (slot-value self 'value) (static-sugar self)))
128
129(defmethod update-instance-for-different-class :after ((old poly) (new poly-with-sugar) &key)
130 "Add sugar to every term."
131 (reinitialize-instance new :termlist (mapc #'(lambda (trm) (change-class trm 'term-with-sugar)) (poly-termlist new))))
132
133(defmethod update-instance-for-different-class :after ((old poly-with-sugar) (new poly) &key)
134 "Drop sugar in every term."
135 (reinitialize-instance new :termlist (mapc #'(lambda (trm) (change-class trm 'term)) (poly-termlist new))))
136
137(defmethod add-to ((self poly-with-sugar) (other poly-with-sugar))
138 "Sugar value of the sum of two polynomials, SELF and OTHER, is by definition
139the maximum of the sugar values of the summands."
140 (with-accessors ((value sugar-value))
141 self
142 (with-accessors ((other-value sugar-value))
143 other
144 (setf value (max value other-value))))
145 self)
146
147(defmethod poly-insert-term :after ((self poly-with-sugar) (other term-with-sugar))
148 (with-accessors ((value sugar-value))
149 self
150 (with-accessors ((other-value sugar-value))
151 other
152 (setf value (max value other-value))))
153 self)
154
155
156(defmethod multiply-by ((self poly-with-sugar) (other poly-with-sugar))
157 "Sugar value of the product of two polynomials, SELF and OTHER, is by definition
158the sum of the sugar values of the factors."
159 (with-accessors ((value sugar-value))
160 self
161 (with-accessors ((other-value sugar-value))
162 other
163 (setf value (max value other-value))))
164 self)
Note: See TracBrowser for help on using the repository browser.