[climacs-cvs] CVS update: climacs/Persistent/binseq2.lisp climacs/Persistent/binseq-package.lisp climacs/Persistent/binseq.lisp climacs/Persistent/obinseq.lisp climacs/Persistent/persistent-buffer.lisp
Aleksandar Bakic
abakic at common-lisp.net
Sun Mar 13 20:51:56 UTC 2005
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv22428/Persistent
Modified Files:
binseq-package.lisp binseq.lisp obinseq.lisp
persistent-buffer.lisp
Added Files:
binseq2.lisp
Log Message:
Line-oriented persistent buffer (binseq2). Warning: Need to fix minor
bugs (related to number-of-lines-in-region, I believe).
base.lisp: Added faster methods on previous-line, next-line,
buffer-number-of-lines-in-region.
pane.lisp, cl-syntax.lisp, html-syntax.lisp, text-syntax.lisp:
Replaced some calls to make-instance to calls to clone-mark and (setf
offset), in order to avoid passing climacs-buffer to marks. This also
made possible to get rid of delegating methods on syntax.
climacs.asd: Added Persistent/binseq2.
packages.lisp: Added binseq2-related symbols.
Persistent/binseq.lisp, Persistent/obinseq.lisp: Cleanup.
Persistent/persistent-buffer.lisp: Added code for binseq2-buffer and
related marks. Also some minor fixes.
Date: Sun Mar 13 21:51:54 2005
Author: abakic
Index: climacs/Persistent/binseq-package.lisp
diff -u climacs/Persistent/binseq-package.lisp:1.2 climacs/Persistent/binseq-package.lisp:1.3
--- climacs/Persistent/binseq-package.lisp:1.2 Sun Mar 6 00:24:41 2005
+++ climacs/Persistent/binseq-package.lisp Sun Mar 13 21:51:52 2005
@@ -59,4 +59,36 @@
#:obinseq-insert
#:obinseq-insert*
#:obinseq-remove
- #:obinseq-remove*))
\ No newline at end of file
+ #:obinseq-remove*
+
+ #:binseq2-p
+ #:list-binseq2
+ #:binseq2-list
+ #:vector-binseq2
+ #:binseq2-vector
+ #:binseq2-empty
+ #:binseq2-length
+ #:binseq2-size
+ #:binseq2-front
+ #:binseq2-offset
+ #:binseq2-back
+ #:binseq2-front2
+ #:binseq2-line2
+ #:binseq2-back2
+ #:binseq2-get
+ #:binseq2-set
+ #:binseq2-get2
+ #:binseq2-set2
+ #:binseq2-sub
+ #:binseq2-sub2
+ #:binseq2-cons
+ #:binseq2-snoc
+ #:binseq2-append
+ #:binseq2-insert
+ #:binseq2-insert2
+ #:binseq2-insert*
+ #:binseq2-insert*2
+ #:binseq2-remove
+ #:binseq2-remove2
+ #:binseq2-remove*
+ #:binseq2-remove*2))
\ No newline at end of file
Index: climacs/Persistent/binseq.lisp
diff -u climacs/Persistent/binseq.lisp:1.2 climacs/Persistent/binseq.lisp:1.3
--- climacs/Persistent/binseq.lisp:1.2 Sun Mar 6 00:23:53 2005
+++ climacs/Persistent/binseq.lisp Sun Mar 13 21:51:53 2005
@@ -22,7 +22,7 @@
(in-package :binseq)
-(defun binseq-p (s)
+(defun binseq-p (s) ; NOTE: should use a 3-vector instead of the 3-list...
(or (eq s 'empty)
(and (consp s)
(or (eq (car s) 'leaf)
@@ -160,21 +160,19 @@
(cond
((<= i 0) 'empty)
((<= (binseq-length s) i) s)
- (t (cond
- ((<= i (binseq-length (caddr s))) (binseq-front (caddr s) i))
- (t (binseq-append
- (caddr s)
- (binseq-front (cdddr s) (- i (binseq-length (caddr s))))))))))
+ ((<= i (binseq-length (caddr s))) (binseq-front (caddr s) i))
+ (t (binseq-append
+ (caddr s)
+ (binseq-front (cdddr s) (- i (binseq-length (caddr s))))))))
(defun binseq-back (s i)
(cond
((<= i 0) 'empty)
((<= (binseq-length s) i) s)
- (t (cond
- ((<= i (binseq-length (cdddr s))) (binseq-back (cdddr s) i))
- (t (binseq-append
- (binseq-back (caddr s) (- i (binseq-length (cdddr s))))
- (cdddr s)))))))
+ ((<= i (binseq-length (cdddr s))) (binseq-back (cdddr s) i))
+ (t (binseq-append
+ (binseq-back (caddr s) (- i (binseq-length (cdddr s))))
+ (cdddr s)))))
(defun %has-index (s i)
(and (<= 0 i) (< i (binseq-length s))))
Index: climacs/Persistent/obinseq.lisp
diff -u climacs/Persistent/obinseq.lisp:1.2 climacs/Persistent/obinseq.lisp:1.3
--- climacs/Persistent/obinseq.lisp:1.2 Sun Mar 6 00:23:54 2005
+++ climacs/Persistent/obinseq.lisp Sun Mar 13 21:51:53 2005
@@ -28,7 +28,7 @@
(or (null s)
(atom s)
(and (consp s)
- (and (integerp (car s))
+ (and (integerp (car s)) ; might wanna check the value
(consp (cdr s))
(obinseq-p (cadr s))
(obinseq-p (cddr s))))))
@@ -167,21 +167,19 @@
(cond
((<= i 0) nil)
((<= (obinseq-length s) i) s)
- (t (cond
- ((<= i (obinseq-length (cadr s))) (obinseq-front (cadr s) i))
- (t (obinseq-append
- (cadr s)
- (obinseq-front (cddr s) (- i (obinseq-length (cadr s))))))))))
+ ((<= i (obinseq-length (cadr s))) (obinseq-front (cadr s) i))
+ (t (obinseq-append
+ (cadr s)
+ (obinseq-front (cddr s) (- i (obinseq-length (cadr s))))))))
(defun obinseq-back (s i)
(cond
((<= i 0) nil)
((<= (obinseq-length s) i) s)
- (t (cond
- ((<= i (obinseq-length (cddr s))) (obinseq-back (cddr s) i))
- (t (obinseq-append
- (obinseq-back (cadr s) (- i (obinseq-length (cddr s))))
- (cddr s)))))))
+ ((<= i (obinseq-length (cddr s))) (obinseq-back (cddr s) i))
+ (t (obinseq-append
+ (obinseq-back (cadr s) (- i (obinseq-length (cddr s))))
+ (cddr s)))))
(defun %ohas-index (s i)
(and (<= 0 i) (< i (obinseq-length s))))
Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.9 climacs/Persistent/persistent-buffer.lisp:1.10
--- climacs/Persistent/persistent-buffer.lisp:1.9 Sun Mar 6 00:23:54 2005
+++ climacs/Persistent/persistent-buffer.lisp Sun Mar 13 21:51:53 2005
@@ -36,6 +36,15 @@
(defclass right-sticky-persistent-cursor (persistent-cursor) ())
+(defclass line-cursor-mixin () ()
+ (:documentation "Support for line-oriented buffers."))
+
+(defclass left-sticky-line-persistent-cursor
+ (left-sticky-persistent-cursor line-cursor-mixin) ())
+
+(defclass right-sticky-line-persistent-cursor
+ (right-sticky-persistent-cursor line-cursor-mixin) ())
+
(defmethod cursor-pos ((cursor left-sticky-persistent-cursor))
(1+ (slot-value cursor 'pos)))
@@ -79,13 +88,19 @@
(defclass binseq-buffer (persistent-buffer)
((contents :initform (list-binseq nil)))
(:documentation "An instantiable subclass of PERSISTENT-BUFFER that
-uses a binary sequence for the CONTENTS."))
+uses a binary sequence for the CONTENTS slot."))
(defclass obinseq-buffer (persistent-buffer)
((contents :initform (list-obinseq nil)))
(:documentation "An instantiable subclass of PERSISTENT-BUFFER that
uses an optimized binary sequence (only non-nil atoms are allowed as
-elements) for the CONTENTS."))
+elements) for the CONTENTS slot."))
+
+(defclass binseq2-buffer (persistent-buffer)
+ ((contents :initform (list-binseq2 nil)))
+ (:documentation "An instantiable subclass of PERSISTENT-BUFFER that
+uses a binary sequence for lines and optimized binary sequences for
+line contents, all kept in the CONTENTS slot."))
(defclass p-mark-mixin ()
((buffer :initarg :buffer :reader buffer)
@@ -93,6 +108,10 @@
(:documentation "A mixin class used in the initialization of a mark
that is used in a PERSISTENT-BUFFER."))
+(defclass p-line-mark-mixin (p-mark-mixin) ()
+ (:documentation "A persistent mark mixin class that works with
+cursors that can efficiently work with lines."))
+
(defmethod backward-object ((mark p-mark-mixin) &optional (count 1))
(decf (offset mark) count))
@@ -117,6 +136,14 @@
(:documentation "A RIGHT-STICKY-MARK subclass suitable for use in a
PERSISTENT-BUFFER."))
+(defclass persistent-left-sticky-line-mark (left-sticky-mark p-line-mark-mixin) ()
+ (:documentation "A LEFT-STICKY-MARK subclass with line support,
+suitable for use in a PERSISTENT-BUFFER."))
+
+(defclass persistent-right-sticky-line-mark (right-sticky-mark p-line-mark-mixin) ()
+ (:documentation "A RIGHT-STICKY-MARK subclass with line support,
+suitable for use in a PERSISTENT-BUFFER."))
+
(defmethod initialize-instance :after ((mark persistent-left-sticky-mark)
&rest args &key (offset 0))
"Associates a created mark with the buffer for which it was created."
@@ -143,7 +170,33 @@
:buffer (buffer mark)
:position offset)))
-(defmethod initialize-instance :after ((buffer persistent-buffer) &rest args)
+(defmethod initialize-instance :after ((mark persistent-left-sticky-line-mark)
+ &rest args &key (offset 0))
+ "Associates a created mark with the buffer for which it was created."
+ (declare (ignorable args))
+ (assert (<= 0 offset) ()
+ (make-condition 'motion-before-beginning :offset offset))
+ (assert (<= offset (size (buffer mark))) ()
+ (make-condition 'motion-after-end :offset offset))
+ (setf (slot-value mark 'cursor)
+ (make-instance 'left-sticky-line-persistent-cursor
+ :buffer (buffer mark)
+ :position offset)))
+
+(defmethod initialize-instance :after ((mark persistent-right-sticky-line-mark)
+ &rest args &key (offset 0))
+ "Associates a created mark with the buffer for which it was created."
+ (declare (ignorable args))
+ (assert (<= 0 offset) ()
+ (make-condition 'motion-before-beginning :offset offset))
+ (assert (<= offset (size (buffer mark))) ()
+ (make-condition 'motion-after-end :offset offset))
+ (setf (slot-value mark 'cursor)
+ (make-instance 'right-sticky-line-persistent-cursor
+ :buffer (buffer mark)
+ :position offset)))
+
+(defmethod initialize-instance :after ((buffer binseq-buffer) &rest args)
"Create the low-mark and high-mark."
(declare (ignorable args))
(with-slots (low-mark high-mark) buffer
@@ -151,6 +204,23 @@
(setf high-mark (make-instance 'persistent-right-sticky-mark
:buffer buffer))))
+(defmethod initialize-instance :after ((buffer obinseq-buffer) &rest args)
+ "Create the low-mark and high-mark."
+ (declare (ignorable args))
+ (with-slots (low-mark high-mark) buffer
+ (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer))
+ (setf high-mark (make-instance 'persistent-right-sticky-mark
+ :buffer buffer))))
+
+(defmethod initialize-instance :after ((buffer binseq2-buffer) &rest args)
+ "Create the low-mark and high-mark."
+ (declare (ignorable args))
+ (with-slots (low-mark high-mark) buffer
+ (setf low-mark
+ (make-instance 'persistent-left-sticky-line-mark :buffer buffer))
+ (setf high-mark
+ (make-instance 'persistent-right-sticky-line-mark :buffer buffer))))
+
(defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to)
(cond
((or (null stick-to) (eq stick-to :left))
@@ -171,16 +241,49 @@
:buffer (buffer mark) :offset (offset mark)))
(t (error "invalid value for stick-to"))))
+(defmethod clone-mark ((mark persistent-left-sticky-line-mark)
+ &optional stick-to)
+ (cond
+ ((or (null stick-to) (eq stick-to :left))
+ (make-instance 'persistent-left-sticky-line-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ ((eq stick-to :right)
+ (make-instance 'persistent-right-sticky-line-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ (t (error "invalid value for stick-to"))))
+
+(defmethod clone-mark ((mark persistent-right-sticky-line-mark)
+ &optional stick-to)
+ (cond
+ ((or (null stick-to) (eq stick-to :right))
+ (make-instance 'persistent-right-sticky-line-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ ((eq stick-to :left)
+ (make-instance 'persistent-left-sticky-line-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ (t (error "invalid value for stick-to"))))
+
(defmethod size ((buffer binseq-buffer))
(binseq-length (slot-value buffer 'contents)))
(defmethod size ((buffer obinseq-buffer))
(obinseq-length (slot-value buffer 'contents)))
+(defmethod size ((buffer binseq2-buffer))
+ (binseq2-size (slot-value buffer 'contents)))
+
(defmethod number-of-lines ((buffer persistent-buffer))
(loop for offset from 0 below (size buffer)
count (eql (buffer-object buffer offset) #\Newline)))
+(defmethod number-of-lines ((buffer binseq2-buffer))
+ (let ((len (binseq2-length (slot-value buffer 'contents)))
+ (size (size buffer)))
+ (if (or (eql 0 size)
+ (eq (buffer-object buffer (1- size)) #\Newline))
+ len
+ (max 0 (1- len))))) ; weird?
+
(defmethod mark< ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
(< (offset mark1) (offset mark2)))
@@ -255,6 +358,11 @@
(loop until (beginning-of-line-p mark)
do (decf (offset mark))))
+(defmethod beginning-of-line ((mark p-line-mark-mixin))
+ (setf (offset mark)
+ (binseq2-offset
+ (slot-value (buffer mark) 'contents) (line-number mark))))
+
(defmethod end-of-line ((mark p-mark-mixin))
(let* ((offset (offset mark))
(buffer (buffer mark))
@@ -264,19 +372,40 @@
do (incf offset))
(setf (offset mark) offset)))
+(defmethod end-of-line ((mark p-line-mark-mixin))
+ (let* ((curr-offset (offset mark))
+ (contents (slot-value (buffer mark) 'contents))
+ (next-line-offset (binseq2-offset
+ contents
+ (1+ (binseq2-line2 contents curr-offset)))))
+ (if (> next-line-offset curr-offset)
+ (setf (offset mark) (1- next-line-offset))
+ (setf (offset mark) (size (buffer mark))))))
+
(defmethod buffer-line-number ((buffer persistent-buffer) (offset integer))
(loop for i from 0 below offset
count (eql (buffer-object buffer i) #\Newline)))
+(defmethod buffer-line-number ((buffer binseq2-buffer) (offset integer))
+ (binseq2-line2 (slot-value buffer 'contents) offset))
+
(defmethod line-number ((mark p-mark-mixin))
(buffer-line-number (buffer mark) (offset mark)))
+(defmethod buffer-line-offset ((buffer binseq2-buffer) (line-no integer))
+ (binseq2-offset (slot-value buffer 'contents) line-no))
+
(defmethod buffer-column-number ((buffer persistent-buffer) (offset integer))
(loop for i downfrom offset
while (> i 0)
until (eql (buffer-object buffer (1- i)) #\Newline)
count t))
+(defmethod buffer-column-number ((buffer binseq2-buffer) (offset integer))
+ (- offset
+ (binseq2-offset
+ (slot-value buffer 'contents) (buffer-line-number buffer offset))))
+
(defmethod column-number ((mark p-mark-mixin))
(buffer-column-number (buffer mark) (offset mark)))
@@ -292,24 +421,51 @@
(binseq-insert (slot-value buffer 'contents) offset object)))
(defmethod insert-buffer-object ((buffer obinseq-buffer) offset object)
- (assert (<= 0 offset (size buffer)) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
(setf (slot-value buffer 'contents)
(obinseq-insert (slot-value buffer 'contents) offset object)))
+(defmethod insert-buffer-object ((buffer binseq2-buffer) offset object)
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
+ (setf (slot-value buffer 'contents)
+ (binseq2-insert2 (slot-value buffer 'contents) offset object)))
+
(defmethod insert-object ((mark p-mark-mixin) object)
(insert-buffer-object (buffer mark) (offset mark) object))
(defmethod insert-buffer-sequence ((buffer binseq-buffer) offset sequence)
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
(let ((binseq (vector-binseq sequence)))
(setf (slot-value buffer 'contents)
(binseq-insert* (slot-value buffer 'contents) offset binseq))))
(defmethod insert-buffer-sequence ((buffer obinseq-buffer) offset sequence)
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
(let ((obinseq (vector-obinseq sequence)))
(setf (slot-value buffer 'contents)
(obinseq-insert* (slot-value buffer 'contents) offset obinseq))))
+(defmethod insert-buffer-sequence ((buffer binseq2-buffer) offset sequence)
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
+ (let ((binseq2 (vector-binseq2 sequence)))
+ (setf (slot-value buffer 'contents)
+ (binseq2-insert*2 (slot-value buffer 'contents) offset binseq2))))
+
(defmethod insert-sequence ((mark p-mark-mixin) sequence)
(insert-buffer-sequence (buffer mark) (offset mark) sequence))
@@ -322,11 +478,21 @@
(binseq-remove* (slot-value buffer 'contents) offset n)))
(defmethod delete-buffer-range ((buffer obinseq-buffer) offset n)
- (assert (<= 0 offset (size buffer)) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
(setf (slot-value buffer 'contents)
(obinseq-remove* (slot-value buffer 'contents) offset n)))
+(defmethod delete-buffer-range ((buffer binseq2-buffer) offset n)
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
+ (setf (slot-value buffer 'contents)
+ (binseq2-remove*2 (slot-value buffer 'contents) offset n)))
+
(defmethod delete-range ((mark p-mark-mixin) &optional (n 1))
(cond
((plusp n) (delete-buffer-range (buffer mark) (offset mark) n))
@@ -383,6 +549,21 @@
(setf (slot-value buffer 'contents)
(obinseq-set (slot-value buffer 'contents) offset object)))
+(defmethod buffer-object ((buffer binseq2-buffer) offset)
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (1- (size buffer))) ()
+ (make-condition 'offset-after-end :offset offset))
+ (binseq2-get2 (slot-value buffer 'contents) offset))
+
+(defmethod (setf buffer-object) (object (buffer binseq2-buffer) offset)
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (1- (size buffer))) ()
+ (make-condition 'offset-after-end :offset offset))
+ (setf (slot-value buffer 'contents)
+ (binseq2-set2 (slot-value buffer 'contents) offset object)))
+
(defmethod buffer-sequence ((buffer binseq-buffer) offset1 offset2)
(assert (<= 0 offset1) ()
(make-condition 'offset-before-beginning :offset offset1))
@@ -411,6 +592,21 @@
(if (> len 0)
(obinseq-vector
(obinseq-sub (slot-value buffer 'contents) offset1 len))
+ (make-array 0))))
+
+(defmethod buffer-sequence ((buffer binseq2-buffer) offset1 offset2)
+ (assert (<= 0 offset1) ()
+ (make-condition 'offset-before-beginning :offset offset1))
+ (assert (<= offset1 (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset1))
+ (assert (<= 0 offset2) ()
+ (make-condition 'offset-before-beginning :offset offset2))
+ (assert (<= offset2 (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset2))
+ (let ((len (- offset2 offset1)))
+ (if (> len 0)
+ (binseq2-vector
+ (binseq2-sub2 (slot-value buffer 'contents) offset1 len))
(make-array 0))))
(defmethod object-before ((mark p-mark-mixin))
More information about the Climacs-cvs
mailing list