Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3491 Modified Files: base.lisp gui.lisp packages.lisp Log Message: upcase, downcase, capitalize words from Rudi Schlatte. Thanks! Date: Sun Jan 9 15:08:27 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.13 climacs/base.lisp:1.14 --- climacs/base.lisp:1.13 Sun Jan 9 12:54:50 2005 +++ climacs/base.lisp Sun Jan 9 15:08:26 2005 @@ -111,20 +111,28 @@ #+sbcl (sb-impl::whitespacep obj) #-sbcl (member obj '(#\Space #\Tab)))) -(defun forward-word (mark) - "Forward the mark to the next word." +(defun forward-to-word-boundary (mark) + "Forward the mark forward to the beginning of the next word." (loop until (end-of-buffer-p mark) until (constituentp (object-after mark)) - do (incf (offset mark))) + do (incf (offset mark)))) + +(defun backward-to-word-boundary (mark) + "Move the mark backward to the end of the previous word." + (loop until (beginning-of-buffer-p mark) + until (constituentp (object-before mark)) + do (decf (offset mark)))) + +(defun forward-word (mark) + "Forward the mark to the next word." + (forward-to-word-boundary mark) (loop until (end-of-buffer-p mark) while (constituentp (object-after mark)) do (incf (offset mark)))) (defun backward-word (mark) "Shuttle the mark to the start of the previous word." - (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) - do (decf (offset mark))) + (backward-to-word-boundary mark) (loop until (beginning-of-buffer-p mark) while (constituentp (object-before mark)) do (decf (offset mark)))) @@ -155,6 +163,45 @@ (constituentp (buffer-object (buffer mark) (1- i)))) finally (return i)) mark)) + +(defun downcase-word (mark &optional (n 1)) + "Convert the next N words to lowercase, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (loop until (end-of-buffer-p mark) + while (constituentp (object-after mark)) + for character = (object-after mark) + if (upper-case-p character) + do (progn (delete-range mark 1) + (insert-object mark (char-downcase character))) + else + do (incf (offset mark))))) + +(defun upcase-word (mark &optional (n 1)) + "Convert the next N words to uppercase, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (loop until (end-of-buffer-p mark) + while (constituentp (object-after mark)) + for character = (object-after mark) + when (lower-case-p character) + do (progn + (delete-range mark 1) + (insert-object mark (char-upcase character))) + else + do (incf (offset mark))))) + +(defun capitalize-word (mark &optional (n 1)) + "Capitalize the next N words, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (unless (end-of-buffer-p mark) + (let ((character (object-after mark))) + (when (lower-case-p character) + (delete-range mark 1) + (insert-object mark (char-upcase character)))) + (when (constituentp (object-after mark)) + (downcase-word mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.59 climacs/gui.lisp:1.60 --- climacs/gui.lisp:1.59 Sun Jan 9 12:54:50 2005 +++ climacs/gui.lisp Sun Jan 9 15:08:27 2005 @@ -378,6 +378,15 @@ (define-named-command com-backward-delete-word () (backward-delete-word (point (win *application-frame*)))) +(define-named-command com-upcase-word () + (upcase-word (point (win *application-frame*)))) + +(define-named-command com-downcase-word () + (downcase-word (point (win *application-frame*)))) + +(define-named-command com-capitalize-word () + (capitalize-word (point (win *application-frame*)))) + (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) @@ -683,6 +692,9 @@ (global-set-key '(#\f :meta) 'com-forward-word) (global-set-key '(#\b :meta) 'com-backward-word) (global-set-key '(#\t :meta) 'com-transpose-words) +(global-set-key '(#\u :meta) 'com-upcase-word) +(global-set-key '(#\l :meta) 'com-downcase-word) +(global-set-key '(#\c :meta) 'com-capitalize-word) (global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\y :meta) 'com-rotate-yank) (global-set-key '(#\w :meta) 'com-copy-out) @@ -690,7 +702,6 @@ (global-set-key '(#\v :meta) 'com-page-up) (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) -(global-set-key '(#\u :meta) 'com-browse-url) (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.25 climacs/packages.lisp:1.26 --- climacs/packages.lisp:1.25 Sun Jan 9 12:54:50 2005 +++ climacs/packages.lisp Sun Jan 9 15:08:27 2005 @@ -49,6 +49,7 @@ #:constituentp #:whitespacep #:forward-word #:backward-word #:delete-word #:backward-delete-word + #:upcase-word #:downcase-word #:capitalize-word #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-lookin-at #:looking-at