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

Contents of /flexichain/flexicursor.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sat Jan 26 11:23:09 2008 UTC (6 years, 2 months ago) by rstrandh
Branch: MAIN
Changes since 1.3: +9 -11 lines
Patch from Troels Henriksen.
1 ;;; Flexichain
2 ;;; Flexicursor data structure definition
3 ;;;
4 ;;; Copyright (C) 2003-2004 Robert Strandh (strandh@labri.fr)
5 ;;; Copyright (C) 2003-2004 Matthieu Villeneuve (matthieu.villeneuve@free.fr)
6 ;;;
7 ;;; This library is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the GNU Lesser General Public
9 ;;; License as published by the Free Software Foundation; either
10 ;;; version 2.1 of the License, or (at your option) any later version.
11 ;;;
12 ;;; This library 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 GNU
15 ;;; Lesser General Public License for more details.
16 ;;;
17 ;;; You should have received a copy of the GNU Lesser General Public
18 ;;; License along with this library; if not, write to the Free Software
19 ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20
21
22 (in-package :flexichain)
23
24 (defclass cursorchain (flexichain)
25 ()
26 (:documentation "The protocol class for cursor chains."))
27
28 (defclass flexicursor ()
29 ()
30 (:documentation "The protocol class for flexicursors."))
31
32 (define-condition at-beginning-error (flexi-error)
33 ((cursor :reader at-beginning-error-cursor
34 :initarg :cursor :initform nil))
35 (:report (lambda (condition stream)
36 (let ((cursor (at-beginning-error-cursor condition)))
37 (format stream "Cursor ~A already at the beginning of ~A"
38 cursor
39 (chain cursor))))))
40
41 (define-condition at-end-error (flexi-error)
42 ((cursor :reader at-end-error-cursor
43 :initarg :cursor :initform nil))
44 (:report (lambda (condition stream)
45 (let ((cursor (at-end-error-cursor condition)))
46 (format stream "Cursor ~A already at the end of ~A"
47 cursor
48 (chain cursor))))))
49
50 (defgeneric clone-cursor (cursor)
51 (:documentation "Creates a cursor that is initially at the same location
52 as the one given as argument."))
53
54 (defgeneric cursor-pos (cursor)
55 (:documentation "Returns the position of the cursor."))
56
57 (defgeneric (setf cursor-pos) (posistion cursor)
58 (:documentation "Set the position of the cursor."))
59
60 (defgeneric at-beginning-p (cursor)
61 (:documentation "Returns true if the cursor is at the beginning
62 of the chain."))
63
64 (defgeneric at-end-p (cursor)
65 (:documentation "Returns true if the cursor is at the beginning
66 of the chain."))
67
68 (defgeneric move> (cursor &optional n)
69 (:documentation "Moves the cursor forward N positions."))
70
71 (defgeneric move< (cursor &optional n)
72 (:documentation "Moves the cursor backward N positions."))
73
74 (defgeneric insert (cursor object)
75 (:documentation "Inserts an object at the cursor."))
76
77 (defgeneric insert-sequence (cursor sequence)
78 (:documentation "The effect is the same as if each element of the
79 sequence was inserted using INSERT."))
80
81 (defgeneric delete< (cursor &optional n)
82 (:documentation "Deletes N objects before the cursor."))
83
84 (defgeneric delete> (cursor &optional n)
85 (:documentation "Deletes N objects after the cursor."))
86
87 (defgeneric element< (cursor)
88 (:documentation "Returns the element immediately before the cursor."))
89
90 (defgeneric (setf element<) (object cursor)
91 (:documentation "Replaces the element immediately before the cursor."))
92
93 (defgeneric element> (cursor)
94 (:documentation "Returns the element immediately after the cursor."))
95
96 (defgeneric (setf element>) (object cursor)
97 (:documentation "Replaces the element immediately after the cursor."))
98
99 (defclass standard-cursorchain (cursorchain standard-flexichain)
100 ((cursors :initform '()))
101 (:documentation "The standard instantiable subclass of CURSORCHAIN"))
102
103 (defclass standard-flexicursor (flexicursor)
104 ((chain :reader chain :initarg :chain)
105 (index :accessor flexicursor-index))
106 (:documentation "The standard instantiable subclass of FLEXICURSOR"))
107
108 (defclass left-sticky-flexicursor (standard-flexicursor) ())
109
110 (defclass right-sticky-flexicursor (standard-flexicursor) ())
111
112 (defmethod initialize-instance :after ((cursor left-sticky-flexicursor)
113 &rest initargs &key (position 0))
114 (declare (ignore initargs))
115 (with-slots (index chain) cursor
116 (setf index (position-index chain (1- position)))
117 (with-slots (cursors) chain
118 (push (make-weak-pointer cursor) cursors))))
119
120 (defmethod initialize-instance :after ((cursor right-sticky-flexicursor)
121 &rest initargs &key (position 0))
122 (declare (ignore initargs))
123 (with-slots (index chain) cursor
124 (setf index (position-index chain position))
125 (with-slots (cursors) chain
126 (push (make-weak-pointer cursor) cursors))))
127
128 (defun adjust-cursors (cursors start end increment)
129 (let ((acc '()))
130 (loop
131 for cursor = (and cursors (weak-pointer-value (car cursors)))
132 while cursors
133 do (cond ((null cursor)
134 (pop cursors))
135 ((<= start (flexicursor-index cursor) end)
136 (incf (flexicursor-index cursor) increment)
137 (let ((rest (cdr cursors)))
138 (setf (cdr cursors) acc
139 acc cursors
140 cursors rest)))
141 (t
142 (let ((rest (cdr cursors)))
143 (setf (cdr cursors) acc
144 acc cursors
145 cursors rest)))))
146 acc))
147
148 (defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2)
149 (declare (ignore to from))
150 (with-slots (cursors) cc
151 (setf cursors (adjust-cursors cursors start2 (1- end2) (- start1 start2)))))
152
153 (defmethod clone-cursor ((cursor standard-flexicursor))
154 (make-instance (class-of cursor)
155 :chain (chain cursor)
156 :position (cursor-pos cursor)))
157
158 (defmethod cursor-pos ((cursor left-sticky-flexicursor))
159 (1+ (index-position (chain cursor) (slot-value cursor 'index))))
160
161 (defmethod (setf cursor-pos) (position (cursor left-sticky-flexicursor))
162 (assert (<= 0 position (nb-elements (chain cursor))) ()
163 'flexi-position-error :chain (chain cursor) :position position)
164 (with-slots (chain) cursor
165 (setf (flexicursor-index cursor) (position-index chain (1- position)))))
166
167 (defmethod cursor-pos ((cursor right-sticky-flexicursor))
168 (index-position (chain cursor) (slot-value cursor 'index)))
169
170 (defmethod (setf cursor-pos) (position (cursor right-sticky-flexicursor))
171 (assert (<= 0 position (nb-elements (chain cursor))) ()
172 'flexi-position-error :chain (chain cursor) :position position)
173 (with-slots (chain) cursor
174 (setf (flexicursor-index cursor) (position-index chain position))))
175
176 (defmethod at-beginning-p ((cursor standard-flexicursor))
177 (zerop (cursor-pos cursor)))
178
179 (defmethod at-end-p ((cursor standard-flexicursor))
180 (= (cursor-pos cursor) (nb-elements (chain cursor))))
181
182 (defmethod insert ((cursor standard-flexicursor) object)
183 (insert* (chain cursor) (cursor-pos cursor) object))
184
185 (defmethod insert-sequence ((cursor standard-flexicursor) sequence)
186 (map nil
187 (lambda (object)
188 (insert cursor object))
189 sequence))
190
191 (defmethod delete* :before ((chain standard-cursorchain) position)
192 (with-slots (cursors) chain
193 (let* ((old-index (position-index chain position)))
194 (loop for cursor-wp in cursors
195 as cursor = (weak-pointer-value cursor-wp)
196 when (and cursor (= old-index (flexicursor-index cursor)))
197 do (typecase cursor
198 (right-sticky-flexicursor (incf (cursor-pos cursor)))
199 (left-sticky-flexicursor (decf (cursor-pos cursor))))))))
200
201 (defmethod delete-elements* :before ((chain standard-cursorchain) position n)
202 (with-slots (cursors) chain
203 (when (minusp n)
204 (incf position n)
205 (setf n (* -1 n)))
206 (unless (zerop n)
207 (loop for cursor-wp in cursors
208 as cursor = (weak-pointer-value cursor-wp)
209 when (and cursor (<= position (cursor-pos cursor)
210 (+ position n)))
211 do (typecase cursor
212 (right-sticky-flexicursor (setf (cursor-pos cursor)
213 (+ position n)))
214 (left-sticky-flexicursor (setf (cursor-pos cursor)
215 position)))))))
216
217 (defmethod delete> ((cursor standard-flexicursor) &optional (n 1))
218 (let ((chain (chain cursor))
219 (position (cursor-pos cursor)))
220 (assert (plusp n) ()
221 'flexi-position-error :chain chain :position n)
222 (loop repeat n
223 do (delete* chain position))))
224
225 (defmethod delete< ((cursor standard-flexicursor) &optional (n 1))
226 (let ((chain (chain cursor))
227 (position (cursor-pos cursor)))
228 (assert (plusp n) ()
229 'flexi-position-error :chain chain :position n)
230 (loop repeat n
231 do (delete* chain (- position n)))))
232
233 (defmethod element> ((cursor standard-flexicursor))
234 (assert (not (at-end-p cursor)) ()
235 'at-end-error :cursor cursor)
236 (element* (chain cursor) (cursor-pos cursor)))
237
238 (defmethod (setf element>) (object (cursor standard-flexicursor))
239 (assert (not (at-end-p cursor)) ()
240 'at-end-error :cursor cursor)
241 (setf (element* (chain cursor) (cursor-pos cursor))
242 object))
243
244 (defmethod element< ((cursor standard-flexicursor))
245 (assert (not (at-beginning-p cursor)) ()
246 'at-beginning-error :cursor cursor)
247 (element* (chain cursor) (1- (cursor-pos cursor))))
248
249 (defmethod (setf element<) (object (cursor standard-flexicursor))
250 (assert (not (at-beginning-p cursor)) ()
251 'at-beginning-error :cursor cursor)
252 (setf (element* (chain cursor) (1- (cursor-pos cursor)))
253 object))
254

  ViewVC Help
Powered by ViewVC 1.1.5