[mcclim-cvs] CVS mcclim/Examples - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

19 Apr 2006

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*))

    