[mcclim-cvs] CVS mcclim/Examples

[dlichteblau]

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

Modified Files:
	demodemo.lisp 
Added Files:
	text-size-test.lisp 
Log Message:
* Examples/text-size-test.lisp: New file.  Visual test for the TEXT-SIZE
function.

* Examples/demodemo.lisp: Added a button for text-size-test.

* mcclim.asd (clim-examples): Added text-size-test.lisp.


--- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp	2006/04/10 09:48:40	1.9
+++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp	2006/04/17 17:54:58	1.10
@@ -72,7 +72,8 @@
                    (make-demo-button "Table Test" 'table-test)
                    (make-demo-button "Scroll Test" 'Scroll-test)
                    (make-demo-button "List Test" 'list-test)
-                   (make-demo-button "HBOX Test"  'hbox-test)))))))))
+                   (make-demo-button "HBOX Test"  'hbox-test)
+                   (make-demo-button "Text Size Test"  'text-size-test)))))))))
 
 (defun demodemo ()
   #+nil

--- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp	2006/04/17 17:54:59	NONE
+++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp	2006/04/17 17:54:59	1.1
;;; -*- Mode: Lisp; -*-

;;;  (c) 2006 David Lichteblau (david at lichteblau.com)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(in-package :clim-demo)

(define-application-frame text-size-test ()
    ()
  (:panes
   (canvas :application
	   :min-width 600
	   :display-time t
	   :display-function 'display-canvas)
   (text (make-pane 'text-field :value "ytmM"))
   (family
    (with-radio-box ()
      (make-pane 'toggle-button :label "Fixed" :id :fixed)
      (radio-box-current-selection
       (make-pane 'toggle-button :label "Serif" :id :serif))
      (make-pane 'toggle-button :label "Sans Serif" :id :sans-serif)))
   (face
    (with-radio-box (:type :some-of)
      (make-pane 'toggle-button :label "Bold" :id :bold)
      (make-pane 'toggle-button :label "Italic" :id :italic)))
   (size
    (make-pane 'slider
	       :orientation :horizontal
	       :value 200
	       :min-value 1
	       :max-value 1000)))
  (:layouts
   (default
       (vertically ()
	 (labelling (:label "Text") text)
	 (horizontally ()
	   (labelling (:label "Family") family)
	   (labelling (:label "Face") face))
	 (labelling (:label "Size") size)
	 canvas))))

(defmethod display-canvas (frame stream)
  (window-clear stream)
  (let* ((pane-width (rectangle-width (sheet-region stream)))
	 (pane-height (rectangle-height (sheet-region stream)))
	 (str (gadget-value (find-pane-named frame 'text)))
	 (size (gadget-value (find-pane-named frame 'size)))
	 (family (gadget-id (gadget-value (find-pane-named frame 'family))))
	 (faces
	  (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face))))
	 (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)
	(text-size stream str :text-style style)
      (let ((x1 (/ (- pane-width width) 2))
	    (y1 (/ (- pane-height height) 2)))
	(draw-line* stream
		    0 (+ y1 baseline)
		    pane-width (+ y1 baseline)
		    :ink +green+)
	(draw-text* stream str x1 (+ y1 baseline) :text-style style)
	;; Here an attempt at testing text with newlines, results are garbage
	;; even with CLIM-CLX:
;;;	(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)))))

(define-text-size-test-command (com-quit-text-size-test :menu "Quit") ()
  (frame-exit *application-frame*))

(define-text-size-test-command (com-update :menu "Update") ()
  (display-canvas *application-frame*
		  (frame-standard-output *application-frame*)))