Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv16855
Modified Files: mcclim.asd medium.lisp package.lisp ports.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/mcclim.asd 2006/12/20 18:45:54 1.41 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/24 14:27:43 1.42 @@ -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"))))) --- /project/mcclim/cvsroot/mcclim/medium.lisp 2006/05/05 10:24:02 1.60 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2006/12/24 14:27:43 1.61 @@ -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)) --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/23 21:44:03 1.58 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/12/24 14:27:43 1.59 @@ -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. ;;; --- /project/mcclim/cvsroot/mcclim/ports.lisp 2006/07/01 21:31:41 1.53 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2006/12/24 14:27:43 1.54 @@ -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))))