Index: mcclim.asd =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/mcclim.asd,v retrieving revision 1.41 diff -u -u -r1.41 mcclim.asd --- mcclim.asd 20 Dec 2006 18:45:54 -0000 1.41 +++ mcclim.asd 24 Dec 2006 13:58:41 -0000 @@ -465,7 +465,8 @@ (:file "text-size-test") (:file "drawing-benchmark") (:file "logic-cube") - (:file "views"))) + (:file "views") + (:file "font-selector"))) (:module "Goatee" :components ((:file "goatee-test"))))) Index: medium.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/medium.lisp,v retrieving revision 1.60 diff -u -u -r1.60 medium.lisp --- medium.lisp 5 May 2006 10:24:02 -0000 1.60 +++ medium.lisp 24 Dec 2006 13:58:41 -0000 @@ -126,14 +126,25 @@ (defvar *text-style-hash-table* (make-hash-table :test #'eql))) (defun make-text-style (family face size) - (let ((key (text-style-key family face size))) - (declare (type fixnum key)) - (or (gethash key *text-style-hash-table*) - (setf (gethash key *text-style-hash-table*) - (make-instance 'standard-text-style - :text-family family - :text-face face - :text-size size))))) + (if (and (symbolp family) + (or (symbolp face) + (and (listp face) (every #'symbolp face)))) + ;; Portable text styles have always been cached in McCLIM like this: + ;; (as permitted by the CLIM spec for immutable objects, section 2.4) + (let ((key (text-style-key family face size))) + (declare (type fixnum key)) + (or (gethash key *text-style-hash-table*) + (setf (gethash key *text-style-hash-table*) + (make-text-style-1 family face size)))) + ;; Extended text styles using string components could be cached using + ;; an appropriate hash table, but for now we just re-create them: + (make-text-style-1 family face size))) + +(defun make-text-style-1 (family face size) + (make-instance 'standard-text-style + :text-family family + :text-face face + :text-size size)) ) ; end eval-when @@ -143,8 +154,8 @@ (defmethod text-style-equalp ((style1 standard-text-style) (style2 standard-text-style)) - (and (eql (text-style-family style1) (text-style-family style2)) - (eql (text-style-face style1) (text-style-face style2)) + (and (equal (text-style-family style1) (text-style-family style2)) + (equal (text-style-face style1) (text-style-face style2)) (eql (text-style-size style1) (text-style-size style2)))) (defconstant *default-text-style* (make-text-style :fix :roman :normal)) Index: package.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/package.lisp,v retrieving revision 1.58 diff -u -u -r1.58 package.lisp --- package.lisp 23 Dec 2006 21:44:03 -0000 1.58 +++ package.lisp 24 Dec 2006 13:58:41 -0000 @@ -1922,7 +1922,19 @@ #:simple-event-loop #:pointer-motion-hint-event #:frame-display-pointer-documentation-string - #:list-pane-items)) + #:list-pane-items + ;; Font listing extension: + #: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)) ;;; Symbols that must be defined by a backend. ;;; Index: ports.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/ports.lisp,v retrieving revision 1.53 diff -u -u -r1.53 ports.lisp --- ports.lisp 1 Jul 2006 21:31:41 -0000 1.53 +++ ports.lisp 24 Dec 2006 13:58:41 -0000 @@ -322,3 +322,122 @@ (defmethod set-sheet-pointer-cursor ((port basic-port) sheet cursor) (declare (ignore sheet cursor)) (warn "Port ~A has not implemented sheet pointer cursors." port)) + +;;;; +;;;; Font listing extension +;;;; + +(defgeneric port-all-font-families + (port &key invalidate-cache &allow-other-keys) + (:documentation + "Returns the list of all FONT-FAMILY instances known by PORT. +With INVALIDATE-CACHE, cached font family information is discarded, if any.")) + +(defgeneric font-family-name (font-family) + (:documentation + "Return the font family's name. This name is meant for user display, +and does not, at the time of this writing, necessarily the same string +used as the text style family for this port.")) + +(defgeneric font-family-port (font-family) + (:documentation "Return the port this font family belongs to.")) + +(defgeneric font-family-all-faces (font-family) + (:documentation + "Return the list of all font-face instances for this family.")) + +(defgeneric font-face-name (font-face) + (:documentation + "Return the font face's name. This name is meant for user display, +and does not, at the time of this writing, necessarily the same string +used as the text style face for this port.")) + +(defgeneric font-face-family (font-face) + (:documentation "Return the font family this face belongs to.")) + +(defgeneric font-face-all-sizes (font-face) + (:documentation + "Return the list of all font sizes known to be valid for this font, +if the font is restricted to particular sizes. For scalable fonts, arbitrary +sizes will work, and this list represents only a subset of the valid sizes. +See font-face-scalable-p.")) + +(defgeneric font-face-scalable-p (font-face) + (:documentation + "Return true if this font is scalable, as opposed to a bitmap font. For +a scalable font, arbitrary font sizes are expected to work.")) + +(defgeneric font-face-text-style (font-face &optional size) + (:documentation + "Return an extended text style describing this font face in the specified +size. If size is nil, the resulting text style does not specify a size.")) + +(defclass font-family () + ((font-family-port :initarg :port :reader font-family-port) + (font-family-name :initarg :name :reader font-family-name)) + (:documentation "The protocol class for font families. Each backend +defines a subclass of font-family and implements its accessors. Font +family instances are never created by user code. Use port-all-font-families +to list all instances available on a port.")) + +(defmethod print-object ((object font-family) stream) + (print-unreadable-object (object stream :type t :identity nil) + (format stream "~A" (font-family-name object)))) + +(defclass font-face () + ((font-face-family :initarg :family :reader font-face-family) + (font-face-name :initarg :name :reader font-face-name)) + (:documentation "The protocol class for font faces Each backend +defines a subclass of font-face and implements its accessors. Font +face instances are never created by user code. Use font-family-all-faces +to list all faces of a font family.")) + +(defmethod print-object ((object font-face) stream) + (print-unreadable-object (object stream :type t :identity nil) + (format stream "~A, ~A" + (font-family-name (font-face-family object)) + (font-face-name object)))) + +;;; fallback font listing implementation: + +(defclass basic-font-family (font-family) ()) +(defclass basic-font-face (font-face) ()) + +(defmethod port-all-font-families ((port basic-port) &key invalidate-cache) + (declare (ignore invalidate-cache)) + (flet ((make-basic-font-family (name) + (make-instance 'basic-font-family :port port :name name))) + (list (make-basic-font-family "FIX") + (make-basic-font-family "SERIF") + (make-basic-font-family "SANS-SERIF")))) + +(defmethod font-family-all-faces ((family basic-font-family)) + (flet ((make-basic-font-face (name) + (make-instance 'basic-font-face :family family :name name))) + (list (make-basic-font-face "ROMAN") + (make-basic-font-face "BOLD") + (make-basic-font-face "BOLD-ITALIC") + (make-basic-font-face "ITALIC")))) + +(defmethod font-face-all-sizes ((face basic-font-face)) + (list 1 2 3 4 5 6 7)) + +(defmethod font-face-scalable-p ((face basic-font-face)) + nil) + +(defmethod font-face-text-style ((face basic-font-face) &optional size) + (make-text-style + (find-symbol (string-upcase (font-family-name (font-face-family face))) + :keyword) + (if (string-equal (font-face-name face) "BOLD-ITALIC") + '(:bold :italic) + (find-symbol (string-upcase (font-face-name face)) :keyword)) + (ecase size + ((nil) nil) + (1 :tiny) + (2 :very-small) + (3 :small) + (4 :normal) + (5 :large) + (6 :very-large) + (7 :huge)))) Index: Backends/CLX/port.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp,v retrieving revision 1.125 diff -u -u -r1.125 port.lisp --- Backends/CLX/port.lisp 9 Nov 2006 20:24:21 -0000 1.125 +++ Backends/CLX/port.lisp 24 Dec 2006 13:58:41 -0000 @@ -163,7 +163,8 @@ (pointer :reader port-pointer) (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) (selection-owner :initform nil :accessor selection-owner) - (selection-timestamp :initform nil :accessor selection-timestamp))) + (selection-timestamp :initform nil :accessor selection-timestamp) + (font-families :accessor font-families))) (defun parse-clx-server-path (path) (pop path) @@ -1434,3 +1435,95 @@ (if (streamp stream) stream (error "Cannot connect to server: ~A:~D" host display)))) + + +;;;; Font listing implementation: + +(defclass clx-font-family (clim-extensions:font-family) + ((all-faces :initform nil + :accessor all-faces + :reader clim-extensions:font-family-all-faces))) + +(defclass clx-font-face (clim-extensions:font-face) + ((all-sizes :initform nil + :accessor all-sizes + :reader clim-extensions:font-face-all-sizes))) + +(defun split-font-name (name) + (loop + repeat 12 + for next = (position #\- name :start 0) + :then (position #\- name :start (1+ next)) + and prev = nil then next + while next + when prev + collect (subseq name (1+ prev) next))) + +(defun reload-font-table (port) + (let ((table (make-hash-table :test 'equal))) + (dolist (font (xlib:list-font-names (clx-port-display port) "*")) + (destructuring-bind + (&optional foundry family weight slant setwidth style pixelsize + &rest ignore ;pointsize xresolution yresolution + ;spacing averagewidth registry encoding + ) + (split-font-name font) + (declare (ignore setwidth style ignore)) + (when family + (let* ((family-name (format nil "~A ~A" foundry family)) + (family-instance + (or (gethash family-name table) + (setf (gethash family-name table) + (make-instance 'clx-font-family + :port port + :name family-name)))) + (face-name (format nil "~A ~A" weight slant)) + (face-instance + (find face-name (all-faces family-instance) + :key #'clim-extensions:font-face-name + :test #'equal))) + (unless face-instance + (setf face-instance + (make-instance 'clx-font-face + :family family-instance + :name face-name)) + (push face-instance (all-faces family-instance))) + (pushnew (parse-integer + ;; FIXME: Python thinks pixelsize is NIL, resulting + ;; in a full WARNING. Let's COERCE to make it work. + (coerce pixelsize 'string)) + (all-sizes face-instance)))))) + (setf (font-families port) + (sort (loop + for family being each hash-value in table + do + (setf (all-faces family) + (sort (all-faces family) + #'string< + :key #'clim-extensions:font-face-name)) + (dolist (face (all-faces family)) + (setf (all-sizes face) (sort (all-sizes face) #'<))) + collect family) + #'string< + :key #'clim-extensions:font-family-name)))) + +(defmethod clim-extensions:port-all-font-families + ((port clx-port) &key invalidate-cache) + (when (or (not (slot-boundp port 'font-families)) invalidate-cache) + (reload-font-table port)) + (font-families port)) + +(defmethod clim-extensions:font-face-scalable-p ((face clx-font-face)) + nil) + +(defun make-unfriendly-name (str) + (substitute #\- #\space str)) + +(defmethod clim-extensions:font-face-text-style + ((face clx-font-face) &optional size) + (make-text-style (make-unfriendly-name + (clim-extensions:font-family-name + (clim-extensions:font-face-family face))) + (make-unfriendly-name + (clim-extensions:font-face-name face)) + size)) Index: Backends/gtkairo/ffi.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp,v retrieving revision 1.12 diff -u -u -r1.12 ffi.lisp --- Backends/gtkairo/ffi.lisp 24 Dec 2006 11:30:59 -0000 1.12 +++ Backends/gtkairo/ffi.lisp 24 Dec 2006 13:58:41 -0000 @@ -1498,6 +1498,18 @@ (desc :pointer) ;const PangoFontDescription * ) +(defcfun "pango_font_face_get_face_name" + :string + (face :pointer) ;PangoFontFace * + ) + +(defcfun "pango_font_face_list_sizes" + :void + (face :pointer) ;PangoFontFace * + (sizes :pointer) ;int ** + (n_sizes :pointer) ;int * + ) + (defcfun "pango_font_family_get_name" :string (family :pointer) ;PangoFontFamily * @@ -1508,6 +1520,13 @@ (family :pointer) ;PangoFontFamily * ) +(defcfun "pango_font_family_list_faces" + :void + (family :pointer) ;PangoFontFamily * + (faces :pointer) ;PangoFontFace *** + (n_faces :pointer) ;int * + ) + (defcfun "pango_font_map_load_font" :pointer (fontmap :pointer) ;PangoFontMap * Index: Backends/gtkairo/pango.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp,v retrieving revision 1.2 diff -u -u -r1.2 pango.lisp --- Backends/gtkairo/pango.lisp 23 Dec 2006 13:26:54 -0000 1.2 +++ Backends/gtkairo/pango.lisp 24 Dec 2006 13:58:41 -0000 @@ -123,23 +123,11 @@ (symbol-name (first face)) (symbol-name (second face))) :keyword))) - (let ((desc (pango_font_description_new)) - (family (or (getf *default-font-families* - (if (eq family :fixed) :fix family)) - (error "unknown font family: ~A" family))) - (weight (ecase face - ((:roman :italic :oblique) - :PANGO_WEIGHT_NORMAL) - ((:bold :bold-italic :italic-bold :bold-oblique - :oblique-bold) - :PANGO_WEIGHT_BOLD))) - (style (ecase face - ((:roman :bold) - :PANGO_STYLE_NORMAL) - ((:italic :bold-italic :italic-bold) - :PANGO_STYLE_ITALIC) - ((:oblique :bold-oblique :oblique-bold) - :PANGO_STYLE_OBLIQUE))) + (let ((family (if (stringp family) + family + (or (getf *default-font-families* + (if (eq family :fixed) :fix family)) + (error "unknown font family: ~A" family)))) (size (case size (:normal 12) (:tiny 6) @@ -148,10 +136,28 @@ (:large 14) (:very-large 16) (:huge 24) - (otherwise (truncate size))))) + (otherwise (truncate size)))) + desc) + (if (stringp face) + (setf desc (pango_font_description_from_string + (concatenate 'string ", " face))) + (let ((weight (ecase face + ((:roman :italic :oblique) + :PANGO_WEIGHT_NORMAL) + ((:bold :bold-italic :italic-bold :bold-oblique + :oblique-bold) + :PANGO_WEIGHT_BOLD))) + (style (ecase face + ((:roman :bold) + :PANGO_STYLE_NORMAL) + ((:italic :bold-italic :italic-bold) + :PANGO_STYLE_ITALIC) + ((:oblique :bold-oblique :oblique-bold) + :PANGO_STYLE_OBLIQUE)))) + (setf desc (pango_font_description_new)) + (pango_font_description_set_weight desc weight) + (pango_font_description_set_style desc style))) (pango_font_description_set_family desc family) - (pango_font_description_set_weight desc weight) - (pango_font_description_set_style desc style) (pango_font_description_set_size desc (* size PANGO_SCALE)) desc))) @@ -242,17 +248,6 @@ ;; (pango_layout_get_context layout) -(defun pango-context-list-families (context) - (cffi:with-foreign-object (&families :pointer) - (cffi:with-foreign-object (&n :int) - (pango_context_list_families context &families &n) - (let ((families (cffi:mem-aref &families :pointer))) - (prog1 - (loop - for i from 0 below (cffi:mem-aref &n :int) - collect (cffi:mem-aref families :pointer i)) - (g_free families)))))) - (defun resolve-font-description (context desc) (pango_font_describe (pango_context_load_font context desc))) @@ -308,3 +303,81 @@ (with-font-metrics (metrics context desc) (ceiling (pango_font_metrics_get_approximate_char_width metrics) PANGO_SCALE)))))) + + +;; font listing + +(defclass pango-font-family (clim-extensions:font-family) + ((native-family :initarg :native-family :accessor native-family))) + +(defclass pango-font-face (clim-extensions:font-face) + ((native-face :initarg :native-face :accessor native-face))) + +(defun invoke-lister (fn type) + (cffi:with-foreign-object (&array :pointer) + (cffi:with-foreign-object (&n :int) + (funcall fn &array &n) + (let ((array (cffi:mem-aref &array :pointer))) + (if (cffi:null-pointer-p array) + :null + (prog1 + (loop + for i from 0 below (cffi:mem-aref &n :int) + collect (cffi:mem-aref array type i)) + (g_free array))))))) + +(defun pango-context-list-families (context) + (invoke-lister (lambda (&families &n) + (pango_context_list_families context &families &n)) + :pointer)) + +(defun pango-font-family-list-faces (family) + (invoke-lister (lambda (&faces &n) + (pango_font_family_list_faces family &faces &n)) + :pointer)) + +(defun pango-font-face-list-sizes (face) + (invoke-lister (lambda (&sizes &n) + (pango_font_face_list_sizes face &sizes &n)) + :int)) + +(defmethod clim-extensions:port-all-font-families + ((port gtkairo-port) &key invalidate-cache) + (declare (ignore invalidate-cache)) + (sort (mapcar (lambda (native-family) + (make-instance 'pango-font-family + :native-family native-family + :port port + :name (pango_font_family_get_name native-family))) + (pango-context-list-families (global-pango-context port))) + #'string< + :key #'clim-extensions:font-family-name)) + +(defmethod clim-extensions:font-family-all-faces ((family pango-font-family)) + (sort (mapcar (lambda (native-face) + (make-instance 'pango-font-face + :native-face native-face + :family family + :name (pango_font_face_get_face_name native-face))) + (pango-font-family-list-faces (native-family family))) + #'string< + :key #'clim-extensions:font-face-name)) + +(defmethod clim-extensions:font-face-all-sizes ((face pango-font-face)) + (let ((sizes (pango-font-face-list-sizes (native-face face)))) + (if (eq sizes :null) + (loop for i from 0 below 200 collect i) + (mapcar (lambda (p) + ;; das mit dem round kommt mir aber nicht koscher vor + (round (/ p PANGO_SCALE))) + sizes)))) + +(defmethod clim-extensions:font-face-scalable-p ((face pango-font-face)) + (eq :null (pango-font-face-list-sizes (native-face face)))) + +(defmethod clim-extensions:font-face-text-style + ((face pango-font-face) &optional size) + (make-text-style (clim-extensions:font-family-name + (clim-extensions:font-face-family face)) + (clim-extensions:font-face-name face) + size)) Index: Backends/gtkairo/port.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp,v retrieving revision 1.12 diff -u -u -r1.12 port.lisp --- Backends/gtkairo/port.lisp 3 Dec 2006 15:24:09 -0000 1.12 +++ Backends/gtkairo/port.lisp 24 Dec 2006 13:58:41 -0000 @@ -49,7 +49,8 @@ (widgets->sheets :initform (make-hash-table) :accessor widgets->sheets) (dirty-mediums :initform (make-hash-table) :accessor dirty-mediums) (metrik-medium :accessor metrik-medium) - (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil))) + (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) + (global-pango-context :accessor global-pango-context))) ;;;(defmethod print-object ((object gtkairo-port) stream) ;;; (print-unreadable-object (object stream :identity t :type t) @@ -85,7 +86,8 @@ (gdk_screen_get_root_window (gdk_screen_get_default))))) (set-antialias cr) (setf (metrik-medium port) - (make-instance 'metrik-medium :port port :cr cr)))) + (make-instance 'metrik-medium :port port :cr cr))) + (setf (global-pango-context port) (gdk_pango_context_get))) (when clim-sys:*multiprocessing-p* (start-event-thread port))) Index: Doc/DOCBUILDING =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Doc/DOCBUILDING,v retrieving revision 1.1 diff -u -u -r1.1 DOCBUILDING --- Doc/DOCBUILDING 21 Dec 2006 12:22:03 -0000 1.1 +++ Doc/DOCBUILDING 24 Dec 2006 13:58:41 -0000 @@ -7,6 +7,8 @@ * And whatever tools are necessary to build HTML and PDF output from Texinfo. +[ On Debian: apt-get install imagemagick tetex-bin gs transfig texinfo ] + Before the docs can be built, docstrings will have to be extracted from McCLIM. This is automatically done by starting SBCL and loading McCLIM along with a program that looks at the documentation of Index: Doc/mcclim.texi =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi,v retrieving revision 1.3 diff -u -u -r1.3 mcclim.texi --- Doc/mcclim.texi 21 Dec 2006 12:22:02 -0000 1.3 +++ Doc/mcclim.texi 24 Dec 2006 13:58:41 -0000 @@ -96,6 +96,7 @@ * File Selector Gadget:: * PostScript Backend:: * Drei:: +* Fonts and Extended Text Styles:: Utility Programs * Listener:: @@ -1556,12 +1557,12 @@ @chapter PostScript Backend @menu -* Fonts:: +* Postscript Fonts:: * Additional functions:: @end menu -@node Fonts -@section Fonts +@node Postscript Fonts +@section Postscript Fonts Font mapping is a cons, the car of which is the name of the font (FontName field in the AFM file), and the cdr is the size in points. @@ -1580,6 +1581,86 @@ @include drei.texi +@node Fonts and Extended Text Styles +@chapter Fonts and Extended Text Styles + +@menu +* Extended Text Styles:: +* Listing Fonts:: +@end menu + +@node Extended Text Styles +@section Extended Text Styles + +McCLIM extends the legal values for the @cl{family} and @cl{face} +arguments to @cl{make-text-style} to include strings (in additional to +the portable keyword symbols), as permitted by the CLIM spec, section +11.1. + +Each backend defines its own specific syntax for these family and face +names. + +The CLX backend maps the text style family to the X font's +@emph{foundry} and @emph{family} values, separated by a dash. The +face is mapped to @emph{weight} and @emph{slant} in the same way. For +example, the following form creates a text style for +@emph{-misc-fixed-bold-r-*-*-18-*-*-*-*-*-*-*}: + +@lisp +(make-text-style "misc-fixed" "bold-r" 18) +@end lisp + +In the GTK backend, the text style family and face are used directly +as the Pango font family and face name. Please refer to Pango +documentation for details on the syntax of face names. Example: + +@lisp +(make-text-style "Bitstream Vera Sans" "Bold Oblique" 54) +@end lisp + +@node Listing Fonts +@section Listing Fonts + +McCLIM's font listing functions allow applications to list all +available fonts available on a @class{port} and create text style +instances for them. + +Example: + +@lisp +* (find "Bitstream Vera Sans Mono" + (clim-extensions:port-all-font-families (clim:find-port)) + :key #'clim-extensions:font-family-name + :test #'equal) +# + +* (clim-extensions:font-family-all-faces *) +(# + # + # + #) + +* (clim-extensions:font-face-scalable-p (car *)) +T + +* (clim-extensions:font-face-text-style (car **) 50) +# +@end lisp + +@include class-clim-extensions-font-family.texi +@include class-clim-extensions-font-face.texi + +@include fun-clim-extensions-port-all-font-families.texi + +@include fun-clim-extensions-font-family-name.texi +@include fun-clim-extensions-font-family-port.texi +@include fun-clim-extensions-font-family-all-faces.texi + +@include fun-clim-extensions-font-face-name.texi +@include fun-clim-extensions-font-face-family.texi +@include fun-clim-extensions-font-face-all-sizes.texi +@include fun-clim-extensions-font-face-text-style.texi + @c @node Utility Programs @c @part Utility Programs Index: Examples/demodemo.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp,v retrieving revision 1.15 diff -u -u -r1.15 demodemo.lisp --- Examples/demodemo.lisp 23 Dec 2006 21:44:04 -0000 1.15 +++ Examples/demodemo.lisp 24 Dec 2006 13:58:41 -0000 @@ -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)