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

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Case-Commands.SL - NMODE Case Conversion commands
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        6 October 1982
%
% The original code was contributed by Jeff Soreff.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load fast-int fast-vectors fast-strings))

(fluid '(
  nmode-command-argument
  nmode-current-buffer
  ))

% Global variables:

(fluid '(shifted-digits-association-list))
(setf shifted-digits-association-list NIL)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Case Conversion Commands:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de uppercase-word-command ()
  (transform-region-with-next-word-or-fragment #'string-upcase))

(de lowercase-word-command ()
  (transform-region-with-next-word-or-fragment #'string-downcase))

(de uppercase-initial-command ()
  (transform-region-with-next-word-or-fragment #'string-capitalize))

(de uppercase-region-command ()
  (transform-marked-region #'string-upcase))

(de lowercase-region-command ()
  (transform-marked-region #'string-downcase))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Upcase Digit Command:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de upcase-digit-command ()
  % Convert the previous digit to the corresponding "shifted character"
  % on the keyboard.  Search only within the current line or the previous
  % line.  Ding if no digit found.


  (let ((point (buffer-get-position))
	(limit-line-pos (- (current-line-pos) 1))
	(ok NIL)
	)
    (while (and (>= (current-line-pos) limit-line-pos)
		(not (at-buffer-start?))
		(not (setf ok (digitp (previous-character))))
		)
      (move-backward)
      )
    (cond ((and ok (set-up-shifted-digits-association-list))
	   (let* ((old (previous-character))
		  (new (cdr (assoc old shifted-digits-association-list)))
		  )
	     (delete-previous-character)
	     (insert-character new)
	     ))
	  (t (Ding))
	  )
    (buffer-set-position point)
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% General Transformation Functions:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de transform-region (string-conversion-function bp1 bp2)
  % Transform the region in the current buffer between the positions
  % BP1 and BP2 by applying the specified function to each partial or
  % complete line.  The function should accept a single string argument
  % and return the transformed string.  Return 1 if BP2 > BP1;
  % return -1 if BP2 < BP1.  The buffer pointer is left at the "end"
  % of the transformed region (the greater of BP1 and BP2).

  (let* ((modified-flag (=> nmode-current-buffer modified?))
	 (extracted-pair (extract-region t bp1 bp2))
	 (newregion (cdr extracted-pair))
	 (oldregion (if (not modified-flag) (copyvector newregion)))
	 )
    (for (from index 0 (vector-upper-bound newregion) 1)
	 (do (vector-store newregion index 
	       (apply string-conversion-function
		      (list (vector-fetch newregion index))))))
    (insert-text newregion)
    (if (and (not modified-flag) (text-equal newregion oldregion))
	(=> nmode-current-buffer set-modified? nil)
	)
    (car extracted-pair)
    ))
		
(de transform-region-with-next-word-or-fragment (string-conversion-function)
  % Transform the region consisting of the following N words, where N is
  % the command argument.  N may be negative, meaning previous words.

  (let ((start (buffer-get-position)))
    (move-over-words nmode-command-argument)
    (transform-region string-conversion-function start (buffer-get-position))
    ))

(de transform-marked-region (string-conversion-function)
  % Transform the region defined by point and mark.

  (let ((point (buffer-get-position))
	(mark (current-mark))
	)
    (when (= (transform-region string-conversion-function point mark) 1)
      % The mark was at the end of the region. If the transformation changed
      % the length of the region, the mark may need to be updated.
      (previous-mark) % pop off old mark
      (set-mark-from-point) % set the mark to the end of the transformed region
      (buffer-set-position point)
      )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Auxiliary Function:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de set-up-shifted-digits-association-list ()
  % Ensure that the "shifted digits association list" is set up properly.
  % If necessary, ask the user for the required information.  Returns the
  % association list if properly set up, NIL if an error occurred.

  (if (not shifted-digits-association-list)
    (let ((shifted-digits
	   (prompt-for-string 
	    "Type the digits 1, 2, ... 9, 0, holding down Shift:" nil)))
      (cond ((= (string-length shifted-digits) 10) 
	     (setq shifted-digits-association-list
		   (pair 
		    (string-to-list "1234567890")
		    (string-to-list shifted-digits))))
	    ((> (string-length shifted-digits) 10)
	     (nmode-error "Typed too many shifted digits!"))
	    (t
	     (nmode-error "Typed too few shifted digits!"))
	    )))
  shifted-digits-association-list
  )