[mcclim-cvs] CVS mcclim/Drei/Persistent
thenriksen
thenriksen at common-lisp.net
Wed Nov 8 01:15:32 UTC 2006
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 at 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 at 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]
More information about the Mcclim-cvs
mailing list