* A prototype of intelligent replace for Emacs
@ 2007-04-29 8:32 Herbert Euler
2007-04-29 18:39 ` Drew Adams
2007-04-30 22:09 ` Richard Stallman
0 siblings, 2 replies; 8+ messages in thread
From: Herbert Euler @ 2007-04-29 8:32 UTC (permalink / raw)
To: emacs-devel
[-- Attachment #1: Type: text/plain, Size: 2774 bytes --]
I saw the following entry in etc/TODO some days ago:
** Implement intelligent search/replace, going beyond query-replace
(see http://graphics.csail.mit.edu/~rcm/chi04.pdf).
I thought I could work on it when reading that. After a few days'
working, I get a prototype. I should have discussed it in this list,
but I found difficulties talking about my thought in English, so the
only way to describe it clearly for me is to write such a prototype.
I apologize for this.
The prototype is attached in this message. It is merely a prototype,
so many features, such as documents, mouse operation supports, more
precise classifications and so on, are not present in it. However, it
works well (at least in my opinion) with keyboard.
To start with it, first load the attached file. To replace text
intelligently, execute M-x ireplace. It will ask for a piece of
text. Another window will be opened to show all classified matches of
text in the buffer that M-x ireplace is executed in, and the cursor
will be moved into this window automatically. I call this buffer the
"ireplace" buffer.
The ireplace buffer contains many classes, classified with some
method. Each of the classes itself contains many "blocks". Classes
and blocks are showed in alternate color, respectively, to help the
user distinguish them. The user can mark several classes and/or
blocks, and then replace text of marked classes and/or blocks with
another text. Then, the user may mark and replace again.
In the ireplace buffer, the user can:
- Type n and p to move through blocks;
- Type M-n and M-p to move through classes;
- Type RET to follow the block, or open/fold a class;
- Type m to mark or de-mark blocks or classes;
- Type r to mark blocks reversely;
- Type M-r to mark classes reversely;
- Type x to perform the replace;
- Type q to close the ireplace buffer.
Please try out the prototype.
As I said, there are many features missed in the prototype:
- User interface re-design;
- Mouse operations;
- Console support;
- More commands;
- More precise classifying algorithm, for many mainstream major
modes;
- Documents and comments in source code;
- Coordination in details;
- Code improvement;
- Emacs convension commits,
and perhaps other things. These are because that I am not sure about
them. Please give me suggestions on those things, I will improve the
prototype. When it becomes stable/mature, I would like to contribute
it into Emacs.
Thanks.
Regards,
Guanpeng Xu
_________________________________________________________________
Express yourself instantly with MSN Messenger! Download today it's FREE!
http://messenger.msn.click-url.com/go/onm00200471ave/direct/01/
[-- Attachment #2: ireplace.el --]
[-- Type: application/octet-stream, Size: 30078 bytes --]
;;; ireplace.el --- intelligent replace for Emacs
;; Copyright (C) 2007 Guanpeng Xu.
;; Maintainer: Guanpeng Xu <herberteuler@hotmail.com>
;; Keywords: intelligent replace
;; This file is not part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
;; Variable definitions.
(defvar ireplace-feature-specs nil
"Specification for computing, comparing and displaying features.")
(make-variable-buffer-local 'ireplace-feature-specs)
(defvar ireplace-classes nil
"All of the classes in buffer `ireplace-original-buffer'.")
(make-variable-buffer-local 'ireplace-classes)
(defvar ireplace-old-window-configuration nil
"The old window configuration.")
(defvar ireplace-original-buffer nil
"The original buffer in which the \\[ireplace] command was invoked.")
(make-variable-buffer-local 'ireplace-original-buffer)
(defvar ireplace-original-buffer-tick nil
"The tick for the original buffer.
See also `buffer-chars-modified-tick'.")
(make-variable-buffer-local 'ireplace-original-buffer-tick)
(defvar ireplace-searched-text nil
"The text searched previously.")
(make-variable-buffer-local 'ireplace-searched-text)
\f
;; The core classifying algorithm.
(defun ireplace-classify-matches (feature-specs
string bound noerror use-regexp)
(let ((matches (ireplace-find-all-matches string bound
noerror use-regexp))
blocks
semi-classes
new-semi-classes
classes)
;; Compute features for each found match to create blocks for the
;; matches.
(dolist (match matches)
(let (features)
(dolist (spec feature-specs)
(setq features
(cons (save-match-data
(funcall (ireplace-spec-feature-computing-function spec)
match))
features)))
;; Perhaps we can avoid making a block here in some cases.
(setq blocks (cons (ireplace-make-block match
(nreverse features)
nil)
blocks))))
;; Classify the blocks.
(setq semi-classes (list blocks))
(dotimes (i (length feature-specs))
(let* ((spec (nth i feature-specs))
(less-than (ireplace-spec-feature-comparing-function spec)))
(dolist (semi-class semi-classes)
(let (this-semi-class
last-feature)
(setq semi-class
(sort semi-class
(lambda (b1 b2)
(funcall less-than
(nth i (ireplace-block-features b1))
(nth i (ireplace-block-features b2))))))
(dolist (block semi-class)
(let ((feature (nth i (ireplace-block-features block))))
(cond ((null last-feature)
(setq this-semi-class (list block)
last-feature feature))
((not (or (funcall less-than last-feature feature)
(funcall less-than feature last-feature)))
(setq this-semi-class (cons block this-semi-class)))
(t
(setq new-semi-classes (cons this-semi-class
new-semi-classes)
this-semi-class (list block)
last-feature feature)))))
(if this-semi-class
(setq new-semi-classes (cons this-semi-class
new-semi-classes)))))
(setq semi-classes new-semi-classes)))
(dolist (semi-class semi-classes)
(setq classes (cons (ireplace-make-class semi-class nil)
classes)))
classes))
(defun ireplace-find-all-matches (string bound noerror use-regexp)
(let ((search-func (if use-regexp
're-search-forward
'search-forward))
matches)
(save-match-data
(save-excursion
(goto-char (point-min))
(while (funcall search-func string bound noerror)
(setq matches (cons (match-data) matches)))))
matches))
\f
;; Features: computation, comparison and display.
(defun ireplace-compute-text-mode-feature (match)
(let (start end)
(set-match-data match)
(save-excursion
(goto-char (match-beginning 0))
(forward-word 1)
(backward-word 1)
(setq start (point))
(goto-char (match-end 0))
(backward-word 1)
(forward-word 1)
(setq end (point)))
(buffer-substring-no-properties start end)))
(defun ireplace-compare-text-mode-features (s1 s2)
(string< s1 s2))
(defun ireplace-display-text-mode-feature (feature)
feature)
(defvar ireplace-text-mode-spec
(list 'ireplace-compute-text-mode-feature
'ireplace-compare-text-mode-features
'ireplace-display-text-mode-feature))
(defun ireplace-spec-feature-computing-function (spec)
(nth 0 spec))
(defun ireplace-spec-feature-comparing-function (spec)
(nth 1 spec))
(defun ireplace-spec-feature-displaying-function (spec)
(nth 2 spec))
\f
;; Block related functions.
(defun ireplace-make-block (match features marked)
(list match features marked))
(defun ireplace-block-match (block)
(nth 0 block))
(defun ireplace-block-features (block)
(nth 1 block))
(defun ireplace-block-marked (block)
(nth 2 block))
(defun ireplace-set-block-marked (block marked)
(setcar (nthcdr 2 block) marked))
(defun ireplace-internal-toggle-block-marked (class block)
(let (marked
marked-removed)
;; Do we need to check whether BLOCK is in CLASS?
(ireplace-set-block-marked block
(not (ireplace-block-marked block)))
(setq marked (mapcar 'ireplace-block-marked
(ireplace-class-blocks class))
marked-removed (remove nil marked))
(cond ((equal marked marked-removed)
(ireplace-set-class-marked class t))
((null marked-removed)
(ireplace-set-class-marked class nil))
(t
(ireplace-set-class-marked class 'partial)))))
\f
;; Class related functions.
(defun ireplace-make-class (blocks marked)
(list blocks marked))
(defun ireplace-class-blocks (class)
(nth 0 class))
(defun ireplace-class-marked (class)
(nth 1 class))
(defun ireplace-set-class-marked (class marked)
(setcar (nthcdr 1 class) marked))
(defun ireplace-internal-toggle-class-marked (class)
(let ((marked (ireplace-class-marked class)))
(setq marked (if (eq marked 'partial)
t
(not marked)))
(dolist (block (ireplace-class-blocks class))
(ireplace-set-block-marked block marked))
(ireplace-set-class-marked class marked)))
\f
;; Display related stuff.
(defface ireplace-match
'((((class color))
(:background "yellow")))
"Face for highlighting matches in the original buffer."
:group 'ireplace)
(defface ireplace-match-marked
'((((class color))
(:background "red")))
"Face for highlighting marked matches in the original buffer."
:group 'ireplace)
(defface ireplace-class-header-1
'((((class color))
(:background "purple1" :foreground "white")))
"Face for non-marked class header line, type I."
:group 'ireplace)
(defface ireplace-class-header-1-partially-marked
'((((class color))
(:background "purple3" :foreground "white")))
"Face for partially marked class header line, type I."
:group 'ireplace)
(defface ireplace-class-header-1-marked
'((((class color))
(:background "purple4" :foreground "white")))
"Face for marked class header line, type I."
:group 'ireplace)
(defface ireplace-class-header-2
'((((class color))
(:background "RoyalBlue1" :foreground "white")))
"Face for non-marked class header line, type II."
:group 'ireplace)
(defface ireplace-class-header-2-partially-marked
'((((class color))
(:background "RoyalBlue3" :foreground "white")))
"Face for partially marked class header line, type II."
:group 'ireplace)
(defface ireplace-class-header-2-marked
'((((class color))
(:background "RoyalBlue4" :foreground "white")))
"Face for marked class header line, type II."
:group 'ireplace)
(defface ireplace-block-1
'((((class color))
(:background "white")))
"Face for non-marked block, type I."
:group 'ireplace)
(defface ireplace-block-1-marked
'((((class color))
(:background "gray66")))
"Face for marked block, type I."
:group 'ireplace)
(defface ireplace-block-2
'((((class color))
(:background "gray87")))
"Face for non-marked block, type II."
:group 'ireplace)
(defface ireplace-block-2-marked
'((((class color))
(:background "gray50")))
"Face for marked block, type II."
:group 'ireplace)
(defun ireplace-get-buffer ()
(get-buffer-create (concat "ireplace-" (buffer-name))))
(defun ireplace-text-info (block)
(let* ((match (ireplace-block-match block))
(buffer (marker-buffer (car match)))
(around-lines-amount 2))
(if (null buffer)
(signal 'ireplace-original-buffer-killed (current-buffer)))
(with-current-buffer buffer
(save-match-data
(set-match-data match)
(let* (continue-moving
(start (save-excursion
(goto-char (match-beginning 0))
(setq continue-moving t)
(dotimes (i around-lines-amount)
(if continue-moving
(forward-line -1))
(unless (< (line-beginning-position)
(line-end-position))
(forward-line 1)
(setq continue-moving nil)))
(line-beginning-position)))
(end (save-excursion
(goto-char (match-end 0))
(setq continue-moving t)
(dotimes (i around-lines-amount)
(if continue-moving
(forward-line 1))
(unless (< (line-beginning-position)
(line-end-position))
(forward-line -1)
(setq continue-moving nil)))
(line-end-position)))
text
overlay-start
overlay-end)
(font-lock-fontify-region start end)
(set-match-data match)
(setq text (buffer-substring start end)
overlay-start (- (match-beginning 0) start)
overlay-end (+ overlay-start
(- (match-end 0) (match-beginning 0))))
(list text overlay-start overlay-end))))))
(defun ireplace-make-circular-list (a b)
(let ((l1 (list a))
(l2 (list b)))
(setcdr l1 l2)
(setcdr l2 l1)
l1))
(defun ireplace-setup-ireplace-buffer (original-buffer
buffer
feature-specs
text
classes
&optional window-configuration)
(let ((tick (buffer-chars-modified-tick))
class-start
(class-faces (ireplace-make-circular-list 'ireplace-class-header-1
'ireplace-class-header-2))
(block-faces (ireplace-make-circular-list 'ireplace-block-1
'ireplace-block-2))
(current 0)
(total (length classes)))
(if window-configuration
(setq ireplace-old-window-configuration window-configuration))
(with-current-buffer buffer
(ireplace-mode)
(setq buffer-read-only nil)
;; Setup buffer local variables.
(setq ireplace-feature-specs feature-specs
ireplace-classes classes
ireplace-original-buffer original-buffer
ireplace-original-buffer-tick tick
ireplace-searched-text text)
;; Insert ireplace information.
(erase-buffer)
(dolist (class ireplace-classes)
(setq current (1+ current)
class-start (point))
;; Insert class header line.
(insert (format "[Class %d of %d] " current total))
(dotimes (i (length ireplace-feature-specs))
(let* ((spec (nth i ireplace-feature-specs))
(display-func (ireplace-spec-feature-displaying-function spec))
(block (car (ireplace-class-blocks class)))
(feature (nth i (ireplace-block-features block))))
(if (> i 0)
(insert ", "))
(insert (funcall display-func feature))))
(add-text-properties class-start (point)
`(face ,(car class-faces) ireplace-show-body on
keymap ,ireplace-header-line-map))
(setq class-faces (cdr class-faces))
;; Insert class body.
(dolist (block (ireplace-class-blocks class))
(let* ((text-info (ireplace-text-info block))
(text (nth 0 text-info))
block-start
match-overlay
(match-overlay-start (nth 1 text-info))
(match-overlay-end (nth 2 text-info))
block-overlay)
(insert ?\n)
(setq block-start (point))
(insert text)
(add-text-properties block-start (point)
`(ireplace-block ,block))
(setq block-overlay (make-overlay block-start (point)))
(overlay-put block-overlay 'ireplace-overlay 'block)
(overlay-put block-overlay 'priority 25)
(overlay-put block-overlay 'face (car block-faces))
(setq match-overlay (make-overlay (+ block-start match-overlay-start)
(+ block-start match-overlay-end)))
(overlay-put match-overlay 'ireplace-overlay 'match)
(overlay-put match-overlay 'priority 50)
(overlay-put match-overlay 'face 'ireplace-match)
(setq block-faces (cdr block-faces))))
(add-text-properties class-start (point) `(ireplace-class ,class))
(insert ?\n))
(setq buffer-read-only t)
(goto-char (point-min)))))
(defun ireplace-text-property-for-current-line (prop
error-symbol
&optional ignore-error)
(let ((val (get-char-property (point) prop)))
(if val
val
(if (bobp)
(unless ignore-error
(signal error-symbol (current-buffer)))
(get-char-property (1- (point)) prop)))))
(defun ireplace-text-property-class (&optional ignore-error)
(ireplace-text-property-for-current-line 'ireplace-class
'ireplace-no-classes
ignore-error))
(defun ireplace-text-property-block (&optional ignore-error)
(ireplace-text-property-for-current-line 'ireplace-block
'ireplace-no-blocks
ignore-error))
(defun ireplace-text-property-show-body (&optional ignore-error)
(ireplace-text-property-for-current-line 'ireplace-show-body
'ireplace-no-classes
ignore-error))
(defun ireplace-text-property-face (&optional ignore-error)
(ireplace-text-property-for-current-line 'face
'ireplace-no-classes
ignore-error))
(defun ireplace-get-overlay (type)
(let ((overlays (overlays-at (point)))
desired)
(dolist (overlay overlays)
(if (eq (overlay-get overlay 'ireplace-overlay) type)
(setq desired overlay)))
desired))
(defun ireplace-remove-all-overlays (type)
(remove-overlays (point-min) (point-max) 'ireplace-overlay type))
(defun ireplace-setup-overlays-in-original-buffer ()
(when (buffer-live-p ireplace-original-buffer)
(save-match-data
(let ((classes ireplace-classes))
(with-current-buffer ireplace-original-buffer
(ireplace-remove-all-overlays 'match)
(dolist (class classes)
(dolist (block (ireplace-class-blocks class))
(set-match-data (ireplace-block-match block))
(let* ((start (match-beginning 0))
(end (match-end 0))
(state (ireplace-block-marked block))
(overlay (make-overlay start end)))
(overlay-put overlay 'ireplace-overlay 'match)
(overlay-put overlay
'face
(ireplace-compute-face 'ireplace-match
state))))))))))
(defun ireplace-header-line-end-position ()
(save-excursion
(ireplace-beginning-of-class)
(if (null (ireplace-text-property-show-body))
(signal 'ireplace-not-on-header-line (point))
(save-excursion
(ireplace-beginning-of-class)
(next-single-property-change (point) 'ireplace-show-body)))))
(defun ireplace-class-beginning-position ()
(save-excursion
(ireplace-end-of-class)
(previous-single-char-property-change (point) 'ireplace-class)))
(defun ireplace-class-end-position ()
(let ((class (ireplace-text-property-class)))
(save-excursion
(if (null class)
;; This can be only at the end of buffer, since
;; `ireplace-text-property-for-current-line', which is
;; called by `ireplace-text-property-class', will signal an
;; error in other cases.
(progn (backward-char)
(point))
(if (get-char-property (point) 'ireplace-class)
(next-single-char-property-change (point) 'ireplace-class)
(point))))))
(defun ireplace-block-beginning-position ()
(save-excursion
(ireplace-end-of-block)
(previous-single-char-property-change (point) 'ireplace-block)))
(defun ireplace-block-end-position ()
(let ((class (ireplace-text-property-class))
(block (ireplace-text-property-block 'ignore-error)))
(save-excursion
(if (null class)
;; This can be only at the end of buffer, since
;; `ireplace-text-property-for-current-line', which is
;; called by `ireplace-text-property-block' and
;; `ireplace-text-property-class', will signal an error in
;; other cases.
(progn (backward-char)
(point))
(if (null block)
(signal 'ireplace-not-on-block (point)))
(if (get-char-property (point) 'ireplace-block)
(next-single-char-property-change (point) 'ireplace-block)
(point))))))
(defun ireplace-compute-face (face state)
(let ((name (replace-regexp-in-string "\\(-partially\\)?-marked$"
""
(symbol-name face))))
(cond ((eq state 'partial)
(intern (concat name "-partially-marked")))
(state
(intern (concat name "-marked")))
(t
(intern name)))))
(defun ireplace-update-class-display (class &optional show-body)
;; Update display for CLASS in the ireplace buffer.
(save-excursion
(ireplace-beginning-of-class)
(let* ((class-state (ireplace-class-marked class))
(header-line-face (ireplace-text-property-face))
(body-invisible (ireplace-text-property-show-body))
(show-body (if show-body
show-body
(ireplace-text-property-show-body)))
buffer-read-only)
(add-text-properties (ireplace-class-beginning-position)
(ireplace-header-line-end-position)
`(face
,(ireplace-compute-face header-line-face
class-state)))
(dotimes (i (length (ireplace-class-blocks class)))
(ireplace-next-block)
(let* ((block (ireplace-text-property-block))
(block-state (ireplace-block-marked block))
(overlay (ireplace-get-overlay 'block))
(block-face (overlay-get overlay 'face)))
(overlay-put overlay 'face (ireplace-compute-face block-face
block-state))))
(cond ((eq show-body 'on)
(setq body-invisible nil))
((eq show-body 'off)
(setq body-invisible t)))
(add-text-properties (ireplace-header-line-end-position)
(ireplace-class-end-position)
`(invisible ,body-invisible))
(add-text-properties (ireplace-class-beginning-position)
(ireplace-header-line-end-position)
`(ireplace-show-body ,show-body))))
;; Update display for CLASS in the original buffer.
(when (buffer-live-p ireplace-original-buffer)
(with-current-buffer ireplace-original-buffer
(save-match-data
(save-excursion
(dolist (block (ireplace-class-blocks class))
(set-match-data (ireplace-block-match block))
(let ((start (match-beginning 0))
(state (ireplace-block-marked block))
overlay)
(goto-char start)
(setq overlay (ireplace-get-overlay 'match))
(overlay-put overlay
'face
(ireplace-compute-face 'ireplace-match state)))))))))
(defun ireplace-refresh ()
(save-excursion
(goto-char (point-min))
(ireplace-beginning-of-class)
(dolist (class ireplace-classes)
(ireplace-update-class-display class)
(ireplace-next-class))))
\f
;; Ireplace errors.
(let ((ireplace-errors '((ireplace-no-blocks
. "No blocks in current buffer")
(ireplace-not-on-block
. "Point is not on a block")
(ireplace-not-on-header-line
. "Point is not on header line of a class")
(ireplace-no-classes
. "No classes in current buffer")
(ireplace-original-buffer-killed
. "The original buffer has been killed"))))
(dolist (spec ireplace-errors)
(let ((symbol (car spec))
(message (cdr spec)))
(put symbol 'error-conditions `(error ireplace-errors ,symbol))
(put symbol 'error-message message))))
\f
;; Ireplace major mode and user operations.
(defvar ireplace-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map t)
(define-key map [?\C-m] 'ireplace-follow-block)
(define-key map [?m] 'ireplace-toggle-block-marked)
(define-key map [?n] 'ireplace-next-block)
(define-key map [?p] 'ireplace-previous-block)
(define-key map [?q] 'ireplace-quit)
(define-key map [?r] 'ireplace-mark-blocks-reversely)
(define-key map [?x] 'ireplace-perform-replace)
(define-key map [?\M-n] 'ireplace-next-class)
(define-key map [?\M-p] 'ireplace-previous-class)
(define-key map [?\M-r] 'ireplace-mark-classes-reversely)
map)
"Keymap for `ireplace-mode'.")
(defvar ireplace-header-line-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map t)
(define-key map [?m] 'ireplace-toggle-class-marked)
(define-key map [?\M-m] 'ireplace-toggle-class-marked)
(define-key map [?\C-m] 'ireplace-toggle-class-body)
(define-key map [?\M-\C-m] 'ireplace-toggle-class-body)
map)
"Keymap for `ireplace-mode', on class header line.")
(define-derived-mode ireplace-mode nil "Intelligent-Replace"
"Major mode for intelligent replace.
\\{ireplace-mode-map}"
:syntax-table nil
:abbrev-table nil
:group 'ireplace
(make-local-variable 'pre-command-hook)
(add-hook 'pre-command-hook 'ireplace-synchronize-with-original-buffer)
(make-local-variable 'post-command-hook)
(add-hook 'post-command-hook 'ireplace-update-original-buffer-position))
(defun ireplace-synchronize-with-original-buffer ()
(let ((buffer (current-buffer))
tick)
(if (buffer-live-p ireplace-original-buffer)
(progn
(with-current-buffer ireplace-original-buffer
(setq tick (buffer-chars-modified-tick)))
(if (not (equal tick ireplace-original-buffer-tick))
(progn
(message "The original buffer has been changed, updating matches...")
(let ((text ireplace-searched-text))
(with-current-buffer ireplace-original-buffer
(let* ((feature-specs (list ireplace-text-mode-spec))
(classes (ireplace-classify-matches feature-specs
text nil t nil)))
(if (null classes)
(message
(format "Text `%s' does not exist in buffer `%s' any more"
text (buffer-name)))
(ireplace-setup-ireplace-buffer (current-buffer)
buffer
feature-specs
text
classes)))))
(ireplace-setup-overlays-in-original-buffer)
(message "The original buffer has been changed, updating matches... done"))
(ireplace-setup-overlays-in-original-buffer)))
(message "The original buffer has been killed"))))
(defun ireplace-update-original-buffer-position ()
(let ((block (ireplace-text-property-block 'ignore-error)))
(when block
(let* ((marker (car (ireplace-block-match block)))
(buffer (marker-buffer marker))
(pos (marker-position marker)))
(when buffer
(let ((ireplace-buffer (current-buffer)))
(pop-to-buffer buffer)
(goto-char pos)
(pop-to-buffer ireplace-buffer)))))))
(defun ireplace-toggle-class-status (switch)
(let ((class (ireplace-text-property-class))
(show-body (ireplace-text-property-show-body)))
(if (or (null class)
(null show-body))
(signal 'ireplace-not-on-header-line (point)))
(cond ((eq switch 'show-body)
(setq show-body (if (eq show-body 'on)
'off
'on)))
((eq switch 'marked)
(ireplace-internal-toggle-class-marked class)))
(ireplace-update-class-display class show-body)))
(defun ireplace-toggle-class-body ()
(interactive)
(ireplace-toggle-class-status 'show-body))
(defun ireplace-toggle-class-marked ()
(interactive)
(ireplace-toggle-class-status 'marked))
(defun ireplace-toggle-block-marked ()
(interactive)
(let ((class (ireplace-text-property-class))
(block (ireplace-text-property-block 'ignore-error)))
(if (or (null class)
(null block))
(signal 'ireplace-not-on-block (point)))
(ireplace-internal-toggle-block-marked class block)
(ireplace-update-class-display class)))
(defun ireplace-mark-classes-reversely ()
(interactive)
(dolist (class ireplace-classes)
(unless (eq (ireplace-class-marked class) 'partial)
(ireplace-internal-toggle-class-marked class)))
(ireplace-refresh))
(defun ireplace-mark-blocks-reversely ()
(interactive)
(let ((class (ireplace-text-property-class)))
(dolist (block (ireplace-class-blocks class))
(ireplace-internal-toggle-block-marked class block))
(ireplace-update-class-display class)))
(defun ireplace-follow-block ()
(interactive)
(let ((block (ireplace-text-property-block)))
(if (null block)
(signal 'ireplace-not-on-block (point)))
(let* ((marker (car (ireplace-block-match block)))
(buffer (marker-buffer marker))
(pos (marker-position marker)))
(if (null buffer)
(signal 'ireplace-original-buffer-killed (current-buffer)))
(pop-to-buffer buffer)
(goto-char pos))))
(defun ireplace-perform-replace (newtext
&optional fixedcase literal string subexp)
(interactive
(progn
(if (not (buffer-live-p ireplace-original-buffer))
(signal 'ireplace-original-buffer-killed (current-buffer)))
(list (read-string "Replace text of marked classes/blocks with: "))))
(let ((classes ireplace-classes)
new-classes)
(with-current-buffer ireplace-original-buffer
(save-match-data
(save-excursion
(dolist (class classes)
(let ((blocks (ireplace-class-blocks class))
new-blocks)
(dolist (block blocks)
(if (ireplace-block-marked block)
(let ((match (ireplace-block-match block))
overlay)
(set-match-data match)
(goto-char (match-beginning 0))
(setq overlay (ireplace-get-overlay 'match))
(delete-overlay overlay)
(replace-match newtext fixedcase literal string subexp))
(setq new-blocks (cons block new-blocks))))
(if new-blocks
(setq new-classes (cons (ireplace-make-class new-blocks nil)
new-classes))))))))
(ireplace-setup-ireplace-buffer ireplace-original-buffer
(current-buffer)
ireplace-feature-specs
ireplace-searched-text
new-classes)))
(defun ireplace (text)
(interactive (list (read-string "Text for replacing: ")))
(let* ((feature-specs (list ireplace-text-mode-spec))
(classes (ireplace-classify-matches feature-specs text nil t nil)))
(if (null classes)
(message (format "Text `%s' does not exist in current buffer" text))
(let ((buffer (ireplace-get-buffer)))
(ireplace-setup-ireplace-buffer (current-buffer)
buffer
feature-specs
text
classes
(current-window-configuration))
(delete-other-windows)
(split-window-vertically)
(other-window 1)
(switch-to-buffer buffer)
(ireplace-setup-overlays-in-original-buffer)
(message (format "Found %d classes totally"
(length ireplace-classes)))))))
(defun ireplace-quit ()
(interactive)
(if (buffer-live-p ireplace-original-buffer)
(with-current-buffer ireplace-original-buffer
(ireplace-remove-all-overlays 'match)))
(set-window-configuration ireplace-old-window-configuration)
(message ""))
(defun ireplace-beginning-of-class ()
(interactive)
(goto-char (ireplace-class-beginning-position)))
(defun ireplace-end-of-class ()
(interactive)
(goto-char (ireplace-class-end-position)))
(defun ireplace-beginning-of-block ()
(interactive)
(goto-char (ireplace-block-beginning-position)))
(defun ireplace-end-of-block ()
(interactive)
(goto-char (ireplace-block-end-position)))
(defun ireplace-previous-class ()
(interactive)
(let ((on-header-line (ireplace-text-property-show-body)))
(ireplace-beginning-of-class)
(when (and on-header-line
(not (bobp)))
(backward-char)
(ireplace-beginning-of-class))))
(defun ireplace-next-class ()
(interactive)
(ireplace-end-of-class)
(when (not (eobp))
(forward-char)
(ireplace-end-of-class))
(ireplace-beginning-of-class))
(defun ireplace-previous-block-1 ()
(let (do-not-move-again)
(condition-case nil
(ireplace-beginning-of-block)
(ireplace-not-on-block
(ireplace-beginning-of-class)
(if (bobp)
;; Point was on header line of the first class in current
;; buffer.
(goto-char (1+ (ireplace-header-line-end-position)))
;; Point was on header line of some class but the first one
;; in current buffer.
(ireplace-previous-class)
(ireplace-end-of-class)
(ireplace-beginning-of-block))
(setq do-not-move-again t))
(error
(signal 'ireplace-no-blocks (current-buffer))))
do-not-move-again))
(defun ireplace-previous-block ()
(interactive)
(let ((do-not-move-again (ireplace-previous-block-1)))
(unless do-not-move-again
(backward-char)
(ireplace-previous-block-1))))
(defun ireplace-next-block ()
(interactive)
(condition-case nil
(progn
(ireplace-end-of-block)
(forward-char)
(ireplace-end-of-block)
(ireplace-beginning-of-block))
(ireplace-not-on-block
;; Point was previously on class header line.
(goto-char (1+ (ireplace-header-line-end-position))))
(error
(signal 'ireplace-no-blocks (current-buffer)))))
\f
(provide 'ireplace)
;;; ireplace.el ends here
[-- Attachment #3: Type: text/plain, Size: 142 bytes --]
_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel
^ permalink raw reply [flat|nested] 8+ messages in thread
* RE: A prototype of intelligent replace for Emacs
2007-04-29 8:32 A prototype of intelligent replace for Emacs Herbert Euler
@ 2007-04-29 18:39 ` Drew Adams
2007-05-05 2:29 ` Herbert Euler
2007-04-30 22:09 ` Richard Stallman
1 sibling, 1 reply; 8+ messages in thread
From: Drew Adams @ 2007-04-29 18:39 UTC (permalink / raw)
To: Herbert Euler, emacs-devel
> The prototype is attached in this message.
I like it.
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: A prototype of intelligent replace for Emacs
2007-04-29 8:32 A prototype of intelligent replace for Emacs Herbert Euler
2007-04-29 18:39 ` Drew Adams
@ 2007-04-30 22:09 ` Richard Stallman
2007-05-05 2:30 ` Herbert Euler
1 sibling, 1 reply; 8+ messages in thread
From: Richard Stallman @ 2007-04-30 22:09 UTC (permalink / raw)
To: Herbert Euler; +Cc: emacs-devel
The concept of "classes" and "blocks" sounds rather complex. In order
to install such a feature, we would have to document it. At present,
I don't understand it myself.
Could you give an example to explain what that means?
^ permalink raw reply [flat|nested] 8+ messages in thread
* RE: A prototype of intelligent replace for Emacs
2007-04-29 18:39 ` Drew Adams
@ 2007-05-05 2:29 ` Herbert Euler
0 siblings, 0 replies; 8+ messages in thread
From: Herbert Euler @ 2007-05-05 2:29 UTC (permalink / raw)
To: drew.adams, emacs-devel
> > The prototype is attached in this message.
>
>I like it.
Thank you. Any advices are appreciated.
Best wishes,
Guanpeng Xu
_________________________________________________________________
FREE pop-up blocking with the new MSN Toolbar - get it now!
http://toolbar.msn.click-url.com/go/onm00200415ave/direct/01/
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: A prototype of intelligent replace for Emacs
2007-04-30 22:09 ` Richard Stallman
@ 2007-05-05 2:30 ` Herbert Euler
2007-05-05 23:18 ` Richard Stallman
0 siblings, 1 reply; 8+ messages in thread
From: Herbert Euler @ 2007-05-05 2:30 UTC (permalink / raw)
To: rms; +Cc: emacs-devel
Sorry for the delay. I went travel these days and I could not connect
to net.
>The concept of "classes" and "blocks" sounds rather complex. In order
>to install such a feature, we would have to document it. At present,
>I don't understand it myself.
>
>Could you give an example to explain what that means?
Sure. The reason I did not write comment/document in the attached
source code is that, the user interface included in the prototype is
in unstable status, and it may be changed hugely to satisfy most
people. In such a progress, the written comment/document must be
updated, which in my opinion is not so easy for the sake of
consistency. So I do not want to maintain both the code and the
comment/document when they are unstable, and I was deciding to
postpone them until the prototype is stable. I am sorry for this.
Now I am going to try to explain the concept of "blocks" and
"classes". These concepts are defined in the search phase of a
search/replace process. When a word is searched in a document, many
matches may be found in it. "Blocks" and "classes" are defined based
on the matches.
To define "block" and "class", the concept of "feature" has to be
introduced first. A _feature_ of a match is a value, computed from
the context of the match and a predefined rule. A restriction to
features computed from a same rule is that they must be able to be
compared. Features can be strings, or integers. For example, rule A
could be "a feature of a match is the shortest word sequence that
contains the match". Now suppose the word "at" is searched in a
document. Three matches are found, the first is "status", the second
is "match", and the third is "status" again. Under rule A, the
feature of the first and the third match is "status", since the
shortest word sequence that contains the match "at" is the sequence
"status". Similarly, the feature for the second match is the word
"match". In this example, both word sequences consist of only one
word. If another word "a b" is searched under rule A, the word
sequences may consist of more than one word.
If there are many different rules, many features can be computed for a
match. Because features computed from a same rule can be compared,
matches can be classified, or grouped together, with their features.
This is based on similarity among the matches. Now the concept of
"block" and "class" can be defined. A _block_ is a match plus its
features. A _class_ is a set of blocks, all of which have the same
features. Continuing from the previous example, since the first and
the third block have the same feature "status", they are in one class.
The second block is a class itself.
Now let us go back to the search/replace topic. When the user wants
to replace A with B in a document, it can invoke `replace-string' to
replace all matches of A with B, or invoke `query-replace' to replace
matches of A with B one by one, by answering `y' or `n' on each of the
matches. As described in the paper Cluster-Based Find and Replace by
Robert C. Miller and Alisa M. Marshall (1), another approach,
replacing several matches at one time by similarity, is faster and
more reliable, provided the predefined rules are carefully defined.
The prototype "ireplace" tries to implement such a search/replace
mechanism for Emacs, with the concept of "blocks" and "classes".
Currently, there is only one feature for every match in the prototype:
the shortest word sequence that contains the match. In the ireplace
buffer, the feature of the blocks in a class is displayed after the
class number (i.e. [Class m of n]). Defining proper rules is
important future work. For example, another rule of computing
features for matches in program source code could be the section
(separated by ^L) a match appears in, or the type (variable, function,
and so on) of a match.
I hope I explained clearly. In fact, because English is not my native
language, I chose the words "feature", "block", and "class" at will.
I am not sure how to call them in English. But since you found them
complex, perhaps I should change them to clearer names. What do you
think are better names? Thanks.
And both the user interface and the concepts are needing to be checked
now.
Regards,
Guanpeng Xu
(1) Web link: http://graphics.csail.mit.edu/~rcm/chi04.pdf
_________________________________________________________________
FREE pop-up blocking with the new MSN Toolbar - get it now!
http://toolbar.msn.click-url.com/go/onm00200415ave/direct/01/
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: A prototype of intelligent replace for Emacs
2007-05-05 2:30 ` Herbert Euler
@ 2007-05-05 23:18 ` Richard Stallman
2007-05-06 15:01 ` Herbert Euler
0 siblings, 1 reply; 8+ messages in thread
From: Richard Stallman @ 2007-05-05 23:18 UTC (permalink / raw)
To: Herbert Euler; +Cc: emacs-devel
If there are many different rules, many features can be computed for a
match. Because features computed from a same rule can be compared,
matches can be classified, or grouped together, with their features.
This is based on similarity among the matches. Now the concept of
"block" and "class" can be defined. A _block_ is a match plus its
features. A _class_ is a set of blocks, all of which have the same
features. Continuing from the previous example, since the first and
the third block have the same feature "status", they are in one class.
The second block is a class itself.
Now I understand. Can we find a simple way to present this?
The term "block" is not appropriate. It should be called a "match".
There is no reason why a "match" can't include these features.
"Class" would be come clear if introduced as "class of like matches".
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: A prototype of intelligent replace for Emacs
2007-05-05 23:18 ` Richard Stallman
@ 2007-05-06 15:01 ` Herbert Euler
2007-05-06 22:26 ` Richard Stallman
0 siblings, 1 reply; 8+ messages in thread
From: Herbert Euler @ 2007-05-06 15:01 UTC (permalink / raw)
To: rms; +Cc: emacs-devel
> If there are many different rules, many features can be computed for a
> match. Because features computed from a same rule can be compared,
> matches can be classified, or grouped together, with their features.
> This is based on similarity among the matches. Now the concept of
> "block" and "class" can be defined. A _block_ is a match plus its
> features. A _class_ is a set of blocks, all of which have the same
> features. Continuing from the previous example, since the first and
> the third block have the same feature "status", they are in one class.
> The second block is a class itself.
>
>Now I understand. Can we find a simple way to present this?
>
>The term "block" is not appropriate. It should be called a "match".
>There is no reason why a "match" can't include these features.
It is Ok for me that a "match" includes features as well, but "match"
is not a good term for this purpose, since "match" is already used to
indicate matches without features in Emacs. Calling a match with
features "match" too would perhaps disorder names in the source code:
we already have `save-match-data', `set-match-data', `match-beginning'
etc in it, and people may be confused by the two different meanings of
the same term "match".
But they are indeed matches. How about call them "imatch", the
"i(replace) match", and document it well?
>"Class" would be come clear if introduced as "class of like matches".
This is true. Then should I use the word "class" in the source code,
and use the term "class of like matches" in the document?
`class-of-like-matches' is too long for a name in program, after all.
Thanks.
Regards,
Guanpeng Xu
_________________________________________________________________
FREE pop-up blocking with the new MSN Toolbar - get it now!
http://toolbar.msn.click-url.com/go/onm00200415ave/direct/01/
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: A prototype of intelligent replace for Emacs
2007-05-06 15:01 ` Herbert Euler
@ 2007-05-06 22:26 ` Richard Stallman
0 siblings, 0 replies; 8+ messages in thread
From: Richard Stallman @ 2007-05-06 22:26 UTC (permalink / raw)
To: Herbert Euler; +Cc: emacs-devel
It is Ok for me that a "match" includes features as well, but "match"
is not a good term for this purpose, since "match" is already used to
indicate matches without features in Emacs.
Don't worry about it. Using that meaning for "match" in this file
is fine if you explain it clearly.
This is true. Then should I use the word "class" in the source code,
and use the term "class of like matches" in the document?
That is good.
^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2007-05-06 22:26 UTC | newest]
Thread overview: 8+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2007-04-29 8:32 A prototype of intelligent replace for Emacs Herbert Euler
2007-04-29 18:39 ` Drew Adams
2007-05-05 2:29 ` Herbert Euler
2007-04-30 22:09 ` Richard Stallman
2007-05-05 2:30 ` Herbert Euler
2007-05-05 23:18 ` Richard Stallman
2007-05-06 15:01 ` Herbert Euler
2007-05-06 22:26 ` Richard Stallman
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).