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

Modified Files: demodemo.lisp Added Files: font-selector.lisp Log Message: Enable support for extended text styles using strings for family and face, as already implemented in CLIM-CLX. Teach Gtkairo do the same.

Add an API for font listing (implemented in CLX and Gtkairo, plus a trivial fallback implementation for other backends) and a font selection dialog as an example.

* Doc/mcclim.texi: New chapter "Fonts and Extended Text Styles" * Examples/font-selector.lisp: New file. * Examples/demodemo.lisp: Added a button for the font selector. * mcclim.asd (CLIM-EXAMPLES): Added font-selector.lisp. * package.lisp (CLIM-EXTENSIONS): Export new symbols font-family font-face port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style.

* medium.lisp (MAKE-TEXT-STYLE, TEXT-STYLE-EQUALP): Allow strings for family and face. (MAKE-TEXT-STYLE-1): New helper function.

* ports.lisp (FONT-FAMILY, FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New generic functions and default methods.

* Backends/CLX/port.lisp (FONT-FAMILIES): New slot in the port. (CLX-FONT-FAMILY, CLX-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (SPLIT-FONT-NAME, RELOAD-FONT-TABLE, MAKE-UNFRIEDLY-NAME): New helper functions.

* Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Support strings for family and face. (PANGO-FONT-FAMILY, PANGO-FONT-FACE): New classes. (port-all-font-families font-family-name font-family-port font-family-all-faces font-face-name font-face-family font-face-all-sizes font-face-scalable-p font-face-text-style): New methods. (INVOKE-LISTER, pango-font-family-list-faces, pango-font-face-list-sizes): New helper functions.

* Backends/gtkairo/port.lisp (GLOBAL-PANGO-CONTEXT): New slot in the port. ((INITIALIZE-INSTANCE GTKAIRO-PORT)): Set the pango context.

* Backends/gtkairo/ffi.lisp: regenerated.

--- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/23 21:44:04 1.15 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/12/24 14:27:48 1.16 @@ -67,7 +67,14 @@ (make-demo-button "Colorslider" 'colorslider) (make-demo-button "Goatee Test" 'goatee::goatee-test) (make-demo-button "D&D Translator" 'drag-test) - (make-demo-button "Draggable Graph" 'draggable-graph-demo))) + (make-demo-button "Draggable Graph" 'draggable-graph-demo) + (make-pane 'push-button + :label "Font Selector" + :activate-callback + (lambda (&rest ignore) + (declare (ignore ignore)) + (format *trace-output* "~&You chose: ~A~%" + (select-font)))))) (labelling (:label "Tests") (vertically (:equalize-width t) (make-demo-button "Label Test" 'label-test)

--- /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2006/12/24 14:27:48 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2006/12/24 14:27:48 1.1 ;;; -*- Mode: Lisp; show-trailing-whitespace: t; indent-tabs: nil -*-

;;; A font selection dialog.

#|

(clim-demo::select-font)

(clim-demo::select-font :port (clim:find-port :server-path (list :ps :stream *standard-output*)))

|#

;;; (c) 2006 David Lichteblau (david@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)

(defun select-font (&key (port (find-port))) (let ((frame (make-application-frame 'font-selector :font-selector-port port))) (run-frame-top-level frame) (font-selector-text-style frame)))

(define-application-frame font-selector () ((font-selector-port :initarg :font-selector-port :accessor font-selector-port) (font-selector-text-style :accessor font-selector-text-style)) (:menu-bar nil) (:panes (canvas :application :height 150 :scroll-bars nil :display-time t :display-function 'display-font-preview) (family (make-pane 'list-pane :items nil :name-key #'font-family-name :value-changed-callback 'family-changed)) (face (make-pane 'list-pane :items nil :name-key #'font-face-name :value-changed-callback 'face-changed)) (size (make-pane 'list-pane :items nil :value-changed-callback 'size-changed))) (:layouts (default (vertically (:height 400 :width 600) (horizontally () (labelling (:label "Family") (scrolling () family)) (labelling (:label "Face") (scrolling () face)) (labelling (:label "Size") (scrolling () size))) canvas (horizontally () +fill+ (make-pane 'push-button :label "OK" :activate-callback (lambda (ignore) ignore (frame-exit *application-frame*))) (make-pane 'push-button :label "Cancel" :activate-callback (lambda (ignore) ignore (setf (font-selector-text-style *application-frame*) nil) (frame-exit *application-frame*))))))))

(defmethod generate-panes :after (fm (frame font-selector)) (reset-list-pane (find-pane-named frame 'family) (port-all-font-families (font-selector-port *application-frame*))))

(defun family-changed (pane value) (declare (ignore pane)) (let* ((face-list (find-pane-named *application-frame* 'face)) (old-face (and (slot-boundp face-list 'climi::value) (gadget-value face-list))) (new-faces (font-family-all-faces value))) (reset-list-pane face-list new-faces) (when old-face (setf (gadget-value face-list :invoke-callback t) (find (font-face-name old-face) new-faces :key #'font-face-name :test #'equal)))))

(defun face-changed (pane value) (declare (ignore pane)) (let ((sizes (if value (font-face-all-sizes value) nil))) (reset-list-pane (find-pane-named *application-frame* 'size) sizes (or (position-if (lambda (x) (>= x 20)) sizes) 0))))

(defun size-changed (pane value) (declare (ignore pane)) (setf (font-selector-text-style *application-frame*) (let ((face (gadget-value (find-pane-named *application-frame* 'face)))) (if (and face value) (font-face-text-style face value) nil))) (display-font-preview *application-frame* (frame-standard-output *application-frame*)))

(defun reset-list-pane (pane items &optional (index 0)) (setf (climi::list-pane-items pane :invoke-callback nil) items) (setf (gadget-value pane :invoke-callback t) (or (and (slot-boundp pane 'climi::value) (gadget-value pane)) (let ((values (climi::generic-list-pane-item-values pane))) (if (plusp (length values)) (elt values index) nil)))))

(defmethod display-font-preview (frame stream) (window-clear stream) (let* ((pane-width (rectangle-width (sheet-region stream))) (pane-height (rectangle-height (sheet-region stream))) (str "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (style (font-selector-text-style frame)) (ok nil)) (cond ((not (eq (port frame) (font-selector-port frame))) (setf str (format nil "Cannot preview font for ~A" (font-selector-port frame))) (setf style (make-text-style :sans-serif :italic :normal))) ((null style) (setf str "Error: Text style is null") (setf style (make-text-style :sans-serif :italic :normal))) (t (setf ok t))) (multiple-value-bind (width height final-x final-y baseline) (text-size stream str :text-style style) (declare (ignore final-x final-y)) (let* ((x1 (/ (- pane-width width) 2)) (y1 (/ (- pane-height height) 2)) (y2 (+ y1 height)) (ybase (+ y1 baseline))) (when ok (draw-line* stream 0 ybase pane-width ybase :ink +green+) (draw-line* stream 0 y1 pane-width y1 :ink +blue+) (draw-line* stream 0 y2 pane-width y2 :ink +blue+)) (handler-case (draw-text* stream str x1 ybase :text-style style) (error (c) (princ c)))))))