File psl-1983/nmode/text-commands.sl artifact 90430be7cb on branch master


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% TEXT-COMMANDS.SL - NMODE Sentence, Paragraph, Filling, and Formatting
%
% Author:      Jeff Soreff
%              Hewlett-Packard/CRC
% Date:        8 December 1982
% Revised:     1 February 1983
% Revised:     15 February 1983
%
% 15-Feb-83 Jeff Soreff
%  Bugs were removed from fill-comment-command and from next-char-list.
%      A test for arriving at a line end was added to fill-comment-command
%  in the while loop which locates the fill prefix to be used.  It fixed an
%  infinite loop in this while which occurred when one did a
%  fill-comment-command while on the last line in the buffer, if the
%  prefix-finding loop got to the buffer's end.  An at-line-end? test was used
%  instead of an at-buffer-end? test since the fill prefix found should never
%  go over a line.
%      In next-char-list the initialization of final-char-pos was changed
%  from 0 to char-count.  This removed a bug that led to setting the point
%  at the start of a prefixed line after a fill which moved point to the first
%  availible position on that new line.  Point should have been left AFTER the
%  prefix.  Changing the initialization of final-char-position allows
%  next-char-list to accurately account for the spaces taken up by the prefix,
%  since this count is passed to its char-count argument.
% 1-Feb-83 Alan Snyder
%  Changed literal ^L in source to #\FF.
% 30-Dec-82 Alan Snyder
%  Extended C-X = to set the current line number if a command number is
%  given.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

(fluid '(nmode-current-buffer text-mode fill-prefix fill-column
nmode-command-argument nmode-command-argument-given nmode-command-number-given
nmode-command-killed sentence-terminators sentence-extenders))

