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 () ,@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@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 () ,@body) ,medium))
;;;; Helper macros.
(defmacro with-pango-cairo ((layout-var cr &key text-style text) &body body) `(invoke-with-pango-cairo (lambda (,layout-var) ,@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) ,@body) ,text-style))
(defmacro with-font-description ((var description) &body body) `(invoke-with-font-description (lambda (,var) ,@body) ,description))
(defmacro with-font-metrics ((var context desc) &body body) `(invoke-with-font-metrics (lambda (,var) ,@body) ,context ,desc))
(defmacro with-pango-context ((var medium) &body body) `(invoke-with-pango-context (lambda (,var) ,@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))))))
-
dlichteblau