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