basis/ui/text/pango/pango.factor

   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.ffi pango.ffi pango.cairo.ffi ;
   8 IN: ui.text.pango
   9
  10 : pango>float ( n -- x ) PANGO_SCALE /f ; inline
  11 : float>pango ( x -- n ) PANGO_SCALE * >integer ; inline
  12
  13 MEMO: (cache-font-description) ( font -- description )
  14     [
  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 ]
  20             [ drop ]
  21         } 2cleave
  22     ] with-destructors ;
  23
  24 : cache-font-description ( font -- description )
  25     strip-font-colors (cache-font-description) ;
  26
  27
  28 TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
  29
  30 SYMBOL: dpi
  31
  32 72 dpi set-global
  33
  34 : set-layout-font ( font layout -- )
  35     swap cache-font-description pango_layout_set_font_description ;
  36
  37 : set-layout-text ( str layout -- )
  38     swap utf8 string>alien -1 pango_layout_set_text ;
  39
  40 : PangoRectangle>rect ( PangoRectangle -- rect )
  41     [ [ x>> pango>float ] [ y>> pango>float ] bi 2array ]
  42     [ [ width>> pango>float ] [ height>> pango>float ] bi 2array ] bi
  43     <rect> ;
  44
  45 : layout-extents ( layout -- ink-rect logical-rect )
  46     PangoRectangle <struct>
  47     PangoRectangle <struct>
  48     [ pango_layout_get_extents ] 2keep
  49     [ PangoRectangle>rect ] bi@ ;
  50
  51 : layout-baseline ( layout -- baseline )
  52     pango_layout_get_iter &pango_layout_iter_free
  53     pango_layout_iter_get_baseline
  54     pango>float ;
  55
  56 : set-foreground ( cr font -- )
  57     foreground>> set-source-color ;
  58
  59 : fill-background ( cr font dim -- )
  60     [ background>> set-source-color ]
  61     [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
  62
  63 : rect-translate-x ( rect x -- rect' )
  64     '[ _ 0 2array v- ] change-loc ;
  65
  66 : first-line ( layout -- line )
  67     layout>> 0 pango_layout_get_line_readonly ;
  68
  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
  73     *int pango>float ;
  74
  75 : x>line-offset ( layout x -- n )
  76     #! n is an index into the UTF8 encoding of the text
  77     [
  78         [ first-line ] dip
  79         float>pango 0 <int> 0 <int>
  80         [ pango_layout_line_x_to_index drop ] 2keep
  81         [ *int ] bi@ swap
  82     ] [ drop string>> ] 2bi utf8-index> + ;
  83
  84 : selection-start/end ( selection -- start end )
  85     selection>> [ start>> ] [ end>> ] bi ;
  86
  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> ;
  90
  91 : fill-selection-background ( cr layout -- )
  92     dup selection>> [
  93         [ selection>> color>> set-source-color ]
  94         [
  95             [ selection-rect ] [ ink-rect>> loc>> first ] bi
  96             rect-translate-x
  97             fill-rect
  98         ] 2bi
  99     ] [ 2drop ] if ;
 100
 101 : text-position ( layout -- loc )
 102     [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
 103
 104 : set-text-position ( cr loc -- )
 105     first2 cairo_move_to ;
 106
 107 : draw-layout ( layout -- image )
 108     dup ink-rect>> dim>> [ >fixnum ] map [
 109         swap {
 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 ]
 116         } 2cleave
 117     ] make-bitmap-image ;
 118
 119 : escape-nulls ( str -- str' )
 120     #! Replace nulls with something else since Pango uses null-terminated
 121     #! strings
 122     { { 0 CHAR: zero-width-no-break-space } } substitute ;
 123
 124 : unpack-selection ( layout string/selection -- layout )
 125     dup selection? [
 126         [ string>> escape-nulls >>string ] [ >>selection ] bi
 127     ] [ escape-nulls >>string ] if ; inline
 128
 129 : set-layout-resolution ( layout -- )
 130     pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
 131
 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 ;
 137
 138 : glyph-height ( font string -- y )
 139     swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
 140
 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.
 144     [
 145         [ metrics new ] dip
 146         [ "x" glyph-height >>x-height ]
 147         [ "Y" glyph-height >>cap-height ] bi
 148     ] with-destructors ;
 149
 150 : layout-metrics ( layout -- metrics )
 151     dup font>> missing-font-metrics clone
 152         swap
 153         [ layout>> layout-baseline >>ascent ]
 154         [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
 155         dup [ height>> ] [ ascent>> ] bi - >>descent ;
 156
 157 : <layout> ( font string -- line )
 158     [
 159         layout new-disposable
 160             swap unpack-selection
 161             swap >>font
 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
 166     ] with-destructors ;
 167
 168 M: layout dispose* layout>> g_object_unref ;
 169
 170 SYMBOL: cached-layouts
 171
 172 : cached-layout ( font string -- layout )
 173     cached-layouts get [ <layout> ] 2cache ;
 174
 175 : cached-line ( font string -- line )
 176     cached-layout layout>> first-line ;
 177
 178 SINGLETON: pango-renderer
 179
 180 M: pango-renderer string-dim
 181     [ " " string-dim { 0 1 } v* ]
 182     [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
 183
 184 M: pango-renderer flush-layout-cache
 185     cached-layouts get purge-cache ;
 186
 187 M: pango-renderer string>image ( font string -- image loc )
 188     cached-layout [ image>> ] [ text-position vneg ] bi ;
 189
 190 M: pango-renderer x>offset ( x font string -- n )
 191     cached-layout swap x>line-offset ;
 192
 193 M: pango-renderer offset>x ( n font string -- x )
 194     cached-layout swap line-offset>x ;
 195
 196 M: pango-renderer font-metrics ( font -- metrics )
 197     " " cached-layout metrics>> clone f >>width ;
 198
 199 M: pango-renderer line-metrics ( font string -- metrics )
 200     [ " " line-metrics clone 0 >>width ]
 201     [ cached-layout metrics>> ]
 202     if-empty ;
 203
 204 [
 205     \ (cache-font-description) reset-memoized
 206     <cache-assoc> cached-layouts set-global
 207 ] "ui.text.pango" add-startup-hook
 208
 209 pango-renderer font-renderer set-global
 210