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) '()) + ,@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