1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.strings arrays assocs cache cairo
4 cairo.ffi classes.struct combinators destructors fonts fry
5 init io.encodings.utf8 kernel math math.rectangles math.vectors
6 memoize namespaces sequences ui.text ui.text.private
7 gobject gobject.ffi pango pango.ffi pango.cairo pango.cairo.ffi ;
10 : pango>float ( n -- x ) PANGO_SCALE /f ; inline
11 : float>pango ( x -- n ) PANGO_SCALE * >integer ; inline
13 MEMO: (cache-font-description) ( font -- description )
15 [ pango_font_description_new |pango_font_description_free ] dip {
16 [ name>> utf8 string>alien pango_font_description_set_family ]
17 [ size>> float>pango pango_font_description_set_size ]
18 [ bold?>> PANGO_WEIGHT_BOLD PANGO_WEIGHT_NORMAL ? pango_font_description_set_weight ]
19 [ italic?>> PANGO_STYLE_ITALIC PANGO_STYLE_NORMAL ? pango_font_description_set_style ]
24 : cache-font-description ( font -- description )
25 strip-font-colors (cache-font-description) ;
28 TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
34 : set-layout-font ( font layout -- )
35 swap cache-font-description pango_layout_set_font_description ;
37 : set-layout-text ( str layout -- )
38 swap utf8 string>alien -1 pango_layout_set_text ;
40 : PangoRectangle>rect ( PangoRectangle -- rect )
41 [ [ x>> pango>float ] [ y>> pango>float ] bi 2array ]
42 [ [ width>> pango>float ] [ height>> pango>float ] bi 2array ] bi
45 : layout-extents ( layout -- ink-rect logical-rect )
46 PangoRectangle <struct>
47 PangoRectangle <struct>
48 [ pango_layout_get_extents ] 2keep
49 [ PangoRectangle>rect ] bi@ ;
51 : layout-baseline ( layout -- baseline )
52 pango_layout_get_iter &pango_layout_iter_free
53 pango_layout_iter_get_baseline
56 : set-foreground ( cr font -- )
57 foreground>> set-source-color ;
59 : fill-background ( cr font dim -- )
60 [ background>> set-source-color ]
61 [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
63 : rect-translate-x ( rect x -- rect' )
64 '[ _ 0 2array v- ] change-loc ;
66 : first-line ( layout -- line )
67 layout>> 0 pango_layout_get_line_readonly ;
69 : line-offset>x ( layout n -- x )
70 #! n is an index into the UTF8 encoding of the text
71 [ drop first-line ] [ swap string>> >utf8-index ] 2bi
72 f 0 <int> [ pango_layout_line_index_to_x ] keep
75 : x>line-offset ( layout x -- n )
76 #! n is an index into the UTF8 encoding of the text
79 float>pango 0 <int> 0 <int>
80 [ pango_layout_line_x_to_index drop ] 2keep
82 ] [ drop string>> ] 2bi utf8-index> + ;
84 : selection-start/end ( selection -- start end )
85 selection>> [ start>> ] [ end>> ] bi ;
87 : selection-rect ( layout -- rect )
88 [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi
89 [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ;
91 : fill-selection-background ( cr layout -- )
93 [ selection>> color>> set-source-color ]
95 [ selection-rect ] [ ink-rect>> loc>> first ] bi
101 : text-position ( layout -- loc )
102 [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
104 : set-text-position ( cr loc -- )
105 first2 cairo_move_to ;
107 : draw-layout ( layout -- image )
108 dup ink-rect>> dim>> [ >fixnum ] map [
110 [ layout>> pango_cairo_update_layout ]
111 [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ]
112 [ fill-selection-background ]
113 [ text-position set-text-position ]
114 [ font>> set-foreground ]
115 [ layout>> pango_cairo_show_layout ]
117 ] make-bitmap-image ;
119 : escape-nulls ( str -- str' )
120 #! Replace nulls with something else since Pango uses null-terminated
122 { { 0 CHAR: zero-width-no-break-space } } substitute ;
124 : unpack-selection ( layout string/selection -- layout )
126 [ string>> escape-nulls >>string ] [ >>selection ] bi
127 ] [ escape-nulls >>string ] if ; inline
129 : set-layout-resolution ( layout -- )
130 pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
132 : <PangoLayout> ( text font -- layout )
133 dummy-cairo pango_cairo_create_layout |g_object_unref
134 [ set-layout-resolution ] keep
135 [ set-layout-font ] keep
136 [ set-layout-text ] keep ;
138 : glyph-height ( font string -- y )
139 swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
141 MEMO: missing-font-metrics ( font -- metrics )
142 #! Pango doesn't provide x-height and cap-height but Core Text does, so we
143 #! simulate them on Pango.
146 [ "x" glyph-height >>x-height ]
147 [ "Y" glyph-height >>cap-height ] bi
150 : layout-metrics ( layout -- metrics )
151 dup font>> missing-font-metrics clone
153 [ layout>> layout-baseline >>ascent ]
154 [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
155 dup [ height>> ] [ ascent>> ] bi - >>descent ;
157 : <layout> ( font string -- line )
159 layout new-disposable
160 swap unpack-selection
162 dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
163 dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi*
164 dup layout-metrics >>metrics
165 dup draw-layout >>image
168 M: layout dispose* layout>> g_object_unref ;
170 SYMBOL: cached-layouts
172 : cached-layout ( font string -- layout )
173 cached-layouts get [ <layout> ] 2cache ;
175 : cached-line ( font string -- line )
176 cached-layout layout>> first-line ;
178 SINGLETON: pango-renderer
180 M: pango-renderer string-dim
181 [ " " string-dim { 0 1 } v* ]
182 [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
184 M: pango-renderer flush-layout-cache
185 cached-layouts get purge-cache ;
187 M: pango-renderer string>image ( font string -- image loc )
188 cached-layout [ image>> ] [ text-position vneg ] bi ;
190 M: pango-renderer x>offset ( x font string -- n )
191 cached-layout swap x>line-offset ;
193 M: pango-renderer offset>x ( n font string -- x )
194 cached-layout swap line-offset>x ;
196 M: pango-renderer font-metrics ( font -- metrics )
197 " " cached-layout metrics>> clone f >>width ;
199 M: pango-renderer line-metrics ( font string -- metrics )
200 [ " " line-metrics clone 0 >>width ]
201 [ cached-layout metrics>> ]
205 \ (cache-font-description) reset-memoized
206 <cache-assoc> cached-layouts set-global
207 ] "ui.text.pango" add-startup-hook
209 pango-renderer font-renderer set-global