[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
Robert Strandh
rstrandh at common-lisp.net
Sun Jan 9 14:08:28 UTC 2005
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
More information about the Climacs-cvs
mailing list