Update of /project/mcclim/cvsroot/mcclim/Drei/Persistent In directory clnet:/tmp/cvs-serv24994/Drei/Persistent

Added Files: persistent-undo.lisp persistent-buffer.lisp obinseq.lisp binseq2.lisp binseq.lisp binseq-package.lisp README Log Message: Committed Drei.

--- /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-undo.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-undo.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;;

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.

;;; Part of the Undo protocol that works with persistent buffers

(in-package :drei-undo)

(defclass p-undo-mixin () ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree) (undo-accumulate :initform '() :accessor undo-accumulate) (performing-undo :initform nil :accessor performing-undo)))

(defclass p-undo-record (climacs-undo-record) ((contents :initarg :contents)))

(defun save-p-undo-record (buffer) (unless (performing-undo buffer) (push (make-instance 'p-undo-record :buffer buffer :contents (slot-value buffer 'drei-buffer::contents)) (undo-accumulate buffer))))

(defmethod insert-buffer-object :before ((buffer p-undo-mixin) offset object) (declare (ignore offset object)) (save-p-undo-record buffer))

(defmethod insert-buffer-sequence :before ((buffer p-undo-mixin) offset seq) (declare (ignore offset seq)) (save-p-undo-record buffer))

(defmethod delete-buffer-range :before ((buffer p-undo-mixin) offset n) (declare (ignore offset n)) (save-p-undo-record buffer))

(defmethod (setf buffer-object) :before (object (buffer p-undo-mixin) offset) (declare (ignore object offset)) (save-p-undo-record buffer))

(defmethod flip-undo-record ((record p-undo-record)) (with-slots (buffer contents) record (setf (slot-value buffer 'drei-buffer::contents) contents) (drei-buffer::filter-and-update (drei-buffer::cursors buffer) #'(lambda (c) (flexichain::weak-pointer-value c buffer)) #'(lambda (wpc) (setf (cursor-pos wpc) (max 0 (min (cursor-pos wpc) (1- (size buffer)))))))))--- /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-buffer.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-buffer.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;;

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.

;;; A persistent buffer uses a persistent data structure for its ;;; contents, provides cursors into contents, and contains cursors ;;; into the current contents.

(in-package :drei-buffer)

;;; For now, pos contains just an integer, while it might contain a cons ;;; of two adjacent buffer elements for higher performance (with the help ;;; of buffer implementation, especially the rebalancing part). (defclass persistent-cursor () ((buffer :reader buffer :initarg :buffer) ; TODO: fix overlap with mark? (pos :accessor cursor-pos)) (:documentation "The (non-persistent) cursor into PERSISTENT-BUFFER."))

(defclass left-sticky-persistent-cursor (persistent-cursor) ())

(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)))

(defmethod (setf cursor-pos) (position (cursor left-sticky-persistent-cursor)) (assert (<= 0 position (size (buffer cursor))) () "Cursor position out of bounds: ~S, ~S" cursor position) (setf (slot-value cursor 'pos) (1- position)))

(defmethod cursor-pos ((cursor right-sticky-persistent-cursor)) (slot-value cursor 'pos))

(defmethod (setf cursor-pos) (position (cursor right-sticky-persistent-cursor)) (assert (<= 0 position (size (buffer cursor))) () "Cursor position out of bounds: ~S, ~S" cursor position) (setf (slot-value cursor 'pos) position))

(defclass persistent-buffer (buffer) ((low-mark :reader low-mark) (high-mark :reader high-mark) (cursors :accessor cursors :initform nil) (modified :initform nil :reader modified-p)) (:documentation "The Climacs persistent buffer base class (non-instantiable)."))

(defmethod initialize-instance :after ((cursor left-sticky-persistent-cursor) &rest initargs &key (position 0)) (declare (ignorable initargs)) (with-slots (buffer pos) cursor (setf pos (1- position)) (with-slots (cursors) buffer (push (flexichain::make-weak-pointer cursor) cursors))))

(defmethod initialize-instance :after ((cursor right-sticky-persistent-cursor) &rest initargs &key (position 0)) (declare (ignorable initargs)) (with-slots (buffer pos) cursor (setf pos position) (with-slots (cursors) buffer (push (flexichain::make-weak-pointer cursor) cursors))))

(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 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 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) (cursor :reader cursor)) (: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))

(defmethod forward-object ((mark p-mark-mixin) &optional (count 1)) (incf (offset mark) count))

(defmethod offset ((mark p-mark-mixin)) (cursor-pos (cursor mark)))

(defmethod (setf offset) (new-offset (mark p-mark-mixin)) (assert (<= 0 new-offset) () (make-condition 'motion-before-beginning :offset new-offset)) (assert (<= new-offset (size (buffer mark))) () (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset))

(defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) () (:documentation "A LEFT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER."))

(defclass persistent-right-sticky-mark (right-sticky-mark p-mark-mixin) () (: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." (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-persistent-cursor :buffer (buffer mark) :position offset)))

(defmethod initialize-instance :after ((mark persistent-right-sticky-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-persistent-cursor :buffer (buffer mark) :position offset)))

(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 (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 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)) (make-instance 'persistent-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :right) (make-instance 'persistent-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to"))))

(defmethod clone-mark ((mark persistent-right-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'persistent-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :left) (make-instance 'persistent-left-sticky-mark :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)))

(defmethod mark< ((mark1 p-mark-mixin) (mark2 integer)) (< (offset mark1) mark2))

(defmethod mark< ((mark1 integer) (mark2 p-mark-mixin)) (< mark1 (offset mark2)))

(defmethod mark<= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (<= (offset mark1) (offset mark2)))

(defmethod mark<= ((mark1 p-mark-mixin) (mark2 integer)) (<= (offset mark1) mark2))

(defmethod mark<= ((mark1 integer) (mark2 p-mark-mixin)) (<= mark1 (offset mark2)))

(defmethod mark= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (= (offset mark1) (offset mark2)))

(defmethod mark= ((mark1 p-mark-mixin) (mark2 integer)) (= (offset mark1) mark2))

(defmethod mark= ((mark1 integer) (mark2 p-mark-mixin)) (= mark1 (offset mark2)))

(defmethod mark> ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (> (offset mark1) (offset mark2)))

(defmethod mark> ((mark1 p-mark-mixin) (mark2 integer)) (> (offset mark1) mark2))

(defmethod mark> ((mark1 integer) (mark2 p-mark-mixin)) (> mark1 (offset mark2)))

(defmethod mark>= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (>= (offset mark1) (offset mark2)))

(defmethod mark>= ((mark1 p-mark-mixin) (mark2 integer)) (>= (offset mark1) mark2))

(defmethod mark>= ((mark1 integer) (mark2 p-mark-mixin)) (>= mark1 (offset mark2)))

[398 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/obinseq.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/obinseq.lisp 2006/11/08 01:15:32 1.1

[631 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq2.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq2.lisp 2006/11/08 01:15:32 1.1

[1007 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq.lisp 2006/11/08 01:15:32 1.1

[1233 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq-package.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq-package.lisp 2006/11/08 01:15:32 1.1

[1327 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/README 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/README 2006/11/08 01:15:32 1.1

[1337 lines skipped]