[mcclim-cvs] CVS mcclim/Examples
dlichteblau
dlichteblau at common-lisp.net
Sun Dec 24 14:27:48 UTC 2006
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 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)
(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)))))))
More information about the Mcclim-cvs
mailing list