reduce-historical/psl-1983/nmode/kill-commands.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Kill-Commands.SL - NMODE Kill and Delete commands
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        23 August 1982
% Revised:     16 November 1982
%
% 16-Nov-82 Alan Snyder
%   Modified C-Y and M-Y to obey comamnd argument.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects fast-vectors fast-int))
(load gsort)

(fluid '(nmode-current-buffer nmode-command-argument
	 nmode-command-argument-given nmode-command-number-given
	 nmode-previous-command-killed nmode-command-killed
	 ))

% Internal static variables:

(fluid '(nmode-kill-ring))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de nmode-initialize-kill-ring ()
  (setf nmode-kill-ring (ring-buffer-create 16))
  (setf nmode-command-killed NIL)
  )

(de insert-kill-buffer ()
  % Insert the specified "kill buffer" into the buffer at the current location.
  (cond
   ((<= nmode-command-argument 0)
    (Ding))
   (nmode-command-number-given
    (insert-from-kill-ring (+ (- nmode-command-argument) 1) NIL))
   (nmode-command-argument-given
    (insert-from-kill-ring 0 T))
   (t
    (insert-from-kill-ring 0 NIL))
   ))
   
(de insert-from-kill-ring (index flip-positions)
  (insert-text-safely (=> nmode-kill-ring fetch index) flip-positions)
  )

(de insert-text-safely (text flip-positions)
  (cond (text
	 (=> nmode-current-buffer set-mark-from-point)
	 (insert-text text)
	 (when flip-positions (exchange-point-and-mark))
	 )
	(t (Ding))
	))

(de safe-to-unkill ()
  % Return T if the current region contains the same text as the current
  % kill buffer.

  (let ((killed-text (ring-buffer-top nmode-kill-ring))
	(region (extract-text NIL (buffer-get-position) (current-mark)))
	)
    (and killed-text (text-equal killed-text region))
    ))

(de unkill-previous ()
  % Delete (without saving away) the current region, and then unkill (yank) the
  % specified entry in the kill ring.  "Ding" if the current region does not
  % contain the same text as the current entry in the kill ring.

  (cond ((not (safe-to-unkill))
	 (Ding))
	((= nmode-command-argument 0)
	 (extract-region T (buffer-get-position) (current-mark)))
	(t
	 (extract-region T (buffer-get-position) (current-mark))
	 (=> nmode-kill-ring rotate (- nmode-command-argument))
	 (insert-from-kill-ring 0 NIL)
	 )
	))

(de update-kill-buffer (kill-info)
  % Update the "kill buffer", either appending/prepending to the current
  % buffer, or "pushing" the kill ring, as appropriate.  kill-info is a pair,
  % the car of which is +1 if the text was "forward killed", and -1 if
  % "backwards killed".  The cdr is the actual text (a vector of strings).

  (let ((killed-text (cdr kill-info))
	(dir (car kill-info))
	)
    (if (not nmode-previous-command-killed)
      % If previous command wasn't a kill, then "push" the new text.
      (ring-buffer-push nmode-kill-ring killed-text)
      % Otherwise, append or prepend the text, as appropriate.
      (let ((text (ring-buffer-top nmode-kill-ring)))
        % Swap the two pieces of text if deletion was "backwards".
	(if (< dir 0) (psetf text killed-text killed-text text))
	% Replace text with the concatenation of the two.
	(ring-buffer-pop nmode-kill-ring)
	(ring-buffer-push nmode-kill-ring (text-append text killed-text))
	))))

(de text-append (t1 t2)
  % Append two text-vectors.
  % The last line of T1 is concatenated with the first line of T2.
  (let ((text (MkVect (+ (vector-upper-bound t1) (vector-upper-bound t2))))
	(ti 0) % index into TEXT
	)
    (for (from i 0 (- (vector-upper-bound t1) 1))
	 (do (vector-store text ti (vector-fetch t1 i))
	     (setf ti (+ ti 1))
	     ))
    (vector-store text ti
      (string-concat (vector-fetch t1 (vector-upper-bound t1))
		     (vector-fetch t2 0)))
    (setf ti (+ ti 1))
    (for (from i 1 (vector-upper-bound t2))
	 (do (vector-store text ti (vector-fetch t2 i))
	     (setf ti (+ ti 1))
	     ))
    text))

