[Phemlock-cvs] CVS update: phemlock/src/new-undo.lisp
Gilbert Baumann
gbaumann at common-lisp.net
Mon Dec 27 18:53:21 UTC 2004
Update of /project/phemlock/cvsroot/phemlock/src
In directory common-lisp.net:/tmp/cvs-serv1172/src
Modified Files:
new-undo.lisp
Log Message:
half-way working undo
Date: Mon Dec 27 19:53:18 2004
Author: gbaumann
Index: phemlock/src/new-undo.lisp
diff -u phemlock/src/new-undo.lisp:1.2 phemlock/src/new-undo.lisp:1.3
--- phemlock/src/new-undo.lisp:1.2 Fri Dec 24 00:58:24 2004
+++ phemlock/src/new-undo.lisp Mon Dec 27 19:53:18 2004
@@ -1,28 +1,78 @@
-(in-package :hemlock-internals)
-
-(defvar *log* nil)
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: HEMLOCK-INTERNALS; -*-
+;;; ---------------------------------------------------------------------------
+;;; Title: Prelimiary Undo
+;;; Created: 2004-12-26
+;;; Author: Gilbert Baumann <gilbert at base-engineering.com>
+;;; License: MIT style (see below)
+;;; ---------------------------------------------------------------------------
+;;; (c) copyright 2004 by Gilbert Baumann
+
+;;; Permission is hereby granted, free of charge, to any person obtaining
+;;; a copy of this software and associated documentation files (the
+;;; "Software"), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;;; TODO
+
+;; - Undo information must be per buffer. And don't record information
+;; on anonymous buffers.
+;; - Record the position of the point too.
+;; - Some form of consolidation
+;; - Redo
+;; - Ensure that what we indentified as a protocol of functions
+;; modifying a buffer is not violated. Both by runtime and compile
+;; time measures.
+;; - Hook into the command processor so that the Undo command undoes
+;; exactly one [user] command.
+;; - Look and Feel:
+;; Find out what different variants of undo are implemented both
+;; with gnu emacs and xemacs, try to simulate those.
+;; - Q: Are there any commands that modify more than one buffer?
+;; (Besides the kill ring and stuff)
+;; - FILTER-REGION (function region) is missing
+;; - (SETF NEXT-CHARACTER) (character mark) is missing
+;; - Don't record undo information of functions that don't modify the
+;; buffer at all.
+
+;; There is this MODIFYING-BUFFER which should enable access to
+;; LINE-NEXT and LINE-PREVIOUS.
+
+;; Instead of putting :command entires onto an undo list, do
+;; undo-chunks directly.
+
+;; Q: Do we need a separate Redo command or should we go the route
+;; that XEmacs follows and make any other command than undo change
+;; the current undo sequence and let subsequent undos really redo
+;; stuff? This is useful but awkward.
+
+;; Also: I really want the self-insert-commands be grouped by words
+;; and not just by 20 characters as the [documented] behaviour of
+;; XEmacs. This also is the observed behavior.
-;;; Ouch! this all isn't _that_ easy.
+;; Find a better place for buffer-undo-list and also provide for
+;; buffers that don't record undo information.
-;; (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)))))
-;;;;
+(in-package :hemlock-internals)
-(defvar *performing-undo* nil)
+;; Unfortunately we need numeric buffer positions. (Hmm, maybe after
+;; all RMS has a point?) Anyhow to graft this onto hemlock we define
+;; two functions MARK-POSITION and POSTION-MARK to convert and back
+;; and fro. Further these new kind of buffer positions are passed
+;; around as (buffer line-number character-position) triples.
(defun mark-position (mark)
(let ((line-no 0)
@@ -34,105 +84,135 @@
(list (line-buffer (mark-line mark))
line-no (mark-charpos mark))))
-;;; below, I am not quite sure about left vs. right inserting --amb
+(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)))
+ (mark line char-pos)))
+
+;;;; buffer-undo-list
+
+(defparameter *bul-hash*
+ (make-hash-table :test #'eq))
+
+(defun buffer-undo-list (buffer)
+ (gethash buffer *bul-hash*) )
+
+(defun (setf buffer-undo-list) (new-value buffer)
+ (setf (gethash buffer *bul-hash*) new-value))
+
+;;;; Insertion
(defmethod insert-character :around (mark character)
- (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*)))))
+ (push `(insert-string ,(mark-position mark) ,(string character))
+ (buffer-undo-list (line-buffer (mark-line mark))))
+ (call-next-method))
(defmethod insert-string :around (mark string &optional (start 0) (end (length string)))
- (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)))
+ (push `(insert-string ,(mark-position mark) ,(subseq string start end))
+ (buffer-undo-list (line-buffer (mark-line mark))))
+ (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*)))))
+ (push `(insert-string ,(mark-position mark) ,(region-to-string region))
+ (buffer-undo-list (line-buffer (mark-line mark))))
+ (call-next-method))
+
+(defmethod ninsert-region :around (mark region)
+ ;; the "n" refers to the region argument.
+ (push `(insert-region ,(mark-position mark) ,(region-to-string region))
+ (buffer-undo-list (line-buffer (mark-line mark))))
+ (call-next-method))
+
+;;;; Deletion
+
+;; We make delete-characters and delete-region both call off to
+;; delete-and-save-region which is the most general method and has the
+;; benefit to return the deleted stuff.
(defmethod delete-characters :around (mark &optional (n 1))
- (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*))))))
+ ;; For now delete-characters just calls delete-region in any case.
+ ;; code borrowed from htext4.lisp
+ (let* ((line (mark-line mark))
+ (charpos (mark-charpos mark))
+ (length (line-length* line)))
+ (setf (mark-line *internal-temp-mark*) line
+ (mark-charpos *internal-temp-mark*) charpos)
+ (let ((other-mark (character-offset *internal-temp-mark* n)))
+ (cond
+ (other-mark
+ (if (< n 0)
+ (setf (region-start *internal-temp-region*) other-mark
+ (region-end *internal-temp-region*) mark)
+ (setf (region-start *internal-temp-region*) mark
+ (region-end *internal-temp-region*) other-mark))
+ (delete-and-save-region *internal-temp-region*)
+ t)
+ (t nil)))))
(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*))))))
+ (delete-and-save-region region))
(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)))))
+ (let ((pos (mark-position (region-start region)))
+ (matter (call-next-method)))
+ (push `(delete-region ,pos ,(region-to-string matter))
+ (buffer-undo-list (car pos)))
+ matter))
-(defun position-mark (buffer line-no char-pos)
- (let ((line (mark-line (buffer-start-mark buffer))))
- (dotimes (i line-no)
- (if line
- (setf line (line-next line))
- (error "Line is NIL")))
- (mark line char-pos)))
\ No newline at end of file
+;;;;
+
+(defvar last-was-undo-p nil)
+(defvar this-is-undo-p nil)
+(defvar undoing-undo-list nil)
+
+(defcommand "New Undo" (p)
+ ""
+ ""
+ (setf this-is-undo-p t)
+ ;; ### pop the "New Undo" log entry
+ (let ((buffer (current-buffer))
+ (undo-list (if last-was-undo-p
+ undoing-undo-list
+ (cddr (buffer-undo-list (current-buffer))))))
+ (block baz
+ (loop
+ (let ((chunk (pop undo-list)))
+ (when (or (eq (car chunk) :command)
+ (null chunk))
+ (message "~S" (cadr chunk))
+ (return-from baz nil))
+ (when (and chunk (consp (cadr chunk)) (eq (car (cadr chunk)) buffer))
+ (case (car chunk)
+ (insert-string
+ (let ((p (cadr chunk))
+ (n (length (caddr chunk))))
+ (let ()
+ (delete-characters (apply #'position-mark p) n)
+
+ )))
+ (delete-region
+ (let ((p (cadr chunk))
+ (matter (caddr chunk)))
+ (let ()
+ (insert-string (apply #'position-mark p) matter)
+ )))
+ (point-position
+ (move-mark (current-point) (apply #'position-mark (cadr chunk)))) )))))
+
+ (setf undoing-undo-list undo-list) ))
+
+(defun new-undo-invoke-hook (command p)
+ (setf this-is-undo-p nil)
+ (setf *b* (current-buffer))
+ (push (list :command command) (buffer-undo-list (current-buffer)))
+ (push (list 'point-position (mark-position (current-point)))
+ (buffer-undo-list (current-buffer))) )
+
+(defparameter *invoke-hook* #'(lambda (command p)
+ (new-undo-invoke-hook command p)
+ (funcall (command-function command) p)
+ (setf last-was-undo-p this-is-undo-p))
+ "This function is called by the command interpreter when it wants to invoke a
+ command. The arguments are the command to invoke and the prefix argument.
+ The default value just calls the Command-Function with the prefix argument.")
More information about the Phemlock-cvs
mailing list