[climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
Robert Strandh
rstrandh at common-lisp.net
Mon Jan 24 12:49:10 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv3921
Modified Files:
climacs.asd gui.lisp packages.lisp pane.lisp
Log Message:
Implemented undo and redo.
Date: Mon Jan 24 04:49:09 2005
Author: rstrandh
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.13 climacs/climacs.asd:1.14
--- climacs/climacs.asd:1.13 Thu Jan 20 15:21:52 2005
+++ climacs/climacs.asd Mon Jan 24 04:49:08 2005
@@ -59,6 +59,7 @@
"text-syntax"
"kill-ring"
"pane"
+ "undo"
"gui"
;;---- optional ----
"testing/rt"
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.97 climacs/gui.lisp:1.98
--- climacs/gui.lisp:1.97 Sun Jan 23 15:30:34 2005
+++ climacs/gui.lisp Mon Jan 24 04:49:09 2005
@@ -88,6 +88,11 @@
(defmacro current-window () ; shouldn't this be an inlined function? --amb
`(car (windows *application-frame*)))
+(defmethod execute-frame-command :around ((frame climacs) command)
+ (declare (ignore command))
+ (with-undo ((buffer (current-window)))
+ (call-next-method)))
+
(defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
(declare (ignore args))
(let ((buffers (remove-duplicates (mapcar #'buffer (windows frame)))))
@@ -1099,6 +1104,12 @@
(define-named-command com-isearch-exit ()
(setf (isearch-mode (current-window)) nil))
+(define-named-command com-undo ()
+ (undo (undo-tree (buffer (current-window)))))
+
+(define-named-command com-redo ()
+ (redo (undo-tree (buffer (current-window)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Dynamic abbrevs
@@ -1263,6 +1274,8 @@
(c-x-set-key '(#\k) 'com-kill-buffer)
(c-x-set-key '(#\l :control) 'com-load-file)
(c-x-set-key '(#\o) 'com-other-window)
+(c-x-set-key '(#\r) 'com-redo)
+(c-x-set-key '(#\u) 'com-undo)
(c-x-set-key '(#\s :control) 'com-save-buffer)
(c-x-set-key '(#\t :control) 'com-transpose-lines)
(c-x-set-key '(#\w :control) 'com-write-buffer)
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.39 climacs/packages.lisp:1.40
--- climacs/packages.lisp:1.39 Sun Jan 23 15:30:34 2005
+++ climacs/packages.lisp Mon Jan 24 04:49:09 2005
@@ -88,9 +88,16 @@
#:reset-yank-position #:rotate-yank-position #:kill-ring-yank
#:kill-ring-standard-push #:kill-ring-concatenating-push))
+(defpackage :undo
+ (:use :common-lisp)
+ (:export #:no-more-undo
+ #:undo-tree #:standard-undo-tree
+ #:undo-record #:standard-undo-record
+ #:add-undo #:flip-undo-record #:undo #:redo))
+
(defpackage :climacs-pane
(:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev
- :climacs-syntax :flexichain)
+ :climacs-syntax :flexichain :undo)
(:export #:climacs-buffer #:needs-saving #:filename
#:climacs-pane #:point #:mark
#:redisplay-pane #:full-redisplay
@@ -100,9 +107,10 @@
#:auto-fill-mode #:auto-fill-column
#:isearch-state #:search-string #:search-mark #:search-forward-p
#:isearch-mode #:isearch-states #:isearch-previous-string
+ #:with-undo
#:url))
(defpackage :climacs-gui
(:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax
- :climacs-kill-ring :climacs-pane :clim-extensions))
+ :climacs-kill-ring :climacs-pane :clim-extensions :undo))
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.12 climacs/pane.lisp:1.13
--- climacs/pane.lisp:1.12 Sun Jan 23 15:30:35 2005
+++ climacs/pane.lisp Mon Jan 24 04:49:09 2005
@@ -44,6 +44,99 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
+;;; Undo
+
+(defclass 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 climacs-undo-record (standard-undo-record)
+ ((buffer :initarg :buffer)))
+
+(defclass simple-undo-record (climacs-undo-record)
+ ((offset :initarg :offset)))
+
+(defclass insert-record (simple-undo-record)
+ ((objects :initarg :objects)))
+
+(defclass delete-record (simple-undo-record)
+ ((length :initarg :length)))
+
+(defclass compound-record (climacs-undo-record)
+ ((records :initform '() :initarg :records)))
+
+(defmethod print-object ((object delete-record) stream)
+ (with-slots (offset length) object
+ (format stream "[offset: ~a length: ~a]" offset length)))
+
+(defmethod print-object ((object insert-record) stream)
+ (with-slots (offset objects) object
+ (format stream "[offset: ~a objects: ~a]" offset objects)))
+
+(defmethod print-object ((object compound-record) stream)
+ (with-slots (records) object
+ (format stream "[records: ~a]" records)))
+
+(defmethod insert-buffer-object :before ((buffer undo-mixin) offset object)
+ (declare (ignore object))
+ (unless (performing-undo buffer)
+ (push (make-instance 'delete-record
+ :buffer buffer :offset offset :length 1)
+ (undo-accumulate buffer))))
+
+(defmethod insert-buffer-sequence :before ((buffer undo-mixin) offset sequence)
+ (unless (performing-undo buffer)
+ (push (make-instance 'delete-record
+ :buffer buffer :offset offset :length (length sequence))
+ (undo-accumulate buffer))))
+
+
+(defmethod delete-buffer-range :before ((buffer undo-mixin) offset n)
+ (unless (performing-undo buffer)
+ (push (make-instance 'insert-record
+ :buffer buffer :offset offset
+ :objects (buffer-sequence buffer offset (+ offset n)))
+ (undo-accumulate buffer))))
+
+(defmacro with-undo ((buffer) &body body)
+ (let ((buffer-var (gensym)))
+ `(let ((,buffer-var ,buffer))
+ (setf (undo-accumulate ,buffer-var) '())
+ , at body
+ (cond ((null (undo-accumulate ,buffer-var)) nil)
+ ((null (cdr (undo-accumulate ,buffer-var)))
+ (add-undo (car (undo-accumulate ,buffer-var)) (undo-tree ,buffer-var)))
+ (t
+ (add-undo (make-instance 'compound-record :records (undo-accumulate ,buffer-var))
+ (undo-tree ,buffer-var)))))))
+
+(defmethod flip-undo-record :around ((record climacs-undo-record))
+ (with-slots (buffer) record
+ (let ((performing-undo (performing-undo buffer)))
+ (setf (performing-undo buffer) t)
+ (unwind-protect (call-next-method)
+ (setf (performing-undo buffer) performing-undo)))))
+
+(defmethod flip-undo-record ((record insert-record))
+ (with-slots (buffer offset objects) record
+ (change-class record 'delete-record
+ :length (length objects))
+ (insert-buffer-sequence buffer offset objects)))
+
+(defmethod flip-undo-record ((record delete-record))
+ (with-slots (buffer offset length) record
+ (change-class record 'insert-record
+ :objects (buffer-sequence buffer offset (+ offset length)))
+ (delete-buffer-range buffer offset length)))
+
+(defmethod flip-undo-record ((record compound-record))
+ (with-slots (records) record
+ (mapc #'flip-undo-record records)
+ (setf records (nreverse records))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
;;; Isearch
(defclass isearch-state ()
@@ -63,7 +156,7 @@
;(defgeneric indent-tabs-mode (climacs-buffer))
-(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin)
+(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin)
((needs-saving :initform nil :accessor needs-saving)
(syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax)
(indent-tabs-mode :initarg indent-tabs-mode :initform t
More information about the Climacs-cvs
mailing list