(setf sentence-terminators '(#/! #/. #/?))
(setf sentence-extenders '(#/' #/" #/) #/]))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% User/Enhancer option sensitive function:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% The text-justifier function may be altered if one wishes to have the
% same flexibility as EMACS'S TECO search strings provide.

(de text-justifier-command? ()
  % This function checks to see if the rest of the line is a text
  % justifier command. It returns a boolean and leaves point alone.
  (= (next-character) #/.))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Start of Sentence Functions and Associated Support Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de valid-sentence-end? ()
  % This function checks that a sentence is followed by two blanks, a
  % newline or a blank and a newline.  It advances point one space.
  % It returns a boolean value.
  (if (at-line-end?) t
    (move-forward)
    (and (= (previous-character) #\blank)
	 (or (at-line-end?)(= (next-character) #\blank)))))

(de move-to-end-of-last-sentence ()
  % This function moves point to the end of the preceding sentence,
  % after extenders.  This function does not return a useful value
  (while (not
	  (or (at-buffer-start?)
	      (when		  
		% This when returns true if it hits a valid sentence end.
		(member (previous-character) sentence-terminators)
		(let ((scan-place (buffer-get-position)))
		  (while 
		    (member (next-character) sentence-extenders)
		    (move-forward))
		  (let* ((tentative-sentence-end (buffer-get-position))
			 (true-end (valid-sentence-end?)))
		    (buffer-set-position
		     (if true-end tentative-sentence-end scan-place))
		    true-end)))))
    (move-backward)))

(de start-of-last-sentence ()
  % This function restores point to its former place.  It returns the
  % location of the start of the preceding sentence.
  (let ((place (buffer-get-position))(start nil)(end nil))
    (move-to-end-of-last-sentence)
    (setf end (buffer-get-position))
    (skip-forward-blanks) % possibly past starting position this time
    (setf start (buffer-get-position))
    (when (buffer-position-lessp place start)
      (buffer-set-position end) % end of last sentence, after extenders
      (while % push back past extenders
	(member (previous-character) sentence-extenders)
	(move-backward))
      (move-backward) % push back past sentence terminator character
      (move-to-end-of-last-sentence)
      (skip-forward-blanks)
      (setf start (buffer-get-position)))
    (buffer-set-position place)
    start))

(de end-of-next-sentence ()
  % This function restores point to its former place.  It returns the
  % location of the end of the next sentence.
  (let ((place (buffer-get-position)))
    (while (not 
	    % the next sexp detects sentence ends and moves point to them
	    (or (at-buffer-end?)
		(when % note that this returns (valid-sentence-end?)'s value
		  (member (next-character) sentence-terminators)
		  (move-forward)
		  (while 
		    (member (next-character) sentence-extenders)
		    (move-forward))
		  (let ((tentative-sentence-end (buffer-get-position)))
		    (if (valid-sentence-end?)
		      (buffer-set-position tentative-sentence-end))))))
      (move-forward))
    (prog1 
     (buffer-get-position)
     (buffer-set-position place))))

(de forward-one-sentence ()
  % This function moves point to the end of the next sentence or
  % paragraph, whichever one is closer, and does not return a useful
  % value.
  (let ((sentence-end (end-of-next-sentence)))
    (if (at-line-end?)(move-forward)) % kludge to get around xtra newline
    (forward-one-paragraph)
    (if (at-line-start?)(move-backward)) % kludge to get around xtra newline
    (let ((paragraph-end (buffer-get-position)))
      (buffer-set-position
       (if (buffer-position-lessp sentence-end paragraph-end)
	 % "closer" is "earlier" or "before", in this case
	 sentence-end paragraph-end)))))

(de backward-one-sentence ()
  % This function moves point to the start of the preceding sentence
  % or paragraph, whichever one is closer. It does not return a useful
  % value
  (let ((sentence-start (start-of-last-sentence)))
    (skip-backward-blanks)
    (backward-one-paragraph)
    (skip-forward-blanks)
    (let ((paragraph-start (buffer-get-position)))
      (buffer-set-position
       (if (buffer-position-lessp sentence-start paragraph-start)
	 % "closer" is "later" or "after", in this case
	 paragraph-start sentence-start)))))

(de forward-sentence-command ()
  % If nmode-command-argument is positive this function moves point
  % forward by nmode-command-argument sentences , leaving it at the
  % end of a sentence.  If nmode-command-argument is negative it moves
  % backwards by abs(nmode-command-argument) sentences, leaving it at
  % the start of a sentence.  This function does not return a useful
  % value.
  (if (minusp nmode-command-argument)
    (for (from i 1 (- nmode-command-argument) 1)
	 (do (backward-one-sentence)))
    (for (from i 1 nmode-command-argument 1)
	 (do (forward-one-sentence)))))

(de backward-sentence-command ()
  % If nmode-command-argument is positive this function moves point
  % backward by nmode-command-argument sentences , leaving it at the
  % start of a sentence.  If nmode-command-argument is negative it
  % moves forwards by abs(nmode-command-argument) sentences, leaving
  % it at the end of a sentence.  This function does not return a
  % useful value.
  (if (minusp nmode-command-argument)
    (for (from i 1 (- nmode-command-argument) 1)
	 (do (forward-one-sentence)))
    (for (from i 1 nmode-command-argument 1)
	 (do (backward-one-sentence)))))

(de kill-sentence-command ()
  % This function kills whatever forward-sentence-command jumps over.
  % It leaves point after the killed text.  This function is sensitive
  % to the nmode command argument through forward-sentence-command.
  (let ((place (buffer-get-position)))
    (forward-sentence-command)
    (update-kill-buffer (extract-region t place (buffer-get-position)))
    (setf nmode-command-killed t)))

(de backward-kill-sentence-command ()
  % This function kills whatever backward-sentence-command jumps over.
  % It leaves point after the killed text.  This function is sensitive
  % to the nmode command argument through forward-sentence-command.
  (let ((place (buffer-get-position)))
    (backward-sentence-command)
    (update-kill-buffer (extract-region t place (buffer-get-position)))
    (setf nmode-command-killed t)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Start of Paragraph Functions and Associated Support Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de rest-of-current-line-blank? () 
  % This function detects if the rest of the line is blank.  It
  % returns a boolean value.  It restores point.
  (let ((last-position (buffer-get-position)))
    (while (and (not (at-line-end?))
		(char-blank? (next-character)))
      (move-forward))
    (prog1 (at-line-end?)
	   (buffer-get-position last-position))))

(de mismatched-prefix? ()
  % This function checks to see if there is a fill prefix which
  % doesn't match the start of the current line.  It leaves point at
  % the start of the current line if there is a mismatch, or just
  % after the prefix if matched.  It returns t if there is a fill
  % prefix which does NOT match the line's start.
  (move-to-start-of-line)
  (when fill-prefix
    (let ((start-line (buffer-get-position)))
      (move-over-characters
       (string-length % count of characters in fill-prefix
	(getv fill-prefix 0)))
      (when (not (text-equal
		  (extract-text nil 
				start-line
				(buffer-get-position))
		  fill-prefix))
	(buffer-set-position start-line)
	t))))

(de pseudo-blank-line? ()
  % This function tests to see if the current line should be kept out
  % of paragraphs.  It tests for: lines which don't match an existing
  % fill prefix, blank lines, lines with only the fill prefix present,
  % text justifier commands, and properly prefixed text justifier
  % commands.  It only checks for the text justifier commands in text
  % mode.  It leaves point at the start of the current line and
  % returns a boolean value.
  (or (mismatched-prefix?)
      (prog1
       (or (and (text-justifier-command?)
		(eq text-mode (=> nmode-current-buffer mode)))
	   (rest-of-current-line-blank?))
       (move-to-start-of-line))))

(de pseudo-indented-line? ()
  % This function looks for page break characters or (in text mode)
  % indentation (after a fill prefix, if present) which signal the
  % start of a real paragraph. It always leaves point at the start of
  % the current line and returns a boolean.
  (prog1 (or
	  (= #\FF (next-character)) % page break character
	  (progn  (mismatched-prefix?)
		  (and (char-blank? (next-character))
		       (eq text-mode (=> nmode-current-buffer mode)))))
	 (move-to-start-of-line)))

(de start-line-paragraph? ()
  % This function tests the current line to see if it is the first
  % line (not counting an empty line) in a paragraph.  It leaves point
  % at the start of line and returns a boolean value.
  (and (not (pseudo-blank-line?))
       (or (pseudo-indented-line?)
	   % next sexp checks for a previous blank line
	   (if (current-line-is-first?)
	     t
	     (move-to-previous-line)
	     (prog1 
	      (pseudo-blank-line?)
	      (move-to-next-line))))))

(de end-line-paragraph? ()
  % This function tests the current line to see if it is the last line
  % in a paragraph.  It leaves point at the start of line and returns
  % a boolean value.
  (and (not (pseudo-blank-line?))
       % The next sexp checks for the two things on the next line of
       % text that can end a paragraph: a blank line or an indented
       % line which would start a new paragraph.
       (if (current-line-is-last?)
	 t
	 (move-to-next-line)
	 (prog1 
	  (or (pseudo-indented-line?)
	      (pseudo-blank-line?))
	  (move-to-previous-line)))))

(de forward-one-paragraph ()
  % This function moves point to the end of the next or current
  % paragraph, as EMACS defines it. This is either start of the line
  % after the last line with any characters or, if the paragraph
  % extends to the end of the buffer, then the end of the last line
  % with characters. This function returns a boolean which is true if
  % the function was stopped by a real paragraph end, rather than by
  % the buffer's end.
  (let ((true-end nil))
    (while (not (or (setf true-end (end-line-paragraph?))
		    (current-line-is-last?)))
      (move-to-next-line))
    (move-to-next-line)
    true-end))

(de forward-paragraph-command ()
  % If nmode-command-argument is positive this function moves point
  % forward by nmode-command-argument paragraphs , leaving it at the
  % end of a paragraph.  If nmode-command-argument is negative it moves
  % backwards by abs(nmode-command-argument) paragraphs, leaving it at
  % the start of a paragraph.  This function does not return a useful
  % value.
  (if (minusp nmode-command-argument)
    (for (from i 1 (- nmode-command-argument) 1)
	 (do (backward-one-paragraph)))
    (for (from i 1 nmode-command-argument 1)
	 (do (forward-one-paragraph)))))

(de backward-one-paragraph ()
  % This function moves point backward to the start of the previous
  % paragraph. It returns a boolean which is true if the function was
  % stopped by a real paragraph's start, instead of by the buffer's
  % start.
  (if (and (at-line-start?) % if past start of start line, don't miss
	   (start-line-paragraph?)) % start of current paragraph
    (move-to-previous-line))
  (let ((real-start nil))
    (while (not (or (setf real-start (start-line-paragraph?))
		    (current-line-is-first?)))
      (move-to-previous-line))
    (unless (current-line-is-first?) % this sexp gets previous empty line on
      (move-to-previous-line)
      (unless (current-line-empty?)
	(move-to-next-line)))
    real-start))

(de backward-paragraph-command ()
  % If nmode-command-argument is positive this function moves point
  % backward by nmode-command-argument paragraphs , leaving it at the
  % start of a paragraph.  If nmode-command-argument is negative it
  % moves forwards by abs(nmode-command-argument) paragraphs, leaving
  % it at the end of a paragraph.  This function does not return a
  % useful value.
  (if (minusp nmode-command-argument)
    (for (from i 1 (- nmode-command-argument) 1)
	 (do (forward-one-paragraph)))
    (for (from i 1 nmode-command-argument 1)
	 (do (backward-one-paragraph)))))

(de paragraph-limits ()
  % This function returns a list of positions marking the next
  % paragraph.  Only real paragraph limits are returned. If there is
  % only stuff that should be excluded from a paragraph between point
  % and the end or the start of the buffer, then the appropriate limit
  % of the paragraph is filled with the current buffer position.  This
  % function restores point.
  (let* ((temp (buffer-get-position))(top temp)(bottom temp))
    (when (forward-one-paragraph)
      (setf bottom (buffer-get-position)))
    (when (backward-one-paragraph)
      (setf top (buffer-get-position)))
    (buffer-set-position temp)
    (list top bottom)))

(de mark-paragraph-command ()
  % This function sets the mark to the end of the next paragraph, and
  % moves point to its start. It returns nothing useful.
  (let ((pair (paragraph-limits)))
    (buffer-set-position (first pair))
    (set-mark (second pair))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Start of Fill Functions and Associated Support Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de next-char-list (end char-count init-pos)
  % This function returns a list, the first element of which is a list
  % of characters, with their order the reverse of that in the
  % original text, spaces squeezed to a single space between words,
  % and with two spaces between sentences. The second element on the
  % list returned is how far along the new line the position
  % corresponding to "init-pos" wound up.  Point is left after the
  % last character packed in but before "end" or the next nonblank
  % character.
  (let* ((from-end-last-blanks 0)
	 (from-start-last-blanks 0)
	 (final-char-pos char-count)
	 (line-not-full (lessp char-count fill-column))
	 (first-end (buffer-get-position))
	 (next-sentence-wont-exhaust-region
	  (not (buffer-position-lessp end first-end)))
	 (new-char (next-character))
	 (line-list ()))
    % start of loop for successive sentences
    (while (and next-sentence-wont-exhaust-region line-not-full)
      % The next sexp checks to see if the next sentence fits within
      % the main region (from initial "point" to "end") with a
      % character to spare for the next sentence iteration.
      (let* ((next-sentence-end (end-of-next-sentence)))
	(setf next-sentence-wont-exhaust-region
	  (not (buffer-position-lessp end next-sentence-end)))
	(setf first-end (if next-sentence-wont-exhaust-region
			  next-sentence-end end)))
      (skip-forward-blanks) % ignore blanks just before next sentence
      % start of loop for successive characters
      (while (and (setf line-not-full (or (lessp char-count fill-column)
					  % next sexp allows oversize words
					  (eq char-count from-end-last-blanks)))
		  (not (buffer-position-lessp first-end
					      (buffer-get-position))))
	(setf new-char
	  % character compression sexp
	  (let ((next (next-character)))
	    (if (not (= (skip-forward-blanks)
			next))
	      #\blank
	      (move-forward)
	      next)))
	(setq line-list (cons new-char line-list))
	(incr char-count)
	(when (buffer-position-lessp (buffer-get-position) init-pos)
	  (setf final-char-pos char-count))
	(cond ((= new-char #\blank)
	       (setf from-end-last-blanks 0)
	       (setf from-start-last-blanks 1))
	      (t % normal character  
	       (incr from-end-last-blanks)
	       (incr from-start-last-blanks))))
      % The next sexp terminates sentences properly.
      (when (and line-not-full next-sentence-wont-exhaust-region)
	(setf line-list (append '(#\blank #\blank) line-list))
	(incr char-count 2)
	(setf from-end-last-blanks 0)
	(setf from-start-last-blanks 2)))
    % The next sexp trims off the last partial word or extra blank(s).
    (when (or (char-blank? (car line-list)) % extra blank(s)
	      (not (or line-not-full % last partial word
		       (at-line-end?)
		       (char-blank? (next-character)))))
      (for (from i 1 from-start-last-blanks 1)
	   (do (setf line-list (cdr line-list))))
      (move-over-characters (- from-end-last-blanks)))
    % guarantee that buffer-position is left at or before end
    (if (buffer-position-lessp end (buffer-get-position))
      (buffer-set-position end))
    (list line-list final-char-pos)))

(de justify (input desired-length)
  % This function pads its input with blanks and reverses it.  It
  % leaves point alone.
  (let*
    ((input-length (length input))
     (output ())
     (needed-blanks (- desired-length input-length))
     % total number needed to fill out line
     (input-blanks % count preexisting blanks in input
      (for (in char input)
	   (with blanks)
	   (count (= char #\blank) blanks)
	   (returns blanks))))
    (for (in char input)
	 (with (added-blanks 0) % number of new blanks added so far
	       (handled-blanks 0)) % number of input blanks considered so far
	 (do
	  (setf output (cons char output))
	  (when (= char #\blank)
	    (incr handled-blanks)
	    % calculate number of new blanks needed here
	    % fraction of original blanks passed=handled-blanks/input-blanks
	    % blanks needed here~fraction*[needed-blanks(for whole line)]-(added-blanks)
	    (let ((new-blanks (- (/ (* needed-blanks handled-blanks)
				    input-blanks)
				 added-blanks)))
	      (when (> new-blanks 0)
		(for (from new 1 new-blanks 1)
		     (do 
		      (setf output (cons #\blank output))))
		(incr added-blanks new-blanks))))))
    output))

(de position-adjusted-for-prefix (position)
  % This is a pure function which returns a position, corrected for
  % the length of the prefix on the position's line.
  (let ((current-place (buffer-get-position)))
    (buffer-set-position position)
    (mismatched-prefix?)
    (let ((prefix-length-or-zero (current-char-pos)))
      (buffer-set-position current-place)
      (let ((adjusted-char-pos (- (buffer-position-column position)
				  prefix-length-or-zero)))
	(if (< adjusted-char-pos 0)(setf adjusted-char-pos 0))
	(buffer-position-create (buffer-position-line position)
				adjusted-char-pos)))))

(de remove-prefix-from-region (start end)
  % The main effect of this function is to strip the fill prefix off a
  % region in the buffer. this function does not return a useful value
  % or move point.
  (let ((current-place (buffer-get-position)))
    (buffer-set-position start)
    (if (current-line-empty?)(move-to-next-line))
    (while (not (buffer-position-lessp end (buffer-get-position)))
      (setf start (buffer-get-position))
      (unless (or 
	       (mismatched-prefix?)
	       (buffer-position-lessp end (buffer-get-position)))
	(extract-text t start (buffer-get-position)))
      (move-to-next-line))
    (buffer-set-position current-place)))

(de fill-directed-region (start end init-pos)
  % The main effect of this function is to replace text with filled or
  % justified text.  This function returns a list.  The first element
  % is the increase in the number of lines in the text due to filling.
  % The second element is the filled position equivalent to "init-pos"
  % in the original text.  The point is left at the end of the new
  % text
  (let ((modified-flag (=> nmode-current-buffer modified?))
	(old-text (extract-text nil start end))
	(final-pos init-pos)
	(adj-end (position-adjusted-for-prefix end))	
	(adj-init-pos (position-adjusted-for-prefix init-pos)))
    (when fill-prefix (remove-prefix-from-region start end))
    (setf end adj-end)
    (buffer-set-position start)
    (let*
      ((list-of-new-lines (when % handles first blank line
			    (current-line-empty?)
			    (move-to-next-line)
			    '("")))
       (new-packed-line '(nil 0))
       (prefix-list
	(if fill-prefix 
	  (string-to-list 
	   (getv fill-prefix 0))))
       (prefix-column (map-char-to-column
		       (list2string prefix-list)
		       (length prefix-list)))
       (new-line nil)
       (place (buffer-get-position))               % handles indentation
       (junk (skip-forward-blanks))                % handles indentation
       (start-char-pos (+ (current-display-column) % handles indentation
			  prefix-column)) % and first time switch
       (indent-list (string-to-list                % handles indentation
		     (getv (extract-text
			    nil place (buffer-get-position)) 0))))
      (while
	(let* ((after-line-start (buffer-position-lessp
				  (buffer-get-position) adj-init-pos))
	       (new-packed-line 
		(next-char-list end start-char-pos adj-init-pos))
	       (before-line-end (buffer-position-lessp
				 adj-init-pos (buffer-get-position))))
	  (when (and after-line-start before-line-end)
	    (setf final-pos (buffer-position-create
			     (+ (buffer-position-line start)
				(length list-of-new-lines))
			     (second new-packed-line))))
	  % test that anything is left in the region, as well as getting line
	  (setf new-line (first new-packed-line)))
	(setf new-line
	  (list2string 
	   (append % add in fill prefix and indentation
	    (append prefix-list
		    (unless (= start-char-pos prefix-column) indent-list))
	    (if (and nmode-command-argument-given % triggers justification
		     (not (or % don't justify the last line in a paragraph
			   (buffer-position-lessp end (buffer-get-position))
			   (at-buffer-end?))))
	      (justify new-line (- fill-column start-char-pos))
	      (reverse new-line)))))
	(setf list-of-new-lines (cons new-line list-of-new-lines))
	% only the first line in a paragraph is indented
	(setf start-char-pos prefix-column))
      (setf list-of-new-lines (cons (list2string nil) list-of-new-lines))
      % The last line in the new paragraph is added in last setf.
      (let ((line-change 0)
	    (new-text (list2vector (reverse list-of-new-lines))))
	(when list-of-new-lines
	  (extract-text t start end)
	  (setf line-change
	    (- (size new-text)
	       (size old-text)))
	  (insert-text new-text)
	  (if (and (not modified-flag)
		   (text-equal new-text old-text))
	    (=> nmode-current-buffer set-modified? nil)))
	(list line-change final-pos)))))

(de clip-region (limits region)
  % This is a pure function with no side effects.  It returns the
  % "region" position pair, sorted so that first buffer position is
  % the first element, and clipped so that the region returned is
  % between the buffer-positions in "limits".
  (let ((limit-pair (if (buffer-position-lessp (cadr limits) (car limits))
		      (reverse limits) limits))
	(region-pair (copy
		      (if (buffer-position-lessp (cadr region) (car region))
			(reverse region) region))))
    (if (buffer-position-lessp (car region-pair) (car limit-pair))
      (setf (car region-pair) (car limit-pair)))
    (if (buffer-position-lessp (cadr region-pair) (car limit-pair))
      (setf (cadr region-pair) (car limit-pair)))
    (if (buffer-position-lessp (cadr limit-pair) (car region-pair))
      (setf (car region-pair) (cadr limit-pair)))
    (if (buffer-position-lessp (cadr limit-pair) (cadr region-pair))
      (setf (cadr region-pair) (cadr limit-pair)))
    region-pair))
	 
(de fill-region-command ()
  % This function replaces the text between point and the current mark
  % with a filled version of the same text.  It leaves the
  % buffer-position at the end of the new text.  It does not return
  % anything useful.
  (let* ((current-place (buffer-get-position))
	 (limits (list (current-mark) current-place)))
    (setf limits
      (if (buffer-position-lessp (car limits) (cadr limits))
	limits (reverse limits)))
    (buffer-set-position (car limits))
    (let ((at-limits nil)(new-region nil)(lines-advance 0))
      (while (not at-limits) % paragraph loop
	(setf new-region (paragraph-limits))
	(setf new-region (clip-region limits new-region))
	(setf at-limits (= (car new-region) (cadr new-region)))
	(unless at-limits
	  (setf lines-advance
	    (first (fill-directed-region % expansion-of-text-information used
		    (car new-region) (cadr new-region) current-place)))
	  (setf limits % compensate for expansion of filled text
	    (list (first limits)
		  (let ((bottom (second limits)))
		    (buffer-position-create
		     (+ lines-advance (buffer-position-line bottom))
		     (buffer-position-column bottom))))))
	(setf limits % guarantee that no text is filled twice
	  (list (buffer-get-position)(second limits)))))))

(de fill-paragraph-command ()
  % This function replaces the next paragraph with filled version.  It
  % leaves point at the a point bearing the same relation to the
  % filled text that the old point did to the old text.  It does not
  % return a useful value.
  (let* ((current-place (buffer-get-position))
	 (pos-list (paragraph-limits)))
    (buffer-set-position (second (fill-directed-region
				  (first pos-list)
				  (second pos-list)
				  current-place)))))

(de fill-comment-command ()
  % This function creates a temporary fill prefix from the start of
  % the current line.  It replaces the surrounding paragraph
  % (determined using fill-prefix) with a filled version.  It leaves
  % point at the a position bearing the same relation to the filled
  % text that the old point did to the old text.  It does not return a
  % useful value.
  (let ((current-place (buffer-get-position)))
    (move-to-start-of-line)
    (let ((place (buffer-get-position))) % get fill prefix ends set up
      (skip-forward-blanks-in-line)
      (while (not (or (alphanumericp (next-character))
		      (at-line-end?)
		      (char-blank? (next-character))))
	(move-forward))
      (skip-forward-blanks-in-line)
      (let* ((fill-prefix (extract-text nil place (buffer-get-position)))
	     (pos-list (paragraph-limits)))
	(if (buffer-position-lessp (first pos-list) current-place)
	  (buffer-set-position (second (fill-directed-region
					(first pos-list)
					(second pos-list)
					current-place)))
	  (buffer-set-position current-place))))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Start of Misc Functions and Associated Support Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de center-current-line ()
  % This function trims and centers the current line.  It does not
  % return a useful value.  It leaves point at a point in the text
  % equivalent to that before centering.
  (current-line-strip-indent)
  (let ((current-place (buffer-get-position)))
    (move-to-end-of-line)
    (strip-previous-blanks)
    (buffer-set-position current-place))
  (let ((needed-blanks (/ (- fill-column (current-display-column)) 2)))
    (unless (minusp needed-blanks)
      (indent-current-line needed-blanks))))

(de center-line-command ()
  % This function centers a number of lines, depending on the
  % argument.  It leaves point at the end of the last line centered.
  % It does not return a useful value.
  (center-current-line)
  (when (> (abs nmode-command-argument) 1)
    (if (minusp nmode-command-argument)
      (for (from i 2 (- nmode-command-argument) 1)
	   (do (move-to-previous-line)
	       (center-current-line)))
      (for (from i 2 nmode-command-argument 1)
	   (do (move-to-next-line)
	       (center-current-line))))))

(de what-cursor-position-command ()
  % This function tells the user where they are in the buffer or sets
  % point to the specified line number.  It does not return a useful
  % value.
  (cond
   (nmode-command-number-given
    (set-line-pos nmode-command-argument)
    )
   (t
    (write-message
     (if (at-buffer-end?)
       (bldmsg "X=%w Y=%w line=%w (%w percent of %w lines)"
	       (current-display-column)
	       (- (current-line-pos)(current-window-top-line))
	       (current-line-pos)
	       (/ (* 100 (current-line-pos))
		  (current-buffer-visible-size))
	       (current-buffer-visible-size))
       (bldmsg "X=%w Y=%w CH=%w line=%w (%w percent of %w lines)"
	       (current-display-column)
	       (- (current-line-pos)(current-window-top-line))
	       (next-character) % omitted at end of buffer
	       (current-line-pos)
	       (/ (* 100 (current-line-pos))
		  (current-buffer-visible-size))
	       (current-buffer-visible-size))))
    )))


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]