/[flexichain]/flexichain/stupid.lisp
ViewVC logotype

Contents of /flexichain/stupid.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Thu Feb 9 02:51:06 2006 UTC (8 years, 2 months ago) by rkreuter
Branch: clnet
CVS Tags: release-1-1, initial
Changes since 1.1: +0 -0 lines
Initial checkin.
1 ;;; this is a stupid implementation of the flexichain and flexicursor
2 ;;; protocols. The idea is to use this as a reference implementation
3 ;;; and test the other one by generating random operations issued to
4 ;;; both implementations and compare the result.
5
6 (defpackage :stupid
7 (:use :common-lisp)
8 (:export #:flexichain #:standard-flexichain
9 #:flexi-error #:flexi-initialization-error
10 #:flexi-position-error #:flexi-incompatible-type-error
11 #:nb-elements #:flexi-empty-p
12 #:insert* #:element* #:delete*
13 #:push-start #:pop-start #:push-end #:pop-end #:rotate
14 #:cursorchain #:standard-cursorchain
15 #:flexicursor #:standard-flexicursor
16 #:left-sticky-flexicursor #:right-sticky-flexicursor
17 #:chain
18 #:clone-cursor #:cursor-pos
19 #:at-beginning-error #:at-end-error
20 #:at-beginning-p #:at-end-p
21 #:move> #:move<
22 #:insert #:insert-sequence
23 #:element< #:element> #:delete< #:delete>))
24
25 (in-package :stupid)
26
27 (defclass flexichain () ()
28 (:documentation "The protocol class for flexichains."))
29
30 (define-condition flexi-error (simple-error)
31 ())
32
33 (define-condition flexi-initialization-error (flexi-error)
34 ((cause :reader flexi-initialization-error-cause
35 :initarg :cause :initform ""))
36 (:report (lambda (condition stream)
37 (format stream "Error initializing FLEXICHAIN (~S)"
38 (flexi-initialization-error-cause condition)))))
39
40 (define-condition flexi-position-error (flexi-error)
41 ((chain :reader flexi-position-error-chain
42 :initarg :chain :initform nil)
43 (position :reader flexi-position-error-position
44 :initarg :position :initform nil))
45 (:report (lambda (condition stream)
46 (format stream "Position ~D out of bounds in ~A"
47 (flexi-position-error-position condition)
48 (flexi-position-error-chain condition)))))
49
50 (define-condition flexi-incompatible-type-error (flexi-error)
51 ((chain :reader flexi-incompatible-type-error-chain
52 :initarg :chain :initform nil)
53 (element :reader flexi-incompatible-type-error-element
54 :initarg :element :initform nil))
55 (:report (lambda (condition stream)
56 (let ((element (flexi-incompatible-type-error-element
57 condition)))
58 (format stream "Element ~A of type ~A cannot be inserted in ~A"
59 element
60 (type-of element)
61 (flexi-incompatible-type-error-chain condition))))))
62
63 (defgeneric nb-elements (chain)
64 (:documentation "Returns the number of elements in the flexichain."))
65
66 (defgeneric flexi-empty-p (chain)
67 (:documentation "Checks whether CHAIN is empty or not."))
68
69 (defgeneric insert* (chain position object)
70 (:documentation "Inserts an object before the element at POSITION
71 in the chain. If POSITION is out of range (less than 0 or greater
72 than the length of CHAIN, the FLEXI-POSITION-ERROR condition will be
73 signaled."))
74
75 (defgeneric delete* (chain position)
76 (:documentation "Deletes an element at POSITION of the chain.
77 If POSITION is out of range (less than 0 or greater than or equal
78 to the length of CHAIN, the FLEXI-POSITION-ERROR condition
79 will be signaled."))
80
81 (defgeneric element* (chain position)
82 (:documentation "Returns the element at POSITION of the chain.
83 If POSITION is out of range (less than 0 or greater than or equal
84 to the length of CHAIN, the FLEXI-POSITION-ERROR condition
85 will be signaled."))
86
87 (defgeneric (setf element*) (object chain position)
88 (:documentation "Replaces the element at POSITION of CHAIN by OBJECT.
89 If POSITION if out of range (less than 0 or greater than or equal to
90 the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled."))
91
92 (defgeneric push-start (chain object)
93 (:documentation "Inserts an object at the beginning of CHAIN."))
94
95 (defgeneric push-end (chain object)
96 (:documentation "Inserts an object at the end of CHAIN."))
97
98 (defgeneric pop-start (chain)
99 (:documentation "Pops and returns the element at the beginning of CHAIN."))
100
101 (defgeneric pop-end (chain)
102 (:documentation "Pops and returns the element at the end of CHAIN."))
103
104 (defgeneric rotate (chain &optional n)
105 (:documentation "Rotates the elements of CHAIN so that the element
106 that used to be at position N is now at position 0. With a negative
107 value of N, rotates the elements so that the element that used to be
108 at position 0 is now at position N."))
109
110 (defclass standard-flexichain (flexichain)
111 ((elements :initform (list '()) :accessor elements)))
112
113 (defmethod nb-elements ((chain standard-flexichain))
114 (/ (1- (length (elements chain))) 2))
115
116 (defmethod flexi-empty-p ((chain standard-flexichain))
117 (zerop (nb-elements chain)))
118
119 (defmethod insert* ((chain standard-flexichain) position object)
120 (assert (<= 0 position (nb-elements chain)) ()
121 'flexi-position-error :chain chain :position position)
122 (let* ((remainder (nthcdr (* 2 position) (elements chain))))
123 (push (remove-if-not (lambda (x) (typep x 'right-sticky-flexicursor)) (car remainder))
124 (cdr remainder))
125 (push object (cdr remainder))
126 (setf (car remainder)
127 (remove-if (lambda (x) (typep x 'right-sticky-flexicursor)) (car remainder)))))
128
129 (defmethod delete* ((chain standard-flexichain) position)
130 (assert (< -1 position (nb-elements chain)) ()
131 'flexi-position-error :chain chain :position position)
132 (let* ((remainder (nthcdr (* 2 position) (elements chain))))
133 (pop (cdr remainder))
134 (setf (car remainder) (append (cadr remainder) (car remainder)))
135 (pop (cdr remainder))))
136
137 (defmethod element* ((chain standard-flexichain) position)
138 (assert (< -1 position (nb-elements chain)) ()
139 'flexi-position-error :chain chain :position position)
140 (nth (1+ (* 2 position)) (elements chain)))
141
142 (defmethod (setf element*) (object (chain standard-flexichain) position)
143 (assert (< -1 position (nb-elements chain)) ()
144 'flexi-position-error :chain chain :position position)
145 (setf (nth (1+ (* 2 position)) (elements chain)) object))
146
147 (defmethod push-start ((chain standard-flexichain) object)
148 (insert* chain 0 object))
149
150 (defmethod push-end ((chain standard-flexichain) object)
151 (insert* chain (nb-elements chain) object))
152
153 (defmethod pop-start ((chain standard-flexichain))
154 (prog1 (element* chain 0)
155 (delete* chain 0)))
156
157 (defmethod pop-end ((chain standard-flexichain))
158 (let ((position (1- (nb-elements chain))))
159 (prog1 (element* chain position)
160 (delete* chain position))))
161
162 (defmethod rotate ((chain standard-flexichain) &optional (n 1))
163 (when (> (nb-elements chain) 1)
164 (cond ((plusp n) (loop repeat n do (push-start chain (pop-end chain))))
165 ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain))))
166 (t nil))))
167
168 (defclass cursorchain (flexichain)
169 ()
170 (:documentation "The protocol class for cursor chains."))
171
172 (defclass flexicursor ()
173 ()
174 (:documentation "The protocol class for flexicursors."))
175
176 (define-condition at-beginning-error (flexi-error)
177 ((cursor :reader at-beginning-error-cursor
178 :initarg :cursor :initform nil))
179 (:report (lambda (condition stream)
180 (let ((cursor (at-beginning-error-cursor condition)))
181 (format stream "Cursor ~A already at the beginning of ~A"
182 cursor
183 (chain cursor))))))
184
185 (define-condition at-end-error (flexi-error)
186 ((cursor :reader at-end-error-cursor
187 :initarg :cursor :initform nil))
188 (:report (lambda (condition stream)
189 (let ((cursor (at-end-error-cursor condition)))
190 (format stream "Cursor ~A already at the end of ~A"
191 cursor
192 (chain cursor))))))
193
194 (defgeneric clone-cursor (cursor)
195 (:documentation "Creates a cursor that is initially at the same location
196 as the one given as argument."))
197
198 (defgeneric cursor-pos (cursor)
199 (:documentation "Returns the position of the cursor."))
200
201 (defgeneric (setf cursor-pos) (posistion cursor)
202 (:documentation "Set the position of the cursor."))
203
204 (defgeneric at-beginning-p (cursor)
205 (:documentation "Returns true if the cursor is at the beginning
206 of the chain."))
207
208 (defgeneric at-end-p (cursor)
209 (:documentation "Returns true if the cursor is at the beginning
210 of the chain."))
211
212 (defgeneric move> (cursor &optional n)
213 (:documentation "Moves the cursor forward N positions."))
214
215 (defgeneric move< (cursor &optional n)
216 (:documentation "Moves the cursor backward N positions."))
217
218 (defgeneric insert (cursor object)
219 (:documentation "Inserts an object at the cursor."))
220
221 (defgeneric insert-sequence (cursor sequence)
222 (:documentation "The effect is the same as if each element of the
223 sequence was inserted using INSERT."))
224
225 (defgeneric delete< (cursor &optional n)
226 (:documentation "Deletes N objects before the cursor."))
227
228 (defgeneric delete> (cursor &optional n)
229 (:documentation "Deletes N objects after the cursor."))
230
231 (defgeneric element< (cursor)
232 (:documentation "Returns the element immediately before the cursor."))
233
234 (defgeneric (setf element<) (object cursor)
235 (:documentation "Replaces the element immediately before the cursor."))
236
237 (defgeneric element> (cursor)
238 (:documentation "Returns the element immediately after the cursor."))
239
240 (defgeneric (setf element>) (object cursor)
241 (:documentation "Replaces the element immediately after the cursor."))
242
243 (defclass standard-cursorchain (cursorchain standard-flexichain)
244 ()
245 (:documentation "The standard instantiable subclass of CURSORCHAIN"))
246
247 (defclass standard-flexicursor (flexicursor)
248 ((chain :reader chain :initarg :chain))
249 (:documentation "The standard instantiable subclass of FLEXICURSOR"))
250
251 (defmethod initialize-instance :after ((cursor standard-flexicursor)
252 &rest args &key (position 0))
253 (declare (ignore args))
254 (push cursor (car (nthcdr (* 2 position) (elements (chain cursor))))))
255
256 (defclass left-sticky-flexicursor (standard-flexicursor) ())
257
258 (defclass right-sticky-flexicursor (standard-flexicursor) ())
259
260 (defmethod cursor-pos ((cursor standard-flexicursor))
261 (loop for sublist on (elements (chain cursor)) by #'cddr
262 for pos from 0
263 when (member cursor (car sublist) :test #'eq)
264 do (return pos)))
265
266 (defun sublist-of-cursor (cursor)
267 (nthcdr (* 2 (cursor-pos cursor)) (elements (chain cursor))))
268
269 (defmethod clone-cursor ((cursor standard-flexicursor))
270 (make-instance (class-of cursor)
271 :chain (chain cursor)
272 :position (cursor-pos cursor)))
273
274 (defmethod (setf cursor-pos) (position (cursor standard-flexicursor))
275 (assert (<= 0 position (nb-elements (chain cursor))) ()
276 'flexi-position-error :chain (chain cursor) :position position)
277 (let ((sublist1 (sublist-of-cursor cursor))
278 (sublist2 (nthcdr (* 2 position) (elements (chain cursor)))))
279 (setf (car sublist1) (remove cursor (car sublist1) :test #'eq))
280 (push cursor (car sublist2))))
281
282 (defmethod at-beginning-p ((cursor standard-flexicursor))
283 (zerop (cursor-pos cursor)))
284
285 (defmethod at-end-p ((cursor standard-flexicursor))
286 (= (cursor-pos cursor) (nb-elements (chain cursor))))
287
288 (defmethod move> ((cursor standard-flexicursor) &optional (n 1))
289 (incf (cursor-pos cursor) n))
290
291 (defmethod move< ((cursor standard-flexicursor) &optional (n 1))
292 (decf (cursor-pos cursor) n))
293
294 (defmethod insert ((cursor standard-flexicursor) object)
295 (insert* (chain cursor) (cursor-pos cursor) object))
296
297 (defmethod insert-sequence ((cursor standard-flexicursor) sequence)
298 (map nil
299 (lambda (object)
300 (insert cursor object))
301 sequence))
302
303 (defmethod delete> ((cursor standard-flexicursor) &optional (n 1))
304 (let ((chain (chain cursor))
305 (position (cursor-pos cursor)))
306 (assert (plusp n) ()
307 'flexi-position-error :chain chain :position n)
308 (loop repeat n
309 do (delete* chain position))))
310
311 (defmethod delete< ((cursor standard-flexicursor) &optional (n 1))
312 (let ((chain (chain cursor))
313 (position (cursor-pos cursor)))
314 (assert (plusp n) ()
315 'flexi-position-error :chain chain :position n)
316 (loop repeat n
317 do (delete* chain (- position n)))))
318
319 (defmethod element> ((cursor standard-flexicursor))
320 (assert (not (at-end-p cursor)) ()
321 'at-end-error :cursor cursor)
322 (element* (chain cursor) (cursor-pos cursor)))
323
324 (defmethod (setf element>) (object (cursor standard-flexicursor))
325 (assert (not (at-end-p cursor)) ()
326 'at-end-error :cursor cursor)
327 (setf (element* (chain cursor) (cursor-pos cursor))
328 object))
329
330 (defmethod element< ((cursor standard-flexicursor))
331 (assert (not (at-beginning-p cursor)) ()
332 'at-beginning-error :cursor cursor)
333 (element* (chain cursor) (1- (cursor-pos cursor))))
334
335 (defmethod (setf element<) (object (cursor standard-flexicursor))
336 (assert (not (at-beginning-p cursor)) ()
337 'at-beginning-error :cursor cursor)
338 (setf (element* (chain cursor) (1- (cursor-pos cursor)))
339 object))

  ViewVC Help
Powered by ViewVC 1.1.5