[mcclim-cvs] CVS mcclim/Examples

[crhodes]

Update of /project/mcclim/cvsroot/mcclim/Examples
In directory clnet:/tmp/cvs-serv28012/Examples

Modified Files:
	text-size-test.lisp 
Log Message:
Add text-bounding-rectangle* mode to text-size-test


--- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp	2006/04/17 17:54:58	1.1
+++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp	2006/04/19 11:43:31	1.2
@@ -37,6 +37,11 @@
     (with-radio-box (:type :some-of)
       (make-pane 'toggle-button :label "Bold" :id :bold)
       (make-pane 'toggle-button :label "Italic" :id :italic)))
+   (rectangle
+    (with-radio-box ()
+      (radio-box-current-selection
+       (make-pane 'toggle-button :label "Text-Size" :id :text-size))
+      (make-pane 'toggle-button :label "Text-Bounding-Rectangle" :id :text-bounding-rectangle)))
    (size
     (make-pane 'slider
 	       :orientation :horizontal
@@ -49,7 +54,8 @@
 	 (labelling (:label "Text") text)
 	 (horizontally ()
 	   (labelling (:label "Family") family)
-	   (labelling (:label "Face") face))
+	   (labelling (:label "Face") face)
+           (labelling (:label "Rectangle") rectangle))
 	 (labelling (:label "Size") size)
 	 canvas))))
 
@@ -62,6 +68,7 @@
 	 (family (gadget-id (gadget-value (find-pane-named frame 'family))))
 	 (faces
 	  (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face))))
+         (rectangle (gadget-id (gadget-value (find-pane-named frame 'rectangle))))
 	 (face (if (cdr faces) '(:bold :italic) (car faces)))
 	 (style (make-text-style family face size)))
     (multiple-value-bind (width height final-x final-y baseline)
@@ -78,16 +85,26 @@
 ;;;	(setf (stream-cursor-position stream) (values x1 y1))
 ;;;	(with-text-style (stream style)
 ;;;	  (write-string str stream))
-	(draw-rectangle* stream
-			 x1 y1
-			 (+ x1 width) (+ y1 height)
-			 :ink +red+
-			 :filled nil)
-	(draw-rectangle* stream
-			 x1 y1
-			 (+ x1 final-x) (+ y1 final-y)
-			 :ink +blue+
-			 :filled nil)))))
+        (ecase rectangle
+          ((:text-size)
+           (draw-rectangle* stream
+                            x1 y1
+                            (+ x1 width) (+ y1 height)
+                            :ink +red+
+                            :filled nil)
+           (draw-rectangle* stream
+                            x1 y1
+                            (+ x1 final-x) (+ y1 final-y)
+                            :ink +blue+
+                            :filled nil))
+          ((:text-bounding-rectangle)
+           (multiple-value-bind (left top right bottom)
+               (climi::text-bounding-rectangle* (sheet-medium stream) str :text-style style)
+             (draw-rectangle* stream 
+                              (+ x1 left) (+ y1 baseline top)
+                              (+ x1 right) (+ y1 baseline bottom)
+                              :ink +purple+
+                              :filled nil))))))))
 
 (define-text-size-test-command (com-quit-text-size-test :menu "Quit") ()
   (frame-exit *application-frame*))