[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