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/integer-ring.lisp@ 4268

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

* empty log message *

File size: 4.0 KB
Line 
1;;; -*- Mode: Lisp -*-
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(defpackage "INTEGER-RING"
23 (:use :cl :copy :ring)
24 (:export "INTEGER-RING"
25 "INTEGER-RING-VALUE"
26 "ADD-TO"
27 "SUBTRACT-FROM"
28 "MULTIPLY-BY"
29 "DIVIDE-BY"
30 "UNARY-MINUS"
31 "UNARY-INVERSE"
32 "UNIVERSAL-GCD"
33 "UNIVERSAL-EZGCD"
34 "UNIVERSAL-EQUALP"
35 "UNIVERSAL-ZEROP"
36 "->SEXP")
37 (:documentation "Wraps integers into an object."))
38
39(in-package "INTEGER-RING")
40
41(defclass integer-ring (ring)
42 ((value :initarg :value :initform 0 :accessor integer-ring-value :type integer))
43 (:documentation "An object representing an integer.")
44 )
45
46(defmethod print-object ((self integer-ring) stream)
47 (print-unreadable-object (self stream :type t :identity t)
48 (with-accessors ((value integer-ring-value))
49 self
50 (format stream "VALUE=~A" value))))
51
52(defmethod multiply-by ((self integer-ring) (other integer-ring))
53 (with-slots (value)
54 self
55 (with-slots ((other-value value))
56 other
57 (setf value (* value other-value))))
58 self)
59
60(defmethod divide-by ((self integer-ring) (other integer-ring))
61 (with-slots (value)
62 self
63 (with-slots ((other-value value))
64 other
65 (assert (zerop (mod value other-value)))
66 (setf value (/ value other-value))))
67 self)
68
69(defmethod add-to ((self integer-ring) (other integer-ring))
70 (with-slots (value)
71 self
72 (with-slots ((other-value value))
73 other
74 (setf value (+ value other-value))))
75 self)
76
77(defmethod subtract-from ((self integer-ring) (other integer-ring))
78 (with-slots (value)
79 self
80 (with-slots ((other-value value))
81 other
82 (setf value (- value other-value))))
83 self)
84
85(defmethod unary-minus ((self integer-ring))
86 (with-slots (value)
87 self
88 (setf value (- value)))
89 self)
90
91(defmethod unary-inverse ((self integer-ring))
92 (with-slots (value)
93 self
94 (case value
95 (1 self)
96 (-1 self)
97 (otherwise (error "Non-invertible ring element: ~S" self)))))
98
99(defmethod universal-zerop ((self integer-ring))
100 (with-slots (value)
101 self
102 (zerop value)))
103
104(defmethod universal-gcd ((self integer-ring) (other integer-ring))
105 (with-slots (value)
106 self
107 (with-slots ((other-value value))
108 other
109 (make-instance 'integer-ring :value (gcd value other-value)))))
110
111(defmethod universal-ezgcd ((object integer-ring) (other integer-ring))
112 (with-slots (value)
113 object
114 (with-slots ((other-value value))
115 other
116 (let ((c (gcd value other-value)))
117 (values (make-instance 'integer-ring :value c)
118 (make-instance 'integer-ring :value (/ value c))
119 (make-instance 'integer-ring :value (/ other-value c)))))))
120
121(defmethod universal-equalp ((self integer-ring) (other integer-ring))
122 (with-slots (value)
123 self
124 (with-slots ((other-value value))
125 other
126 (= value other-value))))
127
128(defmethod ->sexp ((self integer-ring) &optional vars)
129 (declare (ignore vars))
130 (integer-ring-value self))
Note: See TracBrowser for help on using the repository browser.