(de text-equal (t1 t2)
  % Compare two text vectors for equality.
  (let ((limit (vector-upper-bound t1)))
    (and (= limit (vector-upper-bound t2))
	 (for (from i 0 limit)
	      (always (string= (vector-fetch t1 i) (vector-fetch t2 i)))
	      ))))

(de kill-region ()
  % Kill (and save in kill buffer) the region between point and mark.
  (update-kill-buffer (extract-region T (buffer-get-position) (current-mark)))
  (setf nmode-command-killed T)
  )

(de copy-region ()
  (update-kill-buffer (extract-region NIL (buffer-get-position) (current-mark)))
  )

(de append-to-buffer-command ()
  (let* ((text (cdr (extract-region NIL (buffer-get-position) (current-mark))))
	 (b (prompt-for-buffer "Append Region to Buffer: " NIL))
	 )
    (=> b insert-text text)
    ))

(de prompt-for-register-name (prompt)
  % Prompt for the name of a "Register", which must be a letter
  % or a digit.  Return the corresponding Lisp Symbol.  Return NIL
  % if an invalid name is given.

  (nmode-set-delayed-prompt prompt)
  (let ((ch (input-base-character)))
    (cond ((AlphaNumericP ch)
	   (intern (string-concat "nmode-register-" (string ch))))
	  (t (Ding) NIL))))

(de put-register-command ()
  (let ((register (prompt-for-register-name
		   (if nmode-command-argument-given
		       "Withdraw Region to Register: "
		       "Copy Region to Register: "))))
    (cond (register
	   (set register (cdr (extract-region nmode-command-argument-given
					      (buffer-get-position)
					      (current-mark))))
	   ))))

(de get-register-command ()
  (let ((register (prompt-for-register-name "Insert from Register: "))
	(old-pos (buffer-get-position))
	)
    (cond (register
	   (cond ((BoundP register)
		  (insert-text (ValueCell register))
		  (set-mark-from-point)
		  (buffer-set-position old-pos)
		  (if nmode-command-argument-given
		      (exchange-point-and-mark))
		  )
		 (t (Ding))
		 )))))

(de append-next-kill-command ()
  (if (ring-buffer-top nmode-kill-ring) % If there is a kill buffer...
    (setf nmode-command-killed T)
    ))

(de kill-line ()
  (let ((old-pos (buffer-get-position)))
    (if nmode-command-argument-given
      (cond ((> nmode-command-argument 0)
	     % Kill through that many line terminators
	     (for (from i 1 nmode-command-argument)
		  (do (move-to-next-line)))
	     )
	    ((= nmode-command-argument 0)
	     % Kill preceding text on this line
	     (move-to-start-of-line)
	     )
	    (t
	     % Kill through that many previous line starts
	     % This line counts only if we are not at the beginning of it.
	     (if (not (at-line-start?))
		(progn
		  (move-to-start-of-line)
		  (setf nmode-command-argument (+ nmode-command-argument 1))
		  ))
	     (for (from i 1 (- nmode-command-argument))
		  (do (move-to-previous-line)))
	     ))
      % else (no argument given)
      (while (char-blank? (next-character))
	(move-forward))
      (if (at-line-end?)
        (move-to-next-line)
        (move-to-end-of-line)
        )
      )
    (update-kill-buffer (extract-region T old-pos (buffer-get-position)))
    (setf nmode-command-killed T)
    ))

(de kill-forward-word-command ()
  (delete-words nmode-command-argument)
  (setf nmode-command-killed T)
  )

(de kill-backward-word-command ()
  (delete-words (- nmode-command-argument))
  (setf nmode-command-killed T)
  )

(de kill-forward-form-command ()
  (delete-forms nmode-command-argument)
  (setf nmode-command-killed T)
  )

(de kill-backward-form-command ()
  (delete-forms (- nmode-command-argument))
  (setf nmode-command-killed T)
  )

(de delete-backward-character-command ()
  (cond 
    (nmode-command-argument-given
      (delete-characters (- nmode-command-argument))
      (setf nmode-command-killed T))
    (t
      (if (at-buffer-start?)
	(Ding)
	(delete-previous-character)
	))))

