[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp

[Robert Strandh]

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