Update of /project/phemlock/cvsroot/phemlock/src In directory common-lisp.net:/tmp/cvs-serv12917/src

Modified Files: new-undo.lisp Log Message: Identified initial, partial "undo protocol".

Date: Fri Dec 24 00:58:26 2004 Author: abakic

Index: phemlock/src/new-undo.lisp diff -u phemlock/src/new-undo.lisp:1.1.1.1 phemlock/src/new-undo.lisp:1.2 --- phemlock/src/new-undo.lisp:1.1.1.1 Fri Jul 9 15:37:45 2004 +++ phemlock/src/new-undo.lisp Fri Dec 24 00:58:24 2004 @@ -4,24 +4,26 @@

;;; Ouch! this all isn't _that_ easy.

-(defmacro add-logging (attr) - `(defmethod (setf ,attr) :around (new-value line) - (let ((old (,attr line))) - (push `(,',attr ,line ,old ,new-value) *log*)) - (call-next-method))) - -(add-logging line-previous) -(add-logging line-next) -(add-logging mark-line) - -(defun dada () - (let ((log *log*) - (*log* nil)) - (dolist (k log) - (destructuring-bind (slot object old new) k - (funcall (fdefinition `(setf ,slot)) old object))))) +;; (defmacro add-logging (attr) +;; `(defmethod (setf ,attr) :around (new-value line) +;; (let ((old (,attr line))) +;; (push `(,',attr ,line ,old ,new-value) *log*)) +;; (call-next-method))) + +;; (add-logging line-previous) +;; (add-logging line-next) +;; (add-logging mark-line) + +;; (defun dada () +;; (let ((log *log*) +;; (*log* nil)) +;; (dolist (k log) +;; (destructuring-bind (slot object old new) k +;; (funcall (fdefinition `(setf ,slot)) old object))))) ;;;;

+(defvar *performing-undo* nil) + (defun mark-position (mark) (let ((line-no 0) (line (mark-line mark))) @@ -32,30 +34,105 @@ (list (line-buffer (mark-line mark)) line-no (mark-charpos mark))))

+;;; below, I am not quite sure about left vs. right inserting --amb + (defmethod insert-character :around (mark character) - (push `(insert-character ,(mark-position mark) ,character) - *log*) - (call-next-method)) + (with-mark ((start mark :right-inserting)) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) + (push `(delete-characters ,(mark-position start)) *log*)))))

(defmethod insert-string :around (mark string &optional (start 0) (end (length string))) - (push `(insert-string ,(mark-position mark) ,(subseq string start end)) - *log*) - (call-next-method)) + (if (car (mark-position mark)) ; used with kill-ring? + (progn + (with-mark ((start mark :right-inserting) + (end mark :left-inserting)) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) + (push + `(delete-region ,(mark-position start) ,(mark-position end)) + *log*))))) + (call-next-method))) + +(defmethod insert-region :around (mark region) + (with-mark ((start mark :right-inserting) + (end mark :left-inserting)) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) + (push + `(delete-region ,(mark-position start) ,(mark-position end)) + *log*)))))

(defmethod delete-characters :around (mark &optional (n 1)) - (push `(delete-characters ,(mark-position mark) ,n) - *log*) - (call-next-method)) - -(defun dada (q) - (dolist (k q) - (ecase (car k) - (insert-character - (destructuring-bind ((buffer line-no char-pos) char) (cdr k) - (delete-characters (position-mark buffer line-no char-pos))))))) + (with-mark ((start mark :right-inserting) + (end mark :left-inserting)) + (character-offset end n) + (let ((string (region-to-string (region start end)))) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) + (push + `(insert-string ,(mark-position start) ,string) + *log*)))))) + +(defmethod delete-region :around (region) + (with-mark ((start (region-start region) :right-inserting) + (end (region-end region) :left-inserting)) + (let ((string (region-to-string region))) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line (region-start region))) + *echo-area-buffer*)) + (push + `(insert-string ,(mark-position start) ,string) + *log*)))))) + +(defmethod delete-and-save-region :around (region) + (with-mark ((start (region-start region) :right-inserting) + (end (region-end region) :left-inserting)) + (let ((string (region-to-string region))) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line (region-start region))) + *echo-area-buffer*)) + (push + `(insert-string ,(mark-position start) ,string) + *log*)))))) + +(defun dada () + (let ((*performing-undo* t)) + (do ((k (pop *log*) (pop *log*))) + ((null k)) + (undo k)))) + +(defun undo (k) + (ecase (car k) + (delete-characters + (destructuring-bind ((buffer line-no char-pos)) (cdr k) + (delete-characters (position-mark buffer line-no char-pos)))) + (delete-region + (destructuring-bind ((buffer1 line-no1 char-pos1) + (buffer2 line-no2 char-pos2)) (cdr k) + (delete-region + (region (position-mark buffer1 line-no1 char-pos1) + (position-mark buffer2 line-no2 char-pos2))))) + (insert-string + (destructuring-bind ((buffer line-no char-pos) string) (cdr k) + (insert-string (position-mark buffer line-no char-pos) string)))))

(defun position-mark (buffer line-no char-pos) (let ((line (mark-line (buffer-start-mark buffer)))) (dotimes (i line-no) - (setf line (line-next line))) + (if line + (setf line (line-next line)) + (error "Line is NIL"))) (mark line char-pos)))