(de delete-forward-character-command ()
  (cond 
    (nmode-command-argument-given
      (delete-characters nmode-command-argument)
      (setf nmode-command-killed T))
    (t
      (if (at-buffer-end?)
	(Ding)
	(delete-next-character)
	))))

(de delete-backward-hacking-tabs-command ()
  (cond 
    (nmode-command-argument-given
      (delete-characters-hacking-tabs (- nmode-command-argument))
      (setf nmode-command-killed T))
    (t
      (if (at-buffer-start?)
	(Ding)
	(move-backward-character-hacking-tabs)
	(delete-next-character)
	))))

(de transpose-words ()
  (let ((old-pos (buffer-get-position)))
    (cond ((not (attempt-to-transpose-words nmode-command-argument))
	   (Ding)
	   (buffer-set-position old-pos)
	   ))))

(de attempt-to-transpose-words (n)
  % Returns non-NIL if successful.
  (prog (bp1 bp2 bp3 bp4 word1 word2)
    (cond ((= n 0)
	   (setf bp1 (buffer-get-position))
	   (if (not (move-forward-word)) (return NIL))
	   (setf bp2 (buffer-get-position))
	   (buffer-set-position (current-mark))
	   (setf bp3 (buffer-get-position))
	   (if (not (move-forward-word)) (return NIL))
	   (setf bp4 (buffer-get-position))
	   (exchange-regions bp3 bp4 bp1 bp2)
	   (move-backward-word)
	   )
	  (t
	   (if (not (move-backward-word)) (return NIL))
	   (setf bp1 (buffer-get-position))
	   (if (not (move-forward-word)) (return NIL))
	   (setf bp2 (buffer-get-position))
	   (if (not (move-over-words (if (< n 0) (- n 1) n))) (return NIL))
	   (setf bp4 (buffer-get-position))
	   (if (not (move-over-words (- 0 n))) (return NIL))
	   (setf bp3 (buffer-get-position))
	   (exchange-regions bp1 bp2 bp3 bp4)
	   ))
    (return T)
    ))

(de transpose-lines ()
  (let ((old-pos (buffer-get-position)))
    (cond ((not (attempt-to-transpose-lines nmode-command-argument))
	   (Ding)
	   (buffer-set-position old-pos)
	   ))))

(de attempt-to-transpose-lines (n)
  % Returns non-NIL if successful.
  (prog (bp1 bp2 bp3 bp4 line1 line2 current marked last)
    (setf current (current-line-pos))
    (setf last (- (current-buffer-size) 1))
    % The last line doesn't count, because it is unterminated.
    (setf marked (buffer-position-line (current-mark)))
    (cond ((= n 0)
	   (if (or (>= current last) (>= marked last)) (return NIL))
	   (setf bp1 (buffer-position-create current 0))
	   (setf bp2 (buffer-position-create (+ current 1) 0))
	   (setf bp3 (buffer-position-create marked 0))
	   (setf bp4 (buffer-position-create (+ marked 1) 0))
	   (exchange-regions bp3 bp4 bp1 bp2)
	   (move-to-previous-line)
	   )
	  (t
	   % Dragged line is the previous one.
	   (if (= current 0) (return NIL))
	   (setf bp1 (buffer-position-create (- current 1) 0))
	   (setf bp2 (buffer-position-create current 0))
	   (setf marked (- (+ current n) 1))
	   (if (or (< marked 0) (>= marked last)) (return NIL))
	   (setf bp3 (buffer-position-create marked 0))
	   (setf bp4 (buffer-position-create (+ marked 1) 0))
	   (exchange-regions bp1 bp2 bp3 bp4)
	   ))
    (return T)
    ))

(de transpose-forms ()
  (let ((old-pos (buffer-get-position)))
    (cond ((not (attempt-to-transpose-forms nmode-command-argument))
	   (Ding)
	   (buffer-set-position old-pos)
	   ))))

