Artifact da81804f194a01ef8608ca2eb6f6834e21e262a6f3b708472a245cb81e1ab1da:

• File psl-1983/3-1/nmode/query-replace.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4591) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/nmode/query-replace.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4591) [annotate] [blame] [check-ins using]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% QUERY-REPLACE.SL - Query/Replace command
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        6 July 1982
% Revised:     17 February 1983
%
% 17-Feb-83 Alan Snyder
%  Define backspace to be a synonym for rubout.  Terminate when a non-command
%  character is read and push back the character (like EMACS).
% 9-Feb-83 Alan Snyder
%  Must now refresh since write-message no longer does.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects extended-char fast-int fast-strings))

% Externals used here:

(fluid '(last-search-string nmode-current-buffer))

% Internal static variables:

(fluid '(query-replace-message
	 query-replace-help
	 query-replace-pause-help))

(setf query-replace-message "Query-Replace")
(setf query-replace-help
  (string-concat
   query-replace-message
   " SPACE:yes RUBOUT:no ESC:exit .:yes&exit ,:yes&show !:do all ^:back"
   ))
(setf query-replace-pause-help
  (string-concat
   query-replace-message
   " SPACE:go on ESC:exit !:do all ^:back"
   ))

(de replace-string-command ()
  (let* ((pattern
	  (setf last-search-string
	    (prompt-for-string "Replace string: " last-search-string)))
	 (replacement (prompt-for-string "Replace string with: " NIL))
	 (count 0)
	 (old-pos (buffer-get-position))
	 )
    (while (buffer-search pattern 1)
      (do-string-replacement pattern replacement)
      (setf count (+ count 1))
      )
    (buffer-set-position old-pos)
    (write-prompt (BldMsg "Number of replacements: %d" count))
    ))

(de query-replace-command ()
  (let* ((ask t)
	 ch pattern replacement
	 (pausing nil)
	 (ring-buffer (ring-buffer-create 16))
	 )

    (setf pattern
      (setf last-search-string
        (prompt-for-string
	 "Query Replace (string to replace): "
	 last-search-string
	 )))

    (setf replacement
      (prompt-for-string "Replace string with: " NIL))

    (set-message query-replace-message)
    (while (or pausing (buffer-search pattern 1))
      (if ask
        (progn
	 (cond (pausing
		(nmode-set-immediate-prompt "Command? ")
		)
	       (t
		(ring-buffer-push ring-buffer (buffer-get-position))
		(nmode-set-immediate-prompt "Replace? ")
		))
	 (nmode-refresh)
	 (setf ch (input-terminal-character))
	 (write-prompt "")
	 )
	(setf ch (x-char space)) % if not asking
	)
      (if pausing
	(selectq ch
	  ((#.(x-char space) #.(x-char rubout)
	    #.(x-char backspace) #.(x-char !,))
	   (write-message query-replace-message)
	   (setf pausing nil))
	  (#.(x-char !!)
	   (setf ask nil) (setf pausing nil))
	  ((#.(x-char escape) #.(x-char !.))
	   (exit))
	  (#.(x-char C-L)
	   (nmode-full-refresh))
	  (#.(x-char ^)
	   (ring-buffer-pop ring-buffer)
	   (buffer-set-position (ring-buffer-top ring-buffer)))
	  (#.(x-char ?)
	   (write-message query-replace-pause-help) (next))
	  (t (push-back-input-character ch) (exit))
	  )
	(selectq ch
	  (#.(x-char space)
	   (do-string-replacement pattern replacement))
	  (#.(x-char !,)
	   (do-string-replacement pattern replacement)
	   (write-message query-replace-message)
	   (setf pausing t))
          ((#.(x-char rubout) #.(x-char backspace))
	   (advance-over-string pattern))
	  (#.(x-char !!)
	   (do-string-replacement pattern replacement)
	   (setf ask nil))
	  (#.(x-char !.)
	   (do-string-replacement pattern replacement)
	   (exit))
	  (#.(x-char ?)
	   (write-message query-replace-help) (next))
	  (#.(x-char escape)
	   (exit))
	  (#.(x-char C-L)
	   (nmode-full-refresh))
	  (#.(x-char ^)
	   (ring-buffer-pop ring-buffer)
	   (buffer-set-position (ring-buffer-top ring-buffer))
	   (setf pausing t))
	  (t (push-back-input-character ch) (exit))
	  )
	)
      )
    (reset-message)
    (write-prompt "Query Replace Done.")
    ))

(de do-string-replacement (pattern replacement)

  % Both PATTERN and REPLACEMENT must be single line strings.  PATTERN is
  % assumed to be in the current buffer beginning at POINT.  It is deleted and
  % replaced with REPLACEMENT.  POINT is left pointing just past the inserted
  % text.

  (let ((old-pos (buffer-get-position)))
    (advance-over-string pattern)
    (extract-region T old-pos (buffer-get-position))
    (insert-string replacement)
    ))

(de advance-over-string (pattern)

  % PATTERN must be a single line string.  PATTERN is assumed to be in the
  % current buffer beginning at POINT.  POINT is advanced past PATTERN.

  (let ((pattern-length (string-length pattern)))
    (set-char-pos (+ (current-char-pos) pattern-length))
    ))