[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Wed Dec 20 18:45:37 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory clnet:/tmp/cvs-serv27072
Modified Files:
ffi.lisp gtk-ffi.lisp medium.lisp package.lisp
Added Files:
pango.lisp
Log Message:
Rewrote text drawing and font metric functions using Pango.
* pango.lisp: New file.
* gtk-ffi.lisp (PANGO_SCALE, PangoRectangle): New.
* ffi.lisp: Regenerated.
* medium.lisp (METRIK-MEDIUM, WITH-CAIRO-MEDIUM): Moved to
pango.lisp. (MEDIUM-DRAW-TEXT*): Rewritten using Pango.
(TEXT-STYLE-ASCENT, TEXT-STYLE-DESCENT, TEXT-STYLE-FIXED-WIDTH-P,
TEXT-SIZE, TEXT-BOUNDING-RECTANGLE*): Methods on METRIK-MEDIUM
deleted.
* package.lisp: Export new variable *DEFAULT-FONT-FAMILIES*.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/10 16:34:32 1.8
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/20 18:45:37 1.9
@@ -194,6 +194,20 @@
:GTK_WINDOW_TOPLEVEL
:GTK_WINDOW_POPUP)
+(defcenum PangoStyle
+ :PANGO_STYLE_NORMAL
+ :PANGO_STYLE_OBLIQUE
+ :PANGO_STYLE_ITALIC)
+
+(defcenum PangoWeight
+ (:PANGO_WEIGHT_ULTRALIGHT 200)
+ (:PANGO_WEIGHT_LIGHT 300)
+ (:PANGO_WEIGHT_NORMAL 400)
+ (:PANGO_WEIGHT_SEMIBOLD 600)
+ (:PANGO_WEIGHT_BOLD 700)
+ (:PANGO_WEIGHT_ULTRABOLD 800)
+ (:PANGO_WEIGHT_HEAVY 900))
+
(cffi:defcstruct Screen
(ext_data :pointer) ;XExtData *
(display :pointer) ;struct _XDisplay *
@@ -694,12 +708,22 @@
(arg2 :double) ;double
)
+(defcfun "g_free"
+ :void
+ (mem :pointer) ;gpointer
+ )
+
(defcfun "g_idle_add"
:unsigned-int
(function :pointer) ;GSourceFunc
(data :pointer) ;gpointer
)
+(defcfun "g_object_unref"
+ :void
+ (_object :pointer) ;gpointer
+ )
+
(defcfun "g_signal_connect_data"
:unsigned-long
(instance :pointer) ;gpointer
@@ -827,6 +851,8 @@
(gc :pointer) ;GdkGC *
)
+(defcfun "gdk_pango_context_get" :pointer)
+
(defcfun "gdk_pixmap_new"
:pointer
(drawable :pointer) ;GdkDrawable *
@@ -1364,3 +1390,200 @@
(window :pointer) ;GtkWindow *
(title :string) ;const gchar *
)
+
+(defcfun "pango_cairo_create_layout"
+ :pointer
+ (cr :pointer) ;cairo_t *
+ )
+
+(defcfun "pango_cairo_show_layout"
+ :void
+ (cr :pointer) ;cairo_t *
+ (layout :pointer) ;PangoLayout *
+ )
+
+(defcfun "pango_context_get_font_map"
+ :pointer
+ (context :pointer) ;PangoContext *
+ )
+
+(defcfun "pango_context_get_metrics"
+ :pointer
+ (context :pointer) ;PangoContext *
+ (desc :pointer) ;const PangoFontDescription *
+ (language :pointer) ;PangoLanguage *
+ )
+
+(defcfun "pango_context_list_families"
+ :void
+ (context :pointer) ;PangoContext *
+ (families :pointer) ;PangoFontFamily ***
+ (n_families :pointer) ;int *
+ )
+
+(defcfun "pango_context_load_font"
+ :pointer
+ (context :pointer) ;PangoContext *
+ (desc :pointer) ;const PangoFontDescription *
+ )
+
+(defcfun "pango_font_describe"
+ :pointer
+ (font :pointer) ;PangoFont *
+ )
+
+(defcfun "pango_font_description_free"
+ :void
+ (desc :pointer) ;PangoFontDescription *
+ )
+
+(defcfun "pango_font_description_from_string"
+ :pointer
+ (str :string) ;const char *
+ )
+
+(defcfun "pango_font_description_get_family"
+ :string
+ (desc :pointer) ;const PangoFontDescription *
+ )
+
+(defcfun "pango_font_description_new" :pointer)
+
+(defcfun "pango_font_description_set_absolute_size"
+ :void
+ (desc :pointer) ;PangoFontDescription *
+ (size :double) ;double
+ )
+
+(defcfun "pango_font_description_set_family"
+ :void
+ (desc :pointer) ;PangoFontDescription *
+ (family :string) ;const char *
+ )
+
+(defcfun "pango_font_description_set_size"
+ :void
+ (desc :pointer) ;PangoFontDescription *
+ (size :int) ;gint
+ )
+
+(defcfun "pango_font_description_set_style"
+ :void
+ (desc :pointer) ;PangoFontDescription *
+ (style PangoStyle))
+
+(defcfun "pango_font_description_set_weight"
+ :void
+ (desc :pointer) ;PangoFontDescription *
+ (weight PangoWeight))
+
+(defcfun "pango_font_description_to_string"
+ :string
+ (desc :pointer) ;const PangoFontDescription *
+ )
+
+(defcfun "pango_font_family_get_name"
+ :string
+ (family :pointer) ;PangoFontFamily *
+ )
+
+(defcfun "pango_font_family_is_monospace"
+ :int
+ (family :pointer) ;PangoFontFamily *
+ )
+
+(defcfun "pango_font_map_load_font"
+ :pointer
+ (fontmap :pointer) ;PangoFontMap *
+ (context :pointer) ;PangoContext *
+ (desc :pointer) ;const PangoFontDescription *
+ )
+
+(defcfun "pango_font_metrics_get_approximate_char_width"
+ :int
+ (metrics :pointer) ;PangoFontMetrics *
+ )
+
+(defcfun "pango_font_metrics_get_ascent"
+ :int
+ (metrics :pointer) ;PangoFontMetrics *
+ )
+
+(defcfun "pango_font_metrics_get_descent"
+ :int
+ (metrics :pointer) ;PangoFontMetrics *
+ )
+
+(defcfun "pango_font_metrics_unref"
+ :void
+ (metrics :pointer) ;PangoFontMetrics *
+ )
+
+(defcfun "pango_layout_get_context"
+ :pointer
+ (layout :pointer) ;PangoLayout *
+ )
+
+(defcfun "pango_layout_get_line"
+ :pointer
+ (layout :pointer) ;PangoLayout *
+ (line :int) ;int
+ )
+
+(defcfun "pango_layout_get_line_count"
+ :int
+ (layout :pointer) ;PangoLayout *
+ )
+
+(defcfun "pango_layout_get_pixel_extents"
+ :void
+ (layout :pointer) ;PangoLayout *
+ (ink_rect :pointer) ;PangoRectangle *
+ (logical_rect :pointer) ;PangoRectangle *
+ )
+
+(defcfun "pango_layout_get_pixel_size"
+ :void
+ (layout :pointer) ;PangoLayout *
+ (width :pointer) ;int *
+ (height :pointer) ;int *
+ )
+
+(defcfun "pango_layout_get_size"
+ :void
+ (layout :pointer) ;PangoLayout *
+ (width :pointer) ;int *
+ (height :pointer) ;int *
+ )
+
+(defcfun "pango_layout_line_get_pixel_extents"
+ :void
+ (layout_line :pointer) ;PangoLayoutLine *
+ (ink_rect :pointer) ;PangoRectangle *
+ (logical_rect :pointer) ;PangoRectangle *
+ )
+
+(defcfun "pango_layout_set_font_description"
+ :void
+ (layout :pointer) ;PangoLayout *
+ (desc :pointer) ;const PangoFontDescription *
+ )
+
+(defcfun "pango_layout_set_single_paragraph_mode"
+ :void
+ (layout :pointer) ;PangoLayout *
+ (setting :int) ;gboolean
+ )
+
+(defcfun "pango_layout_set_spacing"
+ :void
+ (layout :pointer) ;PangoLayout *
+ (spacing :int) ;int
+ )
+
+(defcfun "pango_layout_set_text"
+ :void
+ (layout :pointer) ;PangoLayout *
+ (text :string) ;const char *
+ (length :int) ;int
+ )
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/10 19:33:05 1.19
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/20 18:45:37 1.20
@@ -350,16 +350,26 @@
(defconstant GTK_DOUBLE_BUFFERED (ash 1 21))
(defconstant GTK_NO_SHOW_ALL (ash 1 22))
+(defconstant PANGO_SCALE 1024)
+
+(cffi:defcstruct PangoRectangle
+ (x :int)
+ (y :int)
+ (width :int)
+ (height :int))
+
;; magic symbols for FFI code generation
(defvar *dummy*
- '(GdkFunction gtkselectionmode GtkScrollType GdkEventMask GdkEventType
+ '(GdkFunction gtkselectionmode GtkScrollType GdkEventMask GdkEventType
GtkWidgetFlags GdkModifierType GdkCrossingMode GtkWindowType
GdkGrabStatus GdkWindowHints GtkStateType GdkDragAction GConnectFlags
GdkDragProtocol
gdk_x11_drawable_get_xid
+ pangostyle pangoweight PangoRectangle PangoFontMetrics
+
cairo_format_t cairo_operator_t cairo_fill_rule_t cairo_line_cap_t
cairo_line_join_t cairo_font_slant_t cairo_font_weight_t cairo_status_t
cairo_filter_t cairo_extend_t))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/03 15:24:09 1.13
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/20 18:45:37 1.14
@@ -44,9 +44,6 @@
(unless cr
(setf (last-seen-sheet instance) nil)))
-(defclass metrik-medium (gtkairo-medium)
- ())
-
(defparameter *antialiasingp* t)
(defun gtkwidget-gdkwindow (widget)
@@ -56,9 +53,6 @@
(or (climi::port-lookup-mirror (port medium) (medium-sheet medium))
(error "oops, drawing operation on unmirrored sheet ~A" medium)))
-(defmacro with-cairo-medium ((medium) &body body)
- `(invoke-with-cairo-medium (lambda () , at body) ,medium))
-
(defun invoke-with-cairo-medium (fn medium)
(when (or (cr medium)
(climi::port-lookup-mirror (port medium) (medium-sheet medium)))
@@ -635,14 +629,15 @@
(sync-transformation medium)
(sync-ink medium (medium-ink medium))
(sync-clipping-region medium (medium-clipping-region medium))
- (sync-text-style medium
- (merge-text-styles (medium-text-style medium)
- (medium-default-text-style medium))
- transform-glyphs)
- (cairo_move_to cr (df x) (df y))
(setf end (or end (length text)))
- (unless (eql start end) ;empty string breaks cairo/windows
- (cairo_show_text cr (subseq text start end))))))
+ (unless (eql start end)
+ (with-pango-cairo (layout cr
+ :text-style medium
+ :text (subseq text start end))
+ (let ((y2
+ (nth-value 1 (pango-layout-line-get-pixel-extents layout 0))))
+ (cairo_move_to cr (df x) (df (+ y y2))))
+ (pango_cairo_show_layout cr layout))))))
(defmethod medium-finish-output ((medium gtkairo-medium))
(with-cairo-medium (medium)
@@ -720,103 +715,45 @@
(let ((hash (make-hash-table)))
(defmethod text-style-ascent :around (text-style (medium gtkairo-medium))
- (or (gethash text-style hash)
+ (or #-debug-metrik (gethash text-style hash)
(setf (gethash text-style hash) (call-next-method)))))
(defmethod text-style-ascent (text-style (medium gtkairo-medium))
(text-style-ascent text-style (metrik-medium (port medium))))
-(defmethod text-style-ascent (text-style (medium metrik-medium))
- (with-cairo-medium (medium)
- (ceiling
- (with-slots (cr) medium
- (sync-sheet medium)
- (cairo_identity_matrix cr)
- (sync-text-style medium text-style t)
- (cffi:with-foreign-object (res 'cairo_font_extents)
- (cairo_font_extents cr res)
- (slot res 'cairo_font_extents 'ascent))))))
-
;;; TEXT-STYLE-DESCENT
(let ((hash (make-hash-table)))
(defmethod text-style-descent :around (text-style (medium gtkairo-medium))
- (or (gethash text-style hash)
+ (or #-debug-metrik (gethash text-style hash)
(setf (gethash text-style hash) (call-next-method)))))
(defmethod text-style-descent (text-style (medium gtkairo-medium))
(text-style-descent text-style (metrik-medium (port medium))))
-(defmethod text-style-descent (text-style (medium metrik-medium))
- (with-cairo-medium (medium)
- (ceiling
- (with-slots (cr) medium
- (sync-sheet medium)
- (cairo_identity_matrix cr)
- (sync-text-style medium text-style t)
- (cffi:with-foreign-object (res 'cairo_font_extents)
- (cairo_font_extents cr res)
- (slot res 'cairo_font_extents 'descent))))))
-
;;; TEXT-STYLE-HEIGHT
(let ((hash (make-hash-table)))
(defmethod text-style-height :around (text-style (medium gtkairo-medium))
- (or (gethash text-style hash)
+ (or #-debug-metrik (gethash text-style hash)
(setf (gethash text-style hash) (call-next-method)))))
(defmethod text-style-height (text-style (medium gtkairo-medium))
(text-style-height text-style (metrik-medium (port medium))))
-(defmethod text-style-height (text-style (medium metrik-medium))
-;;; (with-cairo-medium (medium)
-;;; (ceiling
-;;; (with-slots (cr) medium
-;;; (sync-sheet medium)
-;;; (cairo_identity_matrix cr)
-;;; (sync-text-style medium text-style t)
-;;; (cffi:with-foreign-object (res 'cairo_font_extents)
-;;; (cairo_font_extents cr res)
-;;; ;; ### let's hope that cairo respects
-;;; ;; height = ascent + descent.
-;;; ;;
-;;; ;; No, it expressly doesn't. Cairo documentation states that
-;;; ;; height includes additional space that is meant to give more
-;;; ;; aesthetic line spacing than ascent+descent would. Is that a
-;;; ;; problem for us? --DFL
-;;; (slot res 'cairo_font_extents 'height)))))
- ;; OK, so it _does_ matter (see bug 15).
- (+ (text-style-ascent text-style medium)
- (text-style-descent text-style medium)))
-
;;; TEXT-STYLE-WIDTH
(let ((hash (make-hash-table)))
(defmethod text-style-width :around (text-style (medium gtkairo-medium))
- (or (gethash text-style hash)
+ (or #-debug-metrik (gethash text-style hash)
(setf (gethash text-style hash) (call-next-method)))))
(defmethod text-style-width (text-style (medium gtkairo-medium))
(text-style-width text-style (metrik-medium (port medium))))
-(defmethod text-style-width (text-style (medium metrik-medium))
- (with-cairo-medium (medium)
- (ceiling
- (with-slots (cr) medium
- (sync-sheet medium)
- (cairo_identity_matrix cr)
- (sync-text-style medium text-style t)
- ;; This didn't work well for Climacs. --DFL
-;;; (cffi:with-foreign-object (res 'cairo_text_extents)
-;;; (cairo_text_extents cr "m" res)
-;;; (slot res 'cairo_text_extents 'width))
- (cffi:with-foreign-object (res 'cairo_font_extents)
- (cairo_font_extents cr res)
- (slot res 'cairo_font_extents 'max_x_advance))))))
-
;;; TEXT-STYLE-FIXED-WIDTH-P
@@ -824,26 +761,12 @@
(defmethod text-style-fixed-width-p
:around
(text-style (medium gtkairo-medium))
- (or (gethash text-style hash)
+ (or #-debug-metrik (gethash text-style hash)
(setf (gethash text-style hash) (call-next-method)))))
(defmethod text-style-fixed-width-p (text-style (medium gtkairo-medium))
(text-style-fixed-width-p text-style (metrik-medium (port medium))))
-(defmethod text-style-fixed-width-p (text-style (medium metrik-medium))
- (with-cairo-medium (medium)
- (with-slots (cr) medium
- (sync-sheet medium)
- (cairo_identity_matrix cr)
- (sync-text-style medium text-style t)
- (cffi:with-foreign-object (res 'cairo_text_extents)
- (let (i m)
- (cairo-text-extents cr "i" res)
- (setf i (slot res 'cairo_text_extents 'width))
- (cairo-text-extents cr "m" res)
- (setf m (slot res 'cairo_text_extents 'width))
- (= i m))))))
-
(defmethod text-size
((medium gtkairo-medium) string &key text-style (start 0) end)
(with-gtk ()
@@ -870,71 +793,6 @@
:start start
:end (or end (length string)))))
-;; FIXME: TEXT-SIZE [and presumably TEXT-BOUNDING-RECTANGLE*, too] are
-;; supposed to take newlines into account. The CLX backend code was
-;; written to support that but does not -- T-B-R errors out and T-S
-;; doesn't return what WRITE-STRING on the sheet actually does. So
-;; let's not steal code from CLIM-CLX when it's broken. Doesn't
-;; actually look like anyone has been depending on this after all.
-;; -- DFL
-
-(defmethod text-size
- ((medium metrik-medium) string &key text-style (start 0) end)
- (with-cairo-medium (medium)
- ;; -> width height final-x final-y baseline
- (when (characterp string) (setf string (string string)))
- (setf text-style (or text-style (make-text-style nil nil nil)))
- (setf text-style
- (merge-text-styles text-style (medium-default-text-style medium)))
- (with-slots (cr) medium
- (cairo_identity_matrix cr)
- (sync-text-style medium text-style t)
- (cffi:with-foreign-object (res 'cairo_text_extents)
- (cairo-text-extents cr
- (subseq string start (or end (length string)))
- res)
- (cffi:with-foreign-slots
- ((x_advance height y_bearing) res cairo_text_extents)
- (values
- ;; use x_advance instead of width, since CLIM wants to trailing
- ;; spaces to be taken into account.
- (ceiling x_advance)
- (ceiling height)
- ;; Sames values again here: The CLIM spec states that these
- ;; values differ only for multi-line text. And y_advance is 0
- ;; for european text, which is not what we want. --DFL
- (ceiling x_advance)
- (ceiling height)
- ;; This used to be TEXT-STYLE-ASCENT, but see comment there.
- (abs (ceiling y_bearing))))))))
-
-(defmethod climi::text-bounding-rectangle*
- ((medium metrik-medium) string &key text-style (start 0) end)
- (with-cairo-medium (medium)
- ;; -> left ascent right descent
- (when (characterp string) (setf string (string string)))
- (setf text-style (or text-style (make-text-style nil nil nil)))
- (setf text-style
- (merge-text-styles text-style (medium-default-text-style medium)))
- (with-slots (cr) medium
- (cairo_identity_matrix cr)
- (sync-text-style medium text-style t)
- (cffi:with-foreign-object (res 'cairo_text_extents)
- (cairo-text-extents cr
- (subseq string start (or end (length string)))
- res)
- ;; This used to be a straight call to TEXT-SIZE. Looking at
- ;; what CLIM-CLX does, this looks better to me, but I'm not sure
- ;; whether it's 100% right:
- ;; --DFL
- (cffi:with-foreign-slots
- ((width height x_advance y_advance x_bearing y_bearing)
- res cairo_text_extents)
- (values (floor x_bearing)
- (floor y_bearing)
- (ceiling (+ width (max 0 x_bearing)))
- (ceiling (+ height y_bearing))))))))
-
;;;; ------------------------------------------------------------------------
;;;; General Designs
;;;;
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/package.lisp 2006/04/17 18:40:27 1.1
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/package.lisp 2006/12/20 18:45:37 1.2
@@ -3,4 +3,5 @@
(in-package :common-lisp-user)
(defpackage :clim-gtkairo
- (:use :clim :clim-lisp :clim-backend))
+ (:use :clim :clim-lisp :clim-backend)
+ (:export #:*default-font-families*))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/20 18:45:37 NONE
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/20 18:45:37 1.1
;;; -*- Mode: Lisp; -*-
;;; (c) copyright 2006 David Lichteblau (david at lichteblau.com)
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(in-package :clim-gtkairo)
;;; these shouldn't be here:
(defclass metrik-medium (gtkairo-medium) ())
(defmacro with-cairo-medium ((medium) &body body)
`(invoke-with-cairo-medium (lambda () , at body) ,medium))
;;;; Helper macros.
(defmacro with-pango-cairo ((layout-var cr &key text-style text) &body body)
`(invoke-with-pango-cairo (lambda (,layout-var) , at body)
,cr
:text-style ,text-style
:text ,text))
(defmacro with-text-style-font-description ((var text-style) &body body)
`(invoke-with-text-style-font-description
(lambda (,var) , at body)
,text-style))
(defmacro with-font-description ((var description) &body body)
`(invoke-with-font-description (lambda (,var) , at body) ,description))
(defmacro with-font-metrics ((var context desc) &body body)
`(invoke-with-font-metrics (lambda (,var) , at body) ,context ,desc))
(defmacro with-pango-context ((var medium) &body body)
`(invoke-with-pango-context (lambda (,var) , at body) ,medium))
(defun invoke-with-pango-cairo (fn cr &key text-style text)
(let ((layout (pango_cairo_create_layout cr)))
(unwind-protect
(progn
(when text-style
(with-text-style-font-description
(desc
(etypecase text-style
(text-style
text-style)
(medium
(merge-text-styles
(medium-text-style text-style)
(medium-default-text-style text-style)))))
(pango_layout_set_font_description layout desc)))
(when text
(pango_layout_set_text layout text -1))
(funcall fn layout))
(g_object_unref layout))))
(defun invoke-with-font-description (fn desc)
(unwind-protect
(funcall fn desc)
(pango_font_description_free desc)))
(defun invoke-with-text-style-font-description (fn text-style)
(with-font-description (desc (make-font-description text-style))
(funcall fn desc)))
(defun invoke-with-font-metrics (fn context desc)
(let ((metrics (pango_context_get_metrics context desc (cffi:null-pointer))))
(unwind-protect
(funcall fn metrics)
(pango_font_metrics_unref metrics))))
(defun invoke-with-pango-context (fn medium)
(declare (ignore medium)) ;fixme!
(let ((context (gdk_pango_context_get)))
(unwind-protect
(funcall fn context)
(g_object_unref context))))
;;;; Pango text drawing and metric functions.
(defvar *default-font-families*
;; Finding a good monospace font isn't easy:
;; - "Free Mono" is totally broken.
;; - "Courier", "Nimbus Mono L", "Andale Mono" have weird "Bold" face
;; metrics.
;; - "Courier New" and "Bitstream Vera Sans Mono" work well.
;; (Test case is Climacs.)
'(:fix "Courier New"
:serif "serif"
:sans-serif "sans")
"A plist mapping the standard font family keywords :fix, :serif, and
:sans-serif to Pango font names. Example:
(setf (getf *default-font-families* :fix) \"Bitstream Vera Sans Mono\")")
(defun make-font-description (text-style)
(multiple-value-bind (family face size)
(text-style-components
(merge-text-styles text-style *default-text-style*))
(when (listp face)
;; Ein Pfusch ist das!
(setf face (intern (format nil "~A-~A"
(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)))
(size (case size
(:normal 12)
(:tiny 6)
(:small 10)
(:very-small 8)
(:large 14)
(:very-large 16)
(:huge 24)
(otherwise (truncate size)))))
(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)))
(defun pango-layout-get-pixel-size (layout)
;;; (cffi:with-foreign-object (rect 'pangorectangle)
;;; (pango_layout_get_pixel_extents
;;; layout
;;; (cffi:null-pointer)
;;; rect)
;;; (cffi:with-foreign-slots ((x y width height) rect pangorectangle)
;;; (tr x y width height)
;;; (values width (- height y))))
(cffi:with-foreign-object (&w :int)
(cffi:with-foreign-object (&h :int)
(pango_layout_get_pixel_size layout &w &h)
(values
(cffi:mem-aref &w :int)
(cffi:mem-aref &h :int)))))
(defun pango-layout-line-get-pixel-extents (layout line-index)
(when (minusp line-index)
(incf line-index (pango_layout_get_line_count layout)))
(cffi:with-foreign-object (rect 'pangorectangle)
(pango_layout_line_get_pixel_extents
(pango_layout_get_line layout line-index)
(cffi:null-pointer)
rect)
(cffi:with-foreign-slots ((x y width height) rect pangorectangle)
(values x y width height))))
(defun pango-layout-get-ink-rectangle (layout)
(cffi:with-foreign-object (rect 'pangorectangle)
(pango_layout_get_pixel_extents layout rect (cffi:null-pointer))
(cffi:with-foreign-slots ((x y width height) rect pangorectangle)
(values x y width height))))
(defmethod text-size
((medium metrik-medium) string &key text-style (start 0) end)
(with-cairo-medium (medium)
;; -> width height final-x final-y baseline
(when (characterp string) (setf string (string string)))
(setf text-style (or text-style (make-text-style nil nil nil)))
(setf text-style
(merge-text-styles text-style (medium-default-text-style medium)))
(with-slots (cr) medium
(cairo_identity_matrix cr)
(with-pango-cairo (layout cr
:text-style text-style
:text (unless (eql start end)
(subseq string start end)))
(multiple-value-bind (width height)
(pango-layout-get-pixel-size layout)
(multiple-value-bind (first-x first-y first-width first-height)
(pango-layout-line-get-pixel-extents layout 0)
(declare (ignorable first-x first-y first-width first-height))
(multiple-value-bind (final-x final-y final-width final-height)
(pango-layout-line-get-pixel-extents layout -1)
(declare (ignorable final-x final-y final-width final-height))
(values width
height
final-width
(- height final-height)
(abs first-y)))))))))
(defmethod climi::text-bounding-rectangle*
((medium metrik-medium) string &key text-style (start 0) end)
(with-cairo-medium (medium)
;; -> left ascent right descent
(when (characterp string) (setf string (string string)))
(setf text-style (or text-style (make-text-style nil nil nil)))
(setf text-style
(merge-text-styles text-style (medium-default-text-style medium)))
(with-slots (cr) medium
(cairo_identity_matrix cr)
(with-pango-cairo (layout cr
:text-style text-style
:text (unless (eql start end)
(subseq string start end)))
(multiple-value-bind (x y width height)
(pango-layout-get-ink-rectangle layout)
(let* ((first-y
(nth-value 1 (pango-layout-line-get-pixel-extents layout 0)))
(ascent (- (abs first-y) y)))
(values x
(ceiling (- ascent))
(ceiling (+ width (max 0 x)))
(ceiling (- height ascent)))))))))
;; (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)))
(defun font-description-to-font-family (context desc)
(with-font-description (desc* (resolve-font-description context desc))
(find (pango_font_description_get_family desc*)
(pango-context-list-families context)
:key #'pango_font_family_get_name
:test #'equal)))
(defmethod text-style-fixed-width-p (text-style (medium metrik-medium))
(with-gtk ()
(with-pango-context (context medium)
(with-text-style-font-description (desc text-style)
(let ((family (font-description-to-font-family context desc)))
(assert family)
(not (zerop (pango_font_family_is_monospace family))))))))
(defmethod text-style-ascent (text-style (medium metrik-medium))
(with-gtk ()
(with-pango-context (context medium)
(with-text-style-font-description (desc text-style)
(with-font-metrics (metrics context desc)
(ceiling (pango_font_metrics_get_ascent metrics) PANGO_SCALE)))))
;; here's a dummy implementation guaranteing ascent+descent=height:
;; we don't seem to need it though.
;;; (multiple-value-bind (width height final-x final-y baseline)
;;; (text-size medium "foo" :text-style text-style)
;;; (declare (ignore width height final-x final-y))
;;; baseline)
)
(defmethod text-style-descent (text-style (medium metrik-medium))
(with-gtk ()
(with-pango-context (context medium)
(with-text-style-font-description (desc text-style)
(with-font-metrics (metrics context desc)
(ceiling (pango_font_metrics_get_descent metrics) PANGO_SCALE)))))
;; here's a dummy implementation guaranteing ascent+descent=height:
;; we don't seem to need it though.
;;; (multiple-value-bind (width height final-x final-y baseline)
;;; (text-size medium "foo" :text-style text-style)
;;; (declare (ignore width final-x final-y))
;;; (- height baseline))
)
(defmethod text-style-height (text-style (medium metrik-medium))
(nth-value 1 (text-size medium "foo" :text-style text-style))
;; here's a dummy implementation guaranteing ascent+descent=height,
;; leading to less inter-line space.
;;; (+ (text-style-ascent text-style medium)
;;; (text-style-descent text-style medium))
)
(defmethod text-style-width (text-style (medium metrik-medium))
(with-gtk ()
(with-pango-context (context medium)
(with-text-style-font-description (desc text-style)
(with-font-metrics (metrics context desc)
(ceiling (pango_font_metrics_get_approximate_char_width metrics)
PANGO_SCALE))))))
More information about the Mcclim-cvs
mailing list