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

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

* empty log message *

File size: 6.2 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 "MAKE-UNIT-FOR"
35 )
36 (:documentation "Implements 'sugar'."))
37
38(in-package "POLYNOMIAL-SUGAR")
39
40(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
41
42(defgeneric static-sugar (object)
43 (:documentation "Return statically calculated sugar of object
44OBJECT. That is, the sugar value which does not assume that the object
45is a result of any prior calculations.")
46 (:method ((object monom))
47 "Static sugar of a monom OBJECT is simply the total degree."
48 (total-degree object))
49 (:method ((object poly))
50 "Static sugar of a poly OBJECT is the maximum sugar of its terms."
51 (with-accessors ((termlist poly-termlist))
52 object
53 (loop for trm in termlist maximize (static-sugar trm)))))
54
55(defclass sugar ()
56 ((value :initarg :value :initform -1 :accessor sugar-value :type fixnum))
57 (:documentation "Sugar is a quantity added to various objects, such as monomials, terms and polynomials."))
58
59(defclass monom-with-sugar (monom sugar) ())
60
61(defmethod print-object ((self monom-with-sugar) stream)
62 (print-unreadable-object (self stream :type t :identity t)
63 (with-accessors ((exponents monom-exponents) (value sugar-value))
64 self
65 (format stream "EXPONENTS=~A SUGAR=~A"
66 exponents value))))
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 (with-slots (value)
72 self
73 (setf value (static-sugar self))))
74
75(defmethod update-instance-for-different-class :after ((old monom) (new monom-with-sugar) &key)
76 "Add sugar to a monom OLD."
77 (reinitialize-instance new :value (static-sugar new)))
78
79
80(defmethod multiply-by :after ((self sugar) (other sugar))
81 "By definition, sugar is additive under multiplication."
82 (with-slots (value)
83 self
84 (with-slots ((other-value value))
85 other
86 (incf value other-value)))
87 self)
88
89(defclass term-with-sugar (term sugar) ())
90
91(defmethod print-object ((self term-with-sugar) stream)
92 (print-unreadable-object (self stream :type t :identity t)
93 (with-accessors ((exponents monom-exponents) (value sugar-value) (coeff term-coeff))
94 self
95 (format stream "EXPONENTS=~A COEFF=~A SUGAR=~A"
96 exponents coeff value))))
97
98(defmethod shared-initialize :after ((self term-with-sugar) slot-names &rest initargs &key)
99 (declare (ignore slot-names initargs))
100 (with-slots (value)
101 self
102 (setf value (static-sugar self))))
103
104
105(defmethod update-instance-for-different-class :after ((old term) (new term-with-sugar) &key)
106 "Add sugar."
107 (reinitialize-instance new :value (static-sugar new)))
108
109(defclass poly-with-sugar (poly sugar) ())
110
111(defmethod print-object ((self poly-with-sugar) stream)
112 (print-unreadable-object (self stream :type t :identity t)
113 (with-accessors ((termlist poly-termlist)
114 (order poly-term-order)
115 (value sugar-value))
116 self
117 (format stream "TERMLIST=~A ORDER=~A SUGAR=~A"
118 termlist order value))))
119
120
121(defmethod shared-initialize :after ((self poly-with-sugar) slot-names &rest initargs &key)
122 "Initialize sugar to its static value, which is the maximum of sugar values of the terms."
123 (declare (ignore slot-names initargs))
124 (setf (slot-value self 'value) (static-sugar self)))
125
126(defmethod update-instance-for-different-class :after ((old poly) (new poly-with-sugar) &key)
127 "Add sugar to every term."
128 (reinitialize-instance new :termlist (mapc #'(lambda (trm) (change-class trm 'term-with-sugar)) (poly-termlist new))))
129
130(defmethod update-instance-for-different-class :after ((old poly-with-sugar) (new poly) &key)
131 "Drop sugar in every term."
132 (reinitialize-instance new :termlist (mapc #'(lambda (trm) (change-class trm 'term)) (poly-termlist new))))
133
134(defmethod add-to ((self poly-with-sugar) (other poly-with-sugar))
135 "Sugar value of the sum of two polynomials, SELF and OTHER, is by definition
136the maximum of the sugar values of the summands."
137 (with-accessors ((value sugar-value))
138 self
139 (with-accessors ((other-value sugar-value))
140 other
141 (setf value (max value other-value))))
142 self)
143
144(defmethod poly-insert-term :after ((self poly-with-sugar) (other term-with-sugar))
145 (with-accessors ((value sugar-value))
146 self
147 (with-accessors ((other-value sugar-value))
148 other
149 (setf value (max value other-value))))
150 self)
151
152
153(defmethod multiply-by ((self poly-with-sugar) (other poly-with-sugar))
154 "Sugar value of the product of two polynomials, SELF and OTHER, is by definition
155the sum of the sugar values of the factors."
156 (with-accessors ((value sugar-value))
157 self
158 (with-accessors ((other-value sugar-value))
159 other
160 (setf value (max value other-value))))
161 self)
162
163(defmethod make-unit-for ((object poly-with-sugar))
164 (change-class (call-next-method) 'poly-with-sugar))
Note: See TracBrowser for help on using the repository browser.