(de attempt-to-transpose-forms (n)
  % Returns non-NIL if successful.
  (prog (bp1 bp2 bp3 bp4 form1 form2)
    (cond ((= n 0)
	   (setf bp1 (buffer-get-position))
	   (if (not (move-forward-form)) (return NIL))
	   (setf bp2 (buffer-get-position))
	   (buffer-set-position (current-mark))
	   (setf bp3 (buffer-get-position))
	   (if (not (move-forward-form)) (return NIL))
	   (setf bp4 (buffer-get-position))
	   (exchange-regions bp3 bp4 bp1 bp2)
	   (move-backward-form)
	   )
	  (t
	   (if (not (move-backward-form)) (return NIL))
	   (setf bp1 (buffer-get-position))
	   (if (not (move-forward-form)) (return NIL))
	   (setf bp2 (buffer-get-position))
	   (if (not (move-over-forms (if (< n 0) (- n 1) n))) (return NIL))
	   (setf bp4 (buffer-get-position))
	   (if (not (move-over-forms (- 0 n))) (return NIL))
	   (setf bp3 (buffer-get-position))
	   (exchange-regions bp1 bp2 bp3 bp4)
	   ))
    (return T)
    ))

(de transpose-regions ()
  (let ((old-pos (buffer-get-position)))
    (cond ((not (attempt-to-transpose-regions nmode-command-argument))
	   (Ding)
	   (buffer-set-position old-pos)
	   ))))

(de attempt-to-transpose-regions (n)
  % Returns non-NIL if successful.
  % Transpose regions defined by cursor and three most recent marks.
  % EMACS resets all of the marks; we just reset the cursor to the
  % end of the higher region.

  (prog (bp1 bp2 bp3 bp4 bp-list)
    (setf bp1 (buffer-get-position))
    (setf bp2 (current-mark))
    (setf bp3 (previous-mark))
    (setf bp4 (previous-mark))
    (previous-mark)
    (setf bp-list (list bp1 bp2 bp3 bp4))
    (gsort bp-list (function buffer-position-lessp))
    (exchange-regions (first bp-list)
		      (second bp-list)
		      (third bp-list)
		      (fourth bp-list))
    (buffer-set-position (fourth bp-list))
    (return T)
    ))

% Support functions:

(de delete-characters (n)
  (let ((old-pos (buffer-get-position)))
    (move-over-characters n)
    (update-kill-buffer
      (extract-region T old-pos (buffer-get-position)))
    ))

(de delete-characters-hacking-tabs (n)

  % Note: EMACS doesn't try to hack tabs when deleting forward.
  % We do, but it's a crock.  What should really happen is that all
  % consecutive tabs are converted to spaces.

  (cond ((< n 0)
	 % Deleting backwards is tricky because the conversion of tabs to
	 % spaces may change the numeric value of the original "position".
	 % Our solution is to first move backwards the proper number of
	 % characters (converting tabs to spaces), and then move back over them.

	 (let ((count (- n)))
	   (setf n 0)
	   (while (and (> count 0)
		       (move-backward-character-hacking-tabs))
	     (setf count (- count 1))
	     (setf n (- n 1))
	     )
	   (move-over-characters (- n))
	   )))

  (let ((old-pos (buffer-get-position)))
    (move-over-characters-hacking-tabs n)
    (update-kill-buffer
      (extract-region T old-pos (buffer-get-position)))
    ))

(de delete-words (n)
  (let ((old-pos (buffer-get-position)))
    (move-over-words n)
    (update-kill-buffer
      (extract-region T old-pos (buffer-get-position)))
    ))

(de delete-forms (n)
  (let ((old-pos (buffer-get-position)))
    (move-over-forms n)
    (update-kill-buffer
      (extract-region T old-pos (buffer-get-position)))
    ))

(de exchange-regions (bp1 bp2 bp3 bp4)
  % The specified positions define two regions: R1=<BP1,BP2> and
  % R2=<BP3,BP4>.  These regions should not overlap, unless they
  % are identical.  The contents of the two regions will be exchanged.
  % The cursor will be moved to the right of the region R1 (in its new
  % position).

  (let ((dir (buffer-position-compare bp1 bp3))
	(r1 (cdr (extract-region NIL bp1 bp2)))
	(r2 (cdr (extract-region NIL bp3 bp4)))
	)
    (cond ((< dir 0) % R1 is before R2
	   (extract-region T bp3 bp4)
	   (insert-text r1)
	   (extract-region T bp1 bp2)
	   (insert-text r2)
	   (buffer-set-position bp4)
	   )
	  ((> dir 0) % R2 is before R1
	   (extract-region T bp1 bp2)
	   (insert-text r2)
	   (extract-region T bp3 bp4)
	   (insert-text r1)
	   ))
    ))