[climacs-devel] Multiple Query Replace

[John Q Splittist]

Below is a proof-of-concept Multiple Query Replace and Multiple Query 
Replace From Buffer. I'm assuming that the forthcoming cl-ppcre 
integration (thanks Nicolas!) will change things around a bit in this 
space, and all the Query commands will get refactored as a result. Also, 
the code for reading the search strings from a buffer is even worse than 
my usual efforts...

Multiple Query Replace: prompts for pairs of strings, the first to 
search for, the second to replace it; entering an empty string stops the 
prompting. The command then steps through the buffer and, each time it 
finds one of the search strings, asks you if you want to replace it with 
the relevant replacement string. Thus, to change all the "foo"s to 
"bar"s, and all the "bar"s to "foo"s:
  M-x Multiple Query Replace <return>
  Multiple Query Replace: foo<return>
  Multiple Query Replace foo with: bar<return>
  Multiple Query Replace: bar<return>
  Multiple Query Replace bar with: foo<return>
  Multiple Query Replace: <return>
... and it does its thing. This kind of swapping (or, more generally, 
rotating) can't be done by successive Query Replaces.

But entering a bunch of strings at the prompt can get tedious, so there's:

Multiple Query Replace From Buffer: prompts for a buffer containing 
pairs of strings (words), the first in each pair being the string to 
search for, the second being the string to replace it with. Thus, create 
a buffer "foostrings" with:
  foo bar
  bar baz
  baz foo
swap back to the buffer to rotate these words in,
  M-x Multiple Query Replace From Buffer
  Buffer with Query Replace Strings: foostrings<return>
and away we go.

Any thoughts? This seems such a useful facility I wonder why it isn't in 
  GNU emacs - unless it is and I've just missed it...

(Note that the accept method for buffers always creates a buffer if you 
specify one that doesn't exist: the creation should be factored out into
com-switch-to-buffer etc. When I get the CVS climacs to build I'll do 
that, if no-one beats me to it...)

JQS

In base.lisp [or (in-package :climacs-base)

;;; Multiple search

(defun buffer-looking-at-some (buffer offset list &key (test #'eql))
   "return true if and only if BUFFER contains one of the vectors in 
LIST  at OFFSET"
        (loop for vector in list
	     when (buffer-looking-at buffer offset vector :test test)
	       return vector
	     finally (return nil)))

(defun looking-at-some (mark list &key (test #'eql))
   "return true if and only if BUFFER contains one of the vectors in 
LIST after MARK"
   (buffer-looking-at-some (buffer mark) (offset mark) list :test test))

(defun buffer-search-forward-some (buffer offset list &key (test #'eql))
   "return the smallest offset of BUFFER >= OFFSET containing a vector
from LIST or NIL if no such offset exists"
   (loop for i from offset to (size buffer)
	for vector = (buffer-looking-at-some buffer i list :test test)
	when vector
           return (values i vector)
	finally (return nil)))

(defun search-forward-some (mark list &key (test #'eql))
   "move MARK forward after the first occurence of a vector
in LIST after MARK"
   (multiple-value-bind (offset vector)
       (buffer-search-forward-some
        (buffer mark) (offset mark) list :test test)
     (when offset
       (setf (offset mark) (+ offset (length vector)))
       vector)))

In gui.lisp [or (in-package :climacs-gui)]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Multiple Query Replace

(defun multiple-query-replace-find-next-match (mark list)
   "returns NIL or the vector found from LIST"
   (flet ((object-equal (x y)
            (and (characterp x)
                 (characterp y)
                 (char-equal x y))))
     (climacs-base::search-forward-some mark
				       list
				       :test #'object-equal)))

(define-named-command com-multiple-query-replace ()
   (let (strings string1 string2)
     (loop
        (setf string1 (accept 'string :prompt "Multiple Query Replace"))
        (when (string= "" string1)
	 (return))
        (setf string2 (accept 'string
			     :prompt (format nil "Multiple Query Replace ~A with" string1)))
        (setf strings (acons string1 string2 strings)))
     (multiple-query-replace (nreverse strings))))

(define-named-command com-multiple-query-replace-from-buffer ()
   (let ((buffer (accept 'buffer :prompt "Buffer with Query Replace 
strings")))
     (unless (member buffer (buffers *application-frame*))
       (beep)
       (display-message "~A not an existing buffer" (name buffer))
       (return-from com-multiple-query-replace-from-buffer nil))
     (let* ((words
	    (loop with words = nil
	          with mark1 = (clone-mark (low-mark buffer))
		  with mark2 = (clone-mark (low-mark buffer))
		  for old-mark1-offset = nil then (offset mark1)
		  initially
		   (beginning-of-buffer mark1)
		   (beginning-of-buffer mark2)
		  do
		   (forward-word mark1)
		   (backward-word mark1)
	           (forward-word mark2)
	           (push (coerce (region-to-sequence mark1 mark2) 'string) words)
	           (forward-word mark1)
		  until (eql (offset mark1) old-mark1-offset)
		  finally
		   (return (nreverse (rest words))))))
       (unless (evenp (length words))
	(beep)
	(display-message "Not an even number of words in ~A" (name buffer))
	(return-from com-multiple-query-replace-from-buffer nil))
       (let ((strings
	     (loop for (key value) on words by #'cddr collecting (cons key 
value))))
	(multiple-query-replace strings)))))
	

(defun multiple-query-replace (strings)
   (declare (special strings))
   (let ((occurrences 0))
     (declare (special occurrences))
     (when strings
       (let* ((pane (current-window))
	     (point (point pane))
	     (found (multiple-query-replace-find-next-match point (mapcar #'car 
strings))))
	(when found
	  (setf (query-replace-state pane)
		(make-instance 'query-replace-state
			       :string1 found
			       :string2 (cdr (assoc found strings :test #'string=)))
		(query-replace-mode pane) t)
	  (display-message "Multiple Query Replace ~A with ~A: "
			   (string1 (query-replace-state pane))
			   (string2 (query-replace-state pane)))
	  (simple-command-loop 'multiple-query-replace-climacs-table
			       (query-replace-mode pane)
			       ((setf (query-replace-mode pane) nil))))))
     (display-message "Replaced ~A occurrence~:P" occurrences)))

(define-named-command com-multiple-query-replace-replace ()
   (declare (special strings occurrences))
   (let* ((pane (current-window))
          (point (point pane))
          (buffer (buffer pane))
          (state (query-replace-state pane))
          (string1-length (length (string1 state))))
     (backward-object point string1-length)
     (let* ((offset1 (offset point))
            (offset2 (+ offset1 string1-length))
            (region-case (buffer-region-case buffer offset1 offset2)))
       (delete-range point string1-length)
       (insert-sequence point (string2 state))
       (setf offset2 (+ offset1 (length (string2 state))))
       (finish-output *error-output*)
       (case region-case
         (:upper-case (upcase-buffer-region buffer offset1 offset2))
         (:lower-case (downcase-buffer-region buffer offset1 offset2))
         (:capitalized (capitalize-buffer-region buffer offset1 offset2))))
     (incf occurrences)
     (let ((found (multiple-query-replace-find-next-match point (mapcar 
#'car strings))))
     (cond ((null found)(setf (query-replace-mode pane) nil))
	  (t (setf (query-replace-state pane)
		   (make-instance 'query-replace-state
				  :string1 found
				  :string2 (cdr (assoc found strings :test #'string=))))
	     (display-message "Multiple Query Replace ~A with ~A: "
			      (string1 (query-replace-state pane))
			      (string2 (query-replace-state pane))))))))

(define-named-command com-multiple-query-replace-skip ()
   (declare (special strings))
   (let* ((pane (current-window))
          (point (point pane))
	 (found (multiple-query-replace-find-next-match point (mapcar #'car 
strings))))
     (cond ((null found)(setf (query-replace-mode pane) nil))
	  (t (setf (query-replace-state pane)
		   (make-instance 'query-replace-state
				  :string1 found
				  :string2 (cdr (assoc found strings :test #'string=))))
	     (display-message "Multiple Query Replace ~A with ~A: "
			      (string1 (query-replace-state pane))
			      (string2 (query-replace-state pane)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Multiple query replace command table

(make-command-table 'multiple-query-replace-climacs-table :errorp nil)

(defun multiple-query-replace-set-key (gesture command)
   (add-command-to-command-table command 
'multiple-query-replace-climacs-table
                                 :keystroke gesture :errorp nil))

(multiple-query-replace-set-key '(#\Newline) 'com-query-replace-exit)
(multiple-query-replace-set-key '(#\Space) 
'com-multiple-query-replace-replace)
(multiple-query-replace-set-key '(#\Backspace) 
'com-multiple-query-replace-skip)
(multiple-query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
(multiple-query-replace-set-key '(#\q) 'com-query-replace-exit)
(multiple-query-replace-set-key '(#\y) 'com-multiple-query-replace-replace)
(multiple-query-replace-set-key '(#\n) 'com-multiple-query-replace-skip)