1 ! Copyright (C) 2008 Matthew Willis.
2 ! Copyright (C) 2009 Slava Pestov.
3 ! See http://factorcode.org/license.txt for BSD license.
5 ! pangocairo bindings, from pango/pangocairo.h
6 USING: arrays sequences alien alien.c-types alien.destructors
7 alien.libraries alien.syntax math math.functions math.vectors
8 destructors combinators colors fonts accessors assocs namespaces
9 kernel pango pango.fonts pango.layouts glib unicode.data images
10 cache init system math.rectangles fry memoize io.encodings.utf8
11 classes.struct cairo cairo.ffi ;
15 { [ os winnt? ] [ "pangocairo" "libpangocairo-1.0-0.dll" "cdecl" add-library ] }
16 { [ os macosx? ] [ "pangocairo" "/opt/local/lib/libpangocairo-1.0.0.dylib" "cdecl" add-library ] }
22 C-TYPE: PangoCairoFontMap
23 C-TYPE: PangoCairoFont
25 FUNCTION: PangoFontMap*
26 pango_cairo_font_map_new ( ) ;
28 FUNCTION: PangoFontMap*
29 pango_cairo_font_map_new_for_font_type ( cairo_font_type_t fonttype ) ;
31 FUNCTION: PangoFontMap*
32 pango_cairo_font_map_get_default ( ) ;
34 FUNCTION: cairo_font_type_t
35 pango_cairo_font_map_get_font_type ( PangoCairoFontMap* fontmap ) ;
38 pango_cairo_font_map_set_resolution ( PangoCairoFontMap* fontmap, double dpi ) ;
41 pango_cairo_font_map_get_resolution ( PangoCairoFontMap* fontmap ) ;
43 FUNCTION: PangoContext*
44 pango_cairo_font_map_create_context ( PangoCairoFontMap* fontmap ) ;
46 FUNCTION: cairo_scaled_font_t*
47 pango_cairo_font_get_scaled_font ( PangoCairoFont* font ) ;
49 ! Update a Pango context for the current state of a cairo context
51 pango_cairo_update_context ( cairo_t* cr, PangoContext* context ) ;
54 pango_cairo_context_set_font_options ( PangoContext* context, cairo_font_options_t* options ) ;
56 FUNCTION: cairo_font_options_t*
57 pango_cairo_context_get_font_options ( PangoContext* context ) ;
60 pango_cairo_context_set_resolution ( PangoContext* context, double dpi ) ;
63 pango_cairo_context_get_resolution ( PangoContext* context ) ;
66 FUNCTION: PangoLayout*
67 pango_cairo_create_layout ( cairo_t* cr ) ;
70 pango_cairo_update_layout ( cairo_t* cr, PangoLayout* layout ) ;
74 pango_cairo_show_glyph_string ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
77 pango_cairo_show_layout_line ( cairo_t* cr, PangoLayoutLine* line ) ;
80 pango_cairo_show_layout ( cairo_t* cr, PangoLayout* layout ) ;
83 pango_cairo_show_error_underline ( cairo_t* cr, double x, double y, double width, double height ) ;
87 pango_cairo_glyph_string_path ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
90 pango_cairo_layout_line_path ( cairo_t* cr, PangoLayoutLine* line ) ;
93 pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
96 pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
98 TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
104 : set-layout-font ( font layout -- )
105 swap cache-font-description pango_layout_set_font_description ;
107 : set-layout-text ( str layout -- )
108 #! Replace nulls with something else since Pango uses null-terminated
110 swap -1 pango_layout_set_text ;
112 : layout-extents ( layout -- ink-rect logical-rect )
113 PangoRectangle <struct>
114 PangoRectangle <struct>
115 [ pango_layout_get_extents ] 2keep
116 [ PangoRectangle>rect ] bi@ ;
118 : layout-baseline ( layout -- baseline )
119 pango_layout_get_iter &pango_layout_iter_free
120 pango_layout_iter_get_baseline
123 : set-foreground ( cr font -- )
124 foreground>> set-source-color ;
126 : fill-background ( cr font dim -- )
127 [ background>> set-source-color ]
128 [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
130 : rect-translate-x ( rect x -- rect' )
131 '[ _ 0 2array v- ] change-loc ;
133 : first-line ( layout -- line )
134 layout>> 0 pango_layout_get_line_readonly ;
136 : line-offset>x ( layout n -- x )
137 #! n is an index into the UTF8 encoding of the text
138 [ drop first-line ] [ swap string>> >utf8-index ] 2bi
139 0 0 <int> [ pango_layout_line_index_to_x ] keep
142 : x>line-offset ( layout x -- n )
143 #! n is an index into the UTF8 encoding of the text
146 float>pango 0 <int> 0 <int>
147 [ pango_layout_line_x_to_index drop ] 2keep
149 ] [ drop string>> ] 2bi utf8-index> + ;
151 : selection-start/end ( selection -- start end )
152 selection>> [ start>> ] [ end>> ] bi ;
154 : selection-rect ( layout -- rect )
155 [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi
156 [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ;
158 : fill-selection-background ( cr layout -- )
160 [ selection>> color>> set-source-color ]
162 [ selection-rect ] [ ink-rect>> loc>> first ] bi
168 : text-position ( layout -- loc )
169 [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
171 : set-text-position ( cr loc -- )
172 first2 cairo_move_to ;
174 : draw-layout ( layout -- image )
175 dup ink-rect>> dim>> [ >fixnum ] map [
177 [ layout>> pango_cairo_update_layout ]
178 [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ]
179 [ fill-selection-background ]
180 [ text-position set-text-position ]
181 [ font>> set-foreground ]
182 [ layout>> pango_cairo_show_layout ]
184 ] make-bitmap-image ;
186 : escape-nulls ( str -- str' )
187 { { 0 CHAR: zero-width-no-break-space } } substitute ;
189 : unpack-selection ( layout string/selection -- layout )
191 [ string>> escape-nulls >>string ] [ >>selection ] bi
192 ] [ escape-nulls >>string ] if ; inline
194 : set-layout-resolution ( layout -- )
195 pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
197 : <PangoLayout> ( text font -- layout )
198 dummy-cairo pango_cairo_create_layout |g_object_unref
199 [ set-layout-resolution ] keep
200 [ set-layout-font ] keep
201 [ set-layout-text ] keep ;
203 : glyph-height ( font string -- y )
204 swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
206 MEMO: missing-font-metrics ( font -- metrics )
207 #! Pango doesn't provide x-height and cap-height but Core Text does, so we
208 #! simulate them on Pango.
211 [ "x" glyph-height >>x-height ]
212 [ "Y" glyph-height >>cap-height ] bi
215 : layout-metrics ( layout -- metrics )
216 dup font>> missing-font-metrics clone
218 [ layout>> layout-baseline >>ascent ]
219 [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
220 dup [ height>> ] [ ascent>> ] bi - >>descent ;
222 : <layout> ( font string -- line )
224 layout new-disposable
225 swap unpack-selection
227 dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
228 dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi*
229 dup layout-metrics >>metrics
230 dup draw-layout >>image
233 M: layout dispose* layout>> g_object_unref ;
235 SYMBOL: cached-layouts
237 : cached-layout ( font string -- layout )
238 cached-layouts get [ <layout> ] 2cache ;
240 : cached-line ( font string -- line )
241 cached-layout layout>> first-line ;
243 [ <cache-assoc> cached-layouts set-global ] "pango.cairo" add-init-hook