First attempt at ui.text.pango

basis/cairo/authors.txt

@@ -1,2 +1,3 @@
 Sampo Vuori
 Doug Coleman
+Slava Pestov

basis/cairo/cairo.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: cairo.ffi alien.c-types kernel accessors sequences
+USING: colors fonts cairo.ffi alien alien.c-types kernel accessors
-namespaces fry continuations destructors math images.memory ;
+sequences namespaces fry continuations destructors math images
+images.memory ;
 IN: cairo
 
 ERROR: cairo-error message ;
@@ -43,4 +45,18 @@ ERROR: cairo-error message ;
         <image-surface> &cairo_surface_destroy
         cairo_create &cairo_destroy
         @
-    ] make-memory-bitmap ; inline
+    ] make-memory-bitmap
+    BGRA >>component-order ; inline
+
+: dummy-cairo ( -- cr )
+    #! Sometimes we want a dummy context; eg with Pango, we want
+    #! to measure text dimensions to create a new image context with,
+    #! but we need an existing context to measure text dimensions
+    #! with so we use the dummy.
+    \ dummy-cairo [
+        CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
+        cairo_create
+    ] initialize-alien ;
+
+: set-source-color ( cr color -- )
+    >rgba-components cairo_set_source_rgba ;

basis/core-graphics/core-graphics.factor

@@ -126,4 +126,5 @@ PRIVATE>
     ] initialize-alien ;
 
 : make-bitmap-image ( dim quot -- image )
-    '[ <CGBitmapContext> &CGContextRelease @ ] make-memory-bitmap ; inline
+    '[ <CGBitmapContext> &CGContextRelease @ ] make-memory-bitmap
+    ARGB >>component-order ; inline

basis/glib/glib.factor

@@ -24,6 +24,7 @@ LIBRARY: glib
 
 TYPEDEF: void* gpointer
 TYPEDEF: int gint
+TYPEDEF: bool gboolean
 
 FUNCTION: void
 g_free ( gpointer mem ) ;

basis/images/images.factor

@@ -34,7 +34,7 @@ TUPLE: image dim component-order bitmap ;
 GENERIC: load-image* ( path tuple -- image )
 
 : add-dummy-alpha ( seq -- seq' )
-    3 <sliced-groups> [ 255 suffix ] map concat ;
+    3 <groups> [ 255 suffix ] map concat ;
 
 : normalize-floats ( byte-array -- byte-array )
     byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
@@ -63,8 +63,7 @@ M: R16G16B16 normalize-component-order*
     drop RGB16>8 add-dummy-alpha ;
 
 : BGR>RGB ( bitmap bytes-per-pixel -- pixels )
-    dup <sliced-groups>
+    <groups> [ 3 cut [ reverse ] dip append ] map B{ } join ; inline
-    [ 3 head-slice reverse-here ] each ; inline
 
 M: BGRA normalize-component-order*
     drop 4 BGR>RGB ;
@@ -75,6 +74,15 @@ M: RGB normalize-component-order*
 M: BGR normalize-component-order*
     drop 3 BGR>RGB add-dummy-alpha ;
 
+: ARGB>RGBA ( bitmap -- bitmap' )
+    4 <groups> [ unclip suffix ] map B{ } join ;
+
+M: ARGB normalize-component-order*
+    drop ARGB>RGBA ;
+
+M: ABGR normalize-component-order*
+    drop ARGB>RGBA 4 BGR>RGB ;
+
 GENERIC: normalize-scan-line-order ( image -- image )
 
 M: image normalize-scan-line-order ;

basis/images/memory/memory.factor

@@ -20,8 +20,7 @@ IN: images.memory
     [ bitmap-data ] keep
     <image>
         swap >>dim
-        swap >>bitmap
+        swap >>bitmap ;
-        little-endian? ARGB BGRA ? >>component-order ;
 
 PRIVATE>
 

basis/opengl/textures/textures.factor

@@ -17,7 +17,7 @@ GENERIC: component-order>format ( component-order -- format type )
 
 M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
-M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8 ;
+M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 
 : repeat-last ( seq n -- seq' )
     over peek pad-tail concat ;

basis/pango/cairo/authors.txt

@@ -0,0 +1,2 @@
+Matthew Willis
+Slava Pestov

basis/pango/cairo/cairo.factor

@@ -1,4 +1,5 @@
 ! Copyright (C) 2008 Matthew Willis.
+! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! pangocairo bindings, from pango/pangocairo.h
@@ -101,13 +102,8 @@ MEMO: (cache-font) ( font -- open-font )
 
 : parse-font-metrics ( metrics -- metrics' )
     [ metrics new ] dip
-    {
+    [ pango_font_metrics_get_ascent PANGO_SCALE /f >>height ]
-        [ pango_font_metrics_get_ascent PANGO_SCALE /f >>height ]
+    [ pango_font_metrics_get_descent PANGO_SCALE /f >>descent ] bi
-        [ pango_font_metrics_get_descent PANGO_SCALE /f >>descent ]
-        [ drop 0 >>leading ]
-        [ drop 0 >>cap-height ]
-        [ drop 0 >>x-height ]
-    } cleave
     dup [ height>> ] [ descent>> ] bi - >>ascent ;
 
 MEMO: (cache-font-metrics) ( font -- metrics )

basis/pango/layouts/layouts.factor

@@ -1,8 +1,10 @@
 ! Copyright (C) 2008 Matthew Willis.
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays alien alien.c-types alien.syntax math destructors accessors assocs
+USING: arrays sequences alien alien.c-types alien.destructors
-namespaces kernel pango pango.fonts pango.cairo cairo.ffi glib unicode.data ;
+alien.syntax math math.vectors destructors combinators colors fonts
+accessors assocs namespaces kernel pango pango.fonts pango.cairo cairo
+cairo.ffi glib unicode.data locals images cache init ;
 IN: pango.layouts
 
 LIBRARY: pango
@@ -32,16 +34,45 @@ FUNCTION: int
 pango_layout_get_baseline ( PangoLayout* layout ) ;
 
 FUNCTION: void
-pango_layout_get_pixel_extents ( PangoLayout *layout, PangoRectangle *ink_rect, PangoRectangle *logical_rect ) ;
+pango_layout_get_pixel_extents ( PangoLayout* layout, PangoRectangle* ink_rect, PangoRectangle* logical_rect ) ;
+
+FUNCTION: PangoLayoutLine*
+pango_layout_get_line_readonly ( PangoLayout* layout, int line ) ;
+                                                         
+FUNCTION: void
+pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, gboolean trailing, int* x_pos ) ;
+
+FUNCTION: gboolean
+pango_layout_line_x_to_index ( PangoLayoutLine* line, int x_pos, int* index_, int* trailing ) ;
+
+FUNCTION: PangoLayoutIter*
+pango_layout_get_iter ( PangoLayout* layout ) ;
+
+FUNCTION: int
+pango_layout_iter_get_baseline ( PangoLayoutIter* iter ) ;
+
+FUNCTION: void
+pango_layout_iter_free ( PangoLayoutIter* iter ) ;
+
+DESTRUCTOR: pango_layout_iter_free
 
 : layout-dim ( layout -- dim )
     0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
     [ *int ] bi@ 2array ;
 
-ERROR: bad-font name ;
+: layout-extents ( layout -- ink-rect logical-rect )
+    "PangoRectangle" <c-object>
+    "PangoRectangle" <c-object>
+    [ pango_layout_get_pixel_extents ] 2keep
+    [ PangoRectangle>rect ] bi@ ;
+
+: layout-baseline ( layout -- baseline )
+    pango_layout_get_iter &pango_layout_iter_free
+    pango_layout_iter_get_baseline
+    PANGO_SCALE /f ;
 
 : set-layout-font ( str layout -- )
-    swap cache-font-description pango_layout_set_font_description ;
+    swap pango_layout_set_font_description ;
 
 : set-layout-text ( str layout -- )
     #! Replace nulls with something else since Pango uses null-terminated
@@ -49,15 +80,71 @@ ERROR: bad-font name ;
     swap { { 0 CHAR: zero-width-no-break-space } } substitute
     -1 pango_layout_set_text ;
 
-: <layout> ( text font cairo -- layout )
+: <PangoLayout> ( text font -- layout )
+    dummy-cairo pango_cairo_create_layout |g_object_unref
+    [ set-layout-font ] keep
+    [ set-layout-text ] keep ;
+
+: set-foreground ( cr font -- )
+    foreground>> set-source-color ;
+
+: fill-background ( cr font dim -- )
+    [ background>> set-source-color ]
+    [ [ 0 0 ] dip first2 cairo_rectangle ] bi-curry*
+    [ cairo_fill ]
+    tri ;
+
+:: fill-selection-background ( cr loc dim layout string -- )
+    ;
+
+: set-text-position ( cr loc -- )
+    first2 cairo_move_to ;
+
+: layout-metrics ( dim baseline -- metrics )
+    metrics new
+        swap >>ascent
+        swap first2 [ >>width ] [ >>height ] bi*
+        dup [ height>> ] [ ascent>> ] bi - >>descent ;
+
+TUPLE: layout font layout metrics image loc dim disposed ;
+
+:: <layout> ( font string -- line )
     [
-        pango_cairo_create_layout |g_object_unref
+        ! TODO: metrics and loc
-        [ set-layout-font ] keep
+        [let* | open-font [ font cache-font-description ]
-        [ set-layout-text ] keep
+                layout [ string open-font <PangoLayout> ]
+                logical-rect [ layout layout-extents ] ink-rect [ ]
+                baseline [ layout layout-baseline ]
+                logical-loc [ logical-rect loc>> ]
+                logical-dim [ logical-rect dim>> ]
+                ink-loc [ ink-rect loc>> ]
+                ink-dim [ ink-rect dim>> ]
+                metrics [ logical-dim baseline layout-metrics ] |
+            open-font layout metrics
+            ink-dim [
+                {
+                    [ layout pango_cairo_update_layout ]
+                    [ font ink-dim fill-background ]
+                    [ font set-foreground ]
+                    [ ink-loc ink-dim layout string fill-selection-background ]
+                    [ logical-loc ink-loc v- set-text-position ]
+                    [ layout pango_cairo_show_layout ]
+                } cleave
+            ] make-bitmap-image
+            logical-loc ink-loc v-
+            logical-dim
+        ]
+        f layout boa
     ] with-destructors ;
 
-: dummy-cairo ( -- cr )
+M: layout dispose* layout>> g_object_unref ;
-    \ dummy-cairo [
+
-        CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
+SYMBOL: cached-layouts
-        cairo_create
+
-    ] initialize-alien ;
+: cached-layout ( font string -- layout )
+    cached-layouts get [ <layout> ] 2cache ;
+
+: cached-line ( font string -- line )
+    cached-layout layout>> 0 pango_layout_get_line_readonly ;
+
+[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook

basis/pango/pango.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Matthew Willis.
+! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license
-USING: system alien.destructors alien.c-types alien.syntax alien
+USING: arrays system alien.destructors alien.c-types alien.syntax alien
-combinators ;
+combinators math.rectangles kernel ;
 IN: pango
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -21,5 +22,16 @@ CONSTANT: PANGO_SCALE 1024
 FUNCTION: PangoContext*
 pango_context_new ( ) ;
 
+C-STRUCT: PangoRectangle
+    { "int" "x" }
+    { "int" "y" }
+    { "int" "width" }
+    { "int" "height" } ;
+
+: PangoRectangle>rect ( PangoRectangle -- rect )
+    [ [ PangoRectangle-x ] [ PangoRectangle-y ] bi 2array ]
+    [ [ PangoRectangle-width ] [ PangoRectangle-height ] bi 2array ] bi
+    <rect> ;
+
 : dummy-pango-context ( -- context )
     \ dummy-pango-context [ pango_context_new ] initialize-alien ;

basis/ui/text/pango/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/ui/text/pango/pango.factor

@@ -0,0 +1,44 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs cache kernel math
+namespaces opengl.textures pango.cairo pango.layouts
+ui.gadgets.worlds ui.text ui.text.private ;
+IN: ui.text.pango
+
+SINGLETON: pango-renderer
+
+M: pango-renderer init-text-rendering
+    <cache-assoc> >>text-handle drop ;
+
+M: pango-renderer string-dim cached-layout dim>> ;
+
+M: pango-renderer finish-text-rendering
+    text-handle>> purge-cache
+    cached-layouts get purge-cache ;
+
+: rendered-layout ( font string -- texture )
+    world get text-handle>>
+    [ cached-layout [ image>> ] [ loc>> ] bi <texture> ]
+    2cache ;
+
+M: pango-renderer draw-string ( font string -- )
+    rendered-layout draw-texture ;
+
+M: pango-renderer x>offset ( x font string -- n )
+    cached-line swap 0 <int> 0 <int>
+    [ pango_layout_line_x_to_index drop ] 2keep
+    [ *int ] bi@ + ;
+
+M: pango-renderer offset>x ( n font string -- x )
+    cached-line swap f
+    0 <int> [ pango_layout_line_index_to_x ] keep *int ;
+
+: missing-metrics ( metrics -- metrics ) 5 >>cap-height 5 >>x-height ;
+
+M: pango-renderer font-metrics ( font -- metrics )
+    cache-font-metrics missing-metrics ;
+
+M: pango-renderer line-metrics ( font string -- metrics )
+    cached-layout metrics>> missing-metrics ;
+
+pango-renderer font-renderer set-global