[mcclim-cvs] CVS mcclim/Examples

[dlichteblau]

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

Modified Files:
	text-size-test.lisp 
Log Message:
Visualize text-style-ascent, -descent, -width, -height, and -fixed-width-p.
Print a legend.


--- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp	2006/05/09 20:07:54	1.3
+++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp	2006/12/20 12:30:44	1.4
@@ -45,7 +45,7 @@
    (size
     (make-pane 'slider
 	       :orientation :horizontal
-	       :value 200
+	       :value 160
 	       :min-value 1
 	       :max-value 1000)))
   (:layouts
@@ -59,6 +59,30 @@
 	 (labelling (:label "Size") size)
 	 canvas))))
 
+(defun draw-vstrecke (stream x y1 y2 &rest args &key ink &allow-other-keys)
+  (draw-line* stream (- x 10) y1 (+ x 10) y1 :ink ink)
+  (draw-line* stream (- x 10) y2 (+ x 10) y2 :ink ink)
+  (apply #'draw-arrow* stream x y1 x y2 args))
+
+(defun draw-hstrecke (stream y x1 x2 &rest args &key ink &allow-other-keys)
+  (draw-line* stream x1 (- y 10) x1 (+ y 10) :ink ink)
+  (draw-line* stream x2 (- y 10) x2 (+ y 10) :ink ink)
+  (apply #'draw-arrow* stream x1 y x2 y args))
+
+(defun legend-text-style ()
+  (make-text-style :sans-serif :roman :small))
+
+(defun draw-legend (stream &rest entries)
+  (let* ((style (legend-text-style))
+	 (y 2)
+	 (h (nth-value 1 (text-size stream "dummy" :text-style style))))
+    (dolist (entry entries)
+      (when entry
+	(incf y h)
+	(let ((y* (+ 0.5 (round (- y (/ h 2))))))
+	  (apply #'draw-line* stream 2 y* 35 y* (cdr entry)))
+	(draw-text* stream (car entry) 40 y :text-style style)))))
+
 (defmethod display-canvas (frame stream)
   (window-clear stream)
   (let* ((pane-width (rectangle-width (sheet-region stream)))
@@ -70,11 +94,59 @@
 	  (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)))
+	 (style (make-text-style family face size))
+	 (medium (sheet-medium stream)))
     (multiple-value-bind (width height final-x final-y baseline)
 	(text-size stream str :text-style style)
       (let ((x1 (/ (- pane-width width) 2))
 	    (y1 (/ (- pane-height height) 2)))
+	(draw-text* stream
+		    (format nil "fixed-width-p: ~(~A~)"
+			    (handler-case
+				(text-style-fixed-width-p style medium)
+			      (error (c)
+				c)))
+		    2
+		    pane-height
+		    :text-style (legend-text-style))
+	(draw-legend stream
+		     (list "Ascent"
+			   ;; :line-style (make-line-style :dashes '(1.5))
+			   :ink +black+)
+		     (list "Descent" :ink +black+)
+		     (list "Height"
+			   :line-style (make-line-style :thickness 2)
+			   :ink +black+)
+		     (list "Width (Avg.)" :ink +black+)
+		     (list "Baseline" :ink +green+)
+		     (when (eq rectangle :text-bounding-rectangle)
+		       (list "Bounding rectangle" :ink +purple+))
+		     (when (eq rectangle :text-size)
+		       (list "Text size (width/height)" :ink +red+))
+		     (when (eq rectangle :text-size)
+		       (list "Text size (final x/y)" :ink +blue+)))
+	(draw-vstrecke stream
+		      (- x1 20)
+		      (+ y1 (text-style-ascent style medium))
+		      y1
+		      ;; :line-style (make-line-style :dashes '(1.5))
+		      :ink +black+)
+	(draw-vstrecke stream
+		      (- x1 40)
+		      (+ y1 baseline)
+		      (+ y1 baseline (text-style-descent style medium))
+		      :ink +black+)
+	(draw-vstrecke stream
+		      (- x1 60)
+		      y1
+		      (+ y1 (text-style-height style medium))
+		      :line-style (make-line-style :thickness 2)
+		      :ink +black+)
+	(draw-hstrecke stream
+		       (- y1 20)
+		       x1
+		       (+ x1 (text-style-width style medium))
+		       :ink +black+)
 	(draw-line* stream
 		    0 (+ y1 baseline)
 		    pane-width (+ y1 baseline)
@@ -99,7 +171,7 @@
                             :filled nil))
           ((:text-bounding-rectangle)
            (multiple-value-bind (left top right bottom)
-               (climi::text-bounding-rectangle* (sheet-medium stream) str :text-style style)
+               (climi::text-bounding-rectangle* medium str :text-style style)
              (draw-rectangle* stream 
                               (+ x1 left) (+ y1 baseline top)
                               (+ x1 right) (+ y1 baseline bottom)