[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp - climacs-cvs@common-lisp.net - mailman3.common-lisp.net

13 Jan 2005

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv7173
Modified Files:
    base.lisp gui.lisp packages.lisp 
Log Message:
Added upcase/downcase/capitalize-region, and a do-buffer-region macro
Date: Thu Jan 13 16:34:05 2005
Author: mvilleneuve
Index: climacs/base.lisp
diff -u climacs/base.lisp:1.14 climacs/base.lisp:1.15

--- climacs/base.lisp:1.14	Sun Jan  9 15:08:26 2005
+++ climacs/base.lisp	Thu Jan 13 16:34:05 2005
@@ -28,12 +28,23 @@
(in-package :climacs-base)
+(defmacro do-buffer-region ((object offset buffer offset1 offset2)
+                            &body body)
+  "Iterate over the elements of the region delimited by offset1 and offset2.
+The body is executed for each element, with object being the current object
+(setf-able), and offset being its offset."
+  `(symbol-macrolet ((,object (buffer-object ,buffer ,offset)))
+     (loop for ,offset from ,offset1 to ,offset2
+           do ,@body)))
+
 (defgeneric backward-object (mark &optional count))
+
 (defmethod backward-object ((mark climacs-buffer::mark-mixin)
                             &optional (count 1))
   (decf (offset mark) count))
(defgeneric forward-object (mark &optional count))
+
 (defmethod forward-object ((mark climacs-buffer::mark-mixin)
                            &optional (count 1))
   (incf (offset mark) count))
@@ -164,44 +175,106 @@
     finally (return i))
    mark))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
+;;; Character case
+
+(defun downcase-buffer-region (buffer offset1 offset2)
+  (do-buffer-region (object offset buffer offset1 offset2)
+    (when (and (constituentp object) (upper-case-p object))
+      (setf object (char-downcase object)))))
+
+(defgeneric downcase-region (mark1 mark2)
+  (:documentation "Convert all characters after mark1 and before mark2 to
+lowercase. An error is signaled if the two marks are positioned in different
+buffers. It is acceptable to pass an offset in place of one of the marks."))
+
+(defmethod downcase-region ((mark1 climacs-buffer::mark-mixin)
+                            (mark2 climacs-buffer::mark-mixin))
+  (assert (eq (buffer mark1) (buffer mark2)))
+  (downcase-buffer-region (buffer mark1) (offset mark1) (offset mark2)))
+
+(defmethod downcase-region ((offset integer) (mark climacs-buffer::mark-mixin))
+  (downcase-buffer-region (buffer mark) offset (offset mark)))
+
+(defmethod downcase-region ((mark climacs-buffer::mark-mixin) (offset integer))
+  (downcase-buffer-region (buffer mark) (offset mark) offset))
+
 (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)))))
+  (loop repeat n
+        do (forward-to-word-boundary mark)
+           (let ((offset (offset mark)))
+             (forward-word mark)
+             (downcase-region offset mark))))
+
+(defun upcase-buffer-region (buffer offset1 offset2)
+  (do-buffer-region (object offset buffer offset1 offset2)
+    (when (and (constituentp object) (lower-case-p object))
+      (setf object (char-upcase object)))))
+
+(defgeneric upcase-region (mark1 mark2)
+  (:documentation "Convert all characters after mark1 and before mark2 to
+uppercase. An error is signaled if the two marks are positioned in different
+buffers. It is acceptable to pass an offset in place of one of the marks."))
+
+(defmethod upcase-region ((mark1 climacs-buffer::mark-mixin)
+                          (mark2 climacs-buffer::mark-mixin))
+  (assert (eq (buffer mark1) (buffer mark2)))
+  (upcase-buffer-region (buffer mark1) (offset mark1) (offset mark2)))
+
+(defmethod upcase-region ((offset integer) (mark climacs-buffer::mark-mixin))
+  (upcase-buffer-region (buffer mark) offset (offset mark)))
+
+(defmethod upcase-region ((mark climacs-buffer::mark-mixin) (offset integer))
+  (upcase-buffer-region (buffer mark) (offset mark) offset))
(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)))))
+  (loop repeat n
+        do (forward-to-word-boundary mark)
+           (let ((offset (offset mark)))
+             (forward-word mark)
+             (upcase-region offset mark))))
+
+(defun capitalize-buffer-region (buffer offset1 offset2)
+  (let ((previous-char-constituent-p
+         (and (plusp offset1)
+              (constituentp (buffer-object buffer (1- offset1))))))
+    (do-buffer-region (object offset buffer offset1 offset2)
+      (when (constituentp object)
+        (if previous-char-constituent-p
+            (when (upper-case-p object)
+              (setf object (char-downcase object)))
+            (when (lower-case-p object)
+              (setf object (char-upcase object)))))
+      (setf previous-char-constituent-p (constituentp object)))))
+
+(defgeneric capitalize-region (mark1 mark2)
+  (:documentation "Capitalize all words after mark1 and before mark2.
+An error is signaled if the two marks are positioned in different buffers.
+It is acceptable to pass an offset in place of one of the marks."))
+
+(defmethod capitalize-region ((mark1 climacs-buffer::mark-mixin)
+                              (mark2 climacs-buffer::mark-mixin))
+  (assert (eq (buffer mark1) (buffer mark2)))
+  (capitalize-buffer-region (buffer mark1) (offset mark1) (offset mark2)))
+
+(defmethod capitalize-region ((offset integer)
+                              (mark climacs-buffer::mark-mixin))
+  (capitalize-buffer-region (buffer mark) offset (offset mark)))
+
+(defmethod capitalize-region ((mark climacs-buffer::mark-mixin)
+                              (offset integer))
+  (capitalize-buffer-region (buffer mark) (offset mark) offset))
(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)))))
+  (loop repeat n
+        do (forward-to-word-boundary mark)
+           (let ((offset (offset mark)))
+             (forward-word mark)
+             (capitalize-region offset mark))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.63 climacs/gui.lisp:1.64
--- climacs/gui.lisp:1.63	Thu Jan 13 06:38:41 2005
+++ climacs/gui.lisp	Thu Jan 13 16:34:05 2005
@@ -238,6 +238,12 @@
          (setf (needs-saving buffer) t)))
      (redisplay-frame-panes frame))))
+(defun region-limits (pane)
+  (with-slots (point mark) pane
+    (if (< (offset mark) (offset point))
+        (values mark point)
+        (values point mark))))
+
 (defmacro define-named-command (command-name args &body body)
   `(define-climacs-command ,(if (listp command-name)
    			`(,@command-name :name t)
@@ -383,6 +389,18 @@
 (define-named-command com-backward-delete-word ()
   (backward-delete-word (point (win *application-frame*))))
+(define-named-command com-upcase-region ()
+  (multiple-value-bind (start end) (region-limits (win *application-frame*))
+    (upcase-region start end)))
+
+(define-named-command com-downcase-region ()
+  (multiple-value-bind (start end) (region-limits (win *application-frame*))
+    (downcase-region start end)))
+
+(define-named-command com-capitalize-region ()
+  (multiple-value-bind (start end) (region-limits (win *application-frame*))
+    (capitalize-region start end)))
+
 (define-named-command com-upcase-word ()
   (upcase-word (point (win *application-frame*))))
@@ -593,13 +611,9 @@
;; Destructively cut a given buffer region into the kill-ring
 (define-named-command com-cut-out ()
-  (with-slots (point mark)(win *application-frame*)
-     (cond ((< (offset mark)(offset point))
-	    (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))
-	    (delete-region (offset mark) point))
-	   (t
-	    (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
-	    (delete-region (offset point) mark)))))
+  (multiple-value-bind (start end) (region-limits (win *application-frame*))
+    (kill-ring-standard-push *kill-ring* (region-to-sequence start end))
+    (delete-region (offset start) end)))
;; Non destructively copies in buffer region to the kill ring
 (define-named-command com-copy-out ()
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.27 climacs/packages.lisp:1.28
--- climacs/packages.lisp:1.27	Thu Jan 13 06:38:41 2005
+++ climacs/packages.lisp	Thu Jan 13 16:34:05 2005
@@ -42,13 +42,15 @@
(defpackage :climacs-base
   (:use :clim-lisp :climacs-buffer)
-  (:export #:forward-object #:backward-object
+  (:export #:do-buffer-region
+           #:forward-object #:backward-object
       #:previous-line #:next-line
       #:open-line #:kill-line
       #:number-of-lines-in-region
       #:constituentp #:whitespacep
       #:forward-word #:backward-word
       #:delete-word #:backward-delete-word
+           #:upcase-region #:downcase-region #:capitalize-region
            #:upcase-word #:downcase-word #:capitalize-word
       #:input-from-stream #:output-to-stream
       #:name-mixin #:name

    