FreeType debugging

library/alien/malloc.factor

@@ -5,6 +5,7 @@ USING: alien errors kernel ;
 
 LIBRARY: libc
 FUNCTION: ulong malloc ( ulong size ) ;
+FUNCTION: ulong calloc ( ulong count, ulong size ) ;
 FUNCTION: void free ( ulong ptr ) ;
 FUNCTION: ulong realloc ( ulong ptr, ulong size ) ;
 FUNCTION: void memcpy ( ulong dst, ulong src, ulong size ) ;

library/freetype/freetype-gl.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-USING: #<unknown> alien arrays errors hashtables io kernel
+USING: alien arrays errors hashtables io kernel
 kernel-internals lists math namespaces opengl prettyprint
 sequences styles ;
 IN: freetype
@@ -19,14 +19,11 @@ SYMBOL: open-fonts
         {{ }} clone open-fonts set
     ] bind ;
 
-! A sprite are a texture and display list.
-TUPLE: sprite dlist texture ;
-
 : free-dlists ( seq -- )
-    "Freeing display lists: " print . ;
+    drop ;
 
 : free-textures ( seq -- )
-    "Freeing textures: " print . ;
+    drop ;
 
 : free-sprites ( glyphs -- )
     dup [ sprite-dlist ] map free-dlists
@@ -35,11 +32,19 @@ TUPLE: sprite dlist texture ;
 ! A font object from FreeType.
 ! the handle is an FT_Face.
 ! sprites is a vector.
-TUPLE: font height handle sprites metrics ;
+TUPLE: font ascent descent height handle sprites ;
+
+: flush-font ( font -- )
+    #! Only do this after re-creating a GL context!
+    dup font-sprites [ ] subset free-sprites
+    { } clone swap set-font-sprites ;
 
 : close-font ( font -- )
-    dup font-sprites [ ] subset free-sprites
+    dup flush-font font-handle FT_Done_Face ;
-    font-handle FT_Done_Face ;
+
+: flush-fonts ( -- )
+    #! Only do this after re-creating a GL context!
+    open-fonts get hash-values [ flush-font ] each ;
 
 : close-freetype ( -- )
     global [
@@ -76,23 +81,25 @@ TUPLE: font height handle sprites metrics ;
     ttf-name ttf-path >r freetype get r>
     0 f <void*> [ FT_New_Face freetype-error ] keep *void* ;
 
-: dpi 100 ;
+: dpi 72 ;
 
 : fix>float 64 /f ;
 
 : font-units>pixels ( n font -- n )
     face-size face-size-y-scale FT_MulFix fix>float ;
 
-: init-font-height ( font -- )
+: init-ascent ( font face -- )
-    dup font-handle
+    dup face-y-max swap font-units>pixels swap set-font-ascent ;
-    dup face-y-max over face-y-min - swap font-units>pixels 
+
-    swap set-font-height ;
+: init-descent ( font face -- )
+    dup face-y-min swap font-units>pixels swap set-font-descent ;
+
+: init-font ( font -- )
+    dup font-handle 2dup init-ascent dupd init-descent
+    dup font-ascent over font-descent - swap set-font-height ;
 
 C: font ( handle -- font )
-    { } clone over set-font-sprites
+    [ set-font-handle ] keep dup flush-font dup init-font ;
-    { } clone over set-font-metrics
-    [ set-font-handle ] keep
-    dup init-font-height ;
 
 : open-font ( { font style ptsize } -- font )
     #! Open a font and set the point size of the font.
@@ -103,60 +110,81 @@ C: font ( handle -- font )
     #! Cache open fonts.
     3array open-fonts get [ open-font ] cache ;
 
-: load-glyph ( face char -- glyph )
+: load-glyph ( font char -- glyph )
-    dupd 0 FT_Load_Char freetype-error face-glyph ;
+    >r font-handle r> dupd 0 FT_Load_Char
+    freetype-error face-glyph ;
 
-: (char-size) ( font char -- dim )
+: glyph-size ( glyph -- dim )
-    >r font-handle r> load-glyph
+    dup glyph-advance-x fix>float
-    dup glyph-width fix>float
     swap glyph-height fix>float 0 3array ;
 
-: char-size ( open-font char -- w h )
+: render-glyph ( font char -- bitmap )
-    over font-metrics [ dupd (char-size) ] cache-nth nip first2 ;
-
-: string-size ( font string -- w h )
-    0 pick font-height
-    2swap [ char-size >r rot + swap r> max ] each-with ;
-
-: render-glyph ( face char -- bitmap )
     #! Render a character and return a pointer to the bitmap.
     load-glyph dup
     FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
 
 : with-locked-block ( size quot -- | quot: address -- )
-    swap malloc [ swap call ] keep free ; inline
+    swap 1 calloc [ swap call ] keep free ; inline
 
-: (copy-bitmap) ( bitmap-chase texture-chase width width-pow2 )
+: b/b>w 8 shift bitor ;
-    >r 3dup swapd memcpy tuck >r >r + r> r> r> tuck >r >r + r> r> ;
 
-: copy-bitmap ( glyph texture width-pow2 -- )
+: copy-pixel ( bit tex -- bit tex )
-    pick glyph-bitmap-rows >r >r over glyph-bitmap-pitch >r >r
+    f pick alien-unsigned-1 255 b/b>w
-    glyph-bitmap-buffer alien-address r> r> r> r>
+    f pick set-alien-unsigned-2
-    [ (copy-bitmap) ] times 2drop 2drop ;
+    >r 1+ r> 2 + ;
 
-: bitmap>texture ( width height glyph -- id )
+: (copy-row) ( bit tex bitend texend -- bitend texend )
+    >r pick over >= [
+        r> 2swap 2drop
+    ] [
+        >r copy-pixel r> r> (copy-row)
+    ] if ;
+
+: copy-row ( bit tex width width2 -- bitend texend width width2 )
+    [ pick + >r pick + r> (copy-row) ] 2keep ;
+
+: copy-bitmap ( glyph texture -- )
+    over glyph-bitmap-rows >r
+    over glyph-bitmap-width dup next-power-of-2 2 *
+    >r >r >r glyph-bitmap-buffer alien-address r> r> r> r> 
+    [ copy-row ] times 2drop 2drop ;
+
+: bitmap>texture ( glyph sprite -- id )
     #! Given a glyph bitmap, copy it to a texture with the given
     #! width/height (which must be powers of two).
-    3drop
+    tuck sprite-size2 * 2 * [
-    32 32 * 4 * [
+        [ copy-bitmap ] keep <alien> gray-texture
-        <alien> 32 32 * 4 * [
-            128 pick rot set-alien-signed-1
-        ] each 32 32 rot gray-texture
     ] with-locked-block ;
 
-: char-texture-size ( bitmap -- width height )
+: glyph-texture-loc ( glyph font -- loc )
-    dup glyph-bitmap-width swap glyph-bitmap-rows
+    font-ascent swap glyph-hori-bearing-y fix>float -
-    [ next-power-of-2 ] 2apply ;
+    0 swap 0 3array ;
 
-: <char-sprite> ( face char -- sprite )
+: glyph-texture-size ( glyph -- dim )
-    render-glyph [ char-texture-size 2dup ] keep
+    dup glyph-bitmap-width next-power-of-2
-    bitmap>texture [ texture>dlist ] keep <sprite> ;
+    swap glyph-bitmap-rows next-power-of-2 0 3array ;
+
+: <char-sprite> ( font char -- sprite )
+    #! Create a new display list of a rendered glyph. This
+    #! allocates external resources. See free-sprites.
+    over >r render-glyph dup r> glyph-texture-loc
+    over glyph-size pick glyph-texture-size <sprite>
+    [ bitmap>texture ] keep [ init-sprite ] keep ;
 
 : char-sprite ( open-font char -- sprite )
-    over font-sprites
+    #! Get a cached display list of a FreeType-rendered
-    [ >r dup font-handle r> <char-sprite> ] cache-nth nip ;
+    #! glyph.
+    over font-sprites [ dupd <char-sprite> ] cache-nth nip ;
 
-: draw-string ( font string -- )
+: char-width ( open-font char -- w )
-    GL_TEXTURE_BIT [
+    char-sprite sprite-width ;
-        [ char-sprite sprite-dlist glCallList ] each-with
+
-    ] save-attribs ;
+: string-width ( open-font string -- w )
+    0 -rot [ char-width + ] each-with ;
+
+: draw-string ( open-font string -- )
+    GL_MODELVIEW [
+        GL_TEXTURE_BIT [
+            [ char-sprite sprite-dlist glCallList ] each-with
+        ] save-attribs
+    ] do-matrix ;

library/math/integer.factor

@@ -31,10 +31,14 @@ UNION: integer fixnum bignum ;
     foldable
 
 : (next-power-of-2) ( i n -- n )
-    2dup >= [ drop ] [ >r 1 shift r> (next-power-of-2) ] if ;
+    2dup >= [
+        drop
+    ] [
+        >r 1 shift 1 max r> (next-power-of-2)
+    ] if ;
 
 : next-power-of-2 ( n -- n )
-    2 swap (next-power-of-2) ;
+    0 swap (next-power-of-2) ;
 
 IN: math-internals
 

library/math/ratio.factor

@@ -35,6 +35,8 @@ M: ratio - ( x y -- x-y ) 2dup scale - -rot ratio+d / ;
 M: ratio * ( x y -- x*y ) 2>fraction * >r * r> / ;
 M: ratio / scale / ;
 M: ratio /i scale /i ;
+M: ratio /mod 2dup >r >r /i dup r> * r> swap - ;
+M: ratio mod /mod nip ;
 M: ratio /f scale /f ;
 
 M: ratio truncate >fraction /i ;

library/opengl/opengl-utils.factor

@@ -14,10 +14,16 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
     0 0 width get height get glViewport
     0 width get height get 0 gluOrtho2D
     GL_SMOOTH glShadeModel
-    GL_TEXTURE_2D glEnable ;
+    GL_TEXTURE_2D glEnable
+    GL_BLEND glEnable
+    GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+    GL_SCISSOR_TEST glEnable ;
 
 : gl-flags
-    SDL_OPENGL SDL_RESIZABLE bitor SDL_HWSURFACE bitor SDL_DOUBLEBUF bitor ;
+    SDL_OPENGL
+    SDL_RESIZABLE bitor
+    SDL_HWSURFACE bitor
+    SDL_DOUBLEBUF bitor ;
 
 : gl-resize ( event -- )
     #! Acts on an SDL resize event.
@@ -44,13 +50,13 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
 
 : gl-vertex first3 glVertex3d ;
 
-: top-left drop @{ 0 0 0 }@ gl-vertex ;
+: top-left drop 0 0 glTexCoord2d @{ 0 0 0 }@ gl-vertex ;
 
-: top-right @{ 1 0 0 }@ v* gl-vertex ;
+: top-right 1 0 glTexCoord2d @{ 1 0 0 }@ v* gl-vertex ;
 
-: bottom-left @{ 0 1 0 }@ v* gl-vertex ;
+: bottom-left 0 1 glTexCoord2d @{ 0 1 0 }@ v* gl-vertex ;
 
-: bottom-right gl-vertex ;
+: bottom-right 1 1 glTexCoord2d gl-vertex ;
 
 : four-sides ( dim -- )
     dup top-left dup top-right dup bottom-right bottom-left ;
@@ -58,19 +64,17 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
 : gl-line ( from to { r g b } -- )
     gl-color [ gl-vertex ] 2apply ;
 
-: (gl-rect) swap gl-color [ four-sides ] do-state ;
+: gl-fill-rect ( dim -- )
-
-: gl-fill-rect ( dim { r g b } -- )
     #! Draws a two-dimensional box.
-    GL_QUADS (gl-rect) ;
+    GL_QUADS [ four-sides ] do-state ;
 
-: gl-rect ( dim { r g b } -- )
+: gl-rect ( dim -- )
     #! Draws a two-dimensional box.
-    GL_LINE_LOOP (gl-rect) ;
+    GL_LINE_LOOP [ four-sides ] do-state ;
 
-: (gl-poly) swap gl-color [ [ gl-vertex ] each ] do-state ;
+: (gl-poly) [ [ gl-vertex ] each ] do-state ;
 
-: gl-fill-poly ( points { r g b } -- )
+: gl-fill-poly ( points -- )
     #! Draw a filled polygon.
     GL_POLYGON (gl-poly) ;
 
@@ -82,7 +86,9 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
     swap glMatrixMode glPushMatrix call glPopMatrix ; inline
 
 : gl-set-clip ( loc dim -- )
-    [ first2 ] 2apply glScissor ;
+    dup first2 >r >r
+    over second swap second + height get swap - >r
+    first r> r> r> glScissor ;
 
 : prepare-gradient ( direction dim -- v1 v2 )
     tuck v* [ v- ] keep ;
@@ -104,17 +110,26 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
 : save-attribs ( bits quot -- )
     swap glPushAttrib call glPopAttrib ; inline
 
-: gray-texture ( width height buffer -- id )
+! A sprite is a texture and a display list.
+TUPLE: sprite dlist texture loc dim dim2 ;
+
+C: sprite ( loc dim dim2 -- )
+    [ set-sprite-dim2 ] keep
+    [ set-sprite-dim ] keep
+    [ set-sprite-loc ] keep ;
+
+: sprite-size2 sprite-dim2 first2 ;
+
+: sprite-width sprite-dim first ;
+
+: gray-texture ( sprite buffer -- id )
     #! Given a buffer holding a width x height (powers of two)
     #! grayscale texture, bind it and return the ID.
     gen-texture [
         GL_TEXTURE_BIT [
             GL_TEXTURE_2D swap glBindTexture
-            GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+            >r >r GL_TEXTURE_2D 0 GL_RGBA r>
-            GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+            sprite-size2 0 GL_LUMINANCE_ALPHA
-            GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
-            GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf
-            >r >r >r GL_TEXTURE_2D 0 GL_RGBA r> r> 0 GL_RGBA
             GL_UNSIGNED_BYTE r> glTexImage2D
         ] save-attribs
     ] keep ;
@@ -127,19 +142,25 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
     #! Make a display list.
     gen-dlist [ rot glNewList call glEndList ] keep ; inline
 
-: texture>dlist ( width height id -- id )
+: init-texture ( -- )
-    #! Given a texture width/height and ID, make a display list
+    GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
-    #! for draws a quad with this texture.
+    GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ;
+
+: make-sprite-dlist ( sprite -- id )
     GL_MODELVIEW [
         GL_COMPILE [
-            1 1 1 glColor3f
+            GL_MODELVIEW [
-            GL_TEXTURE_2D swap glBindTexture
+                dup sprite-loc first3 glTranslatef
-            GL_QUADS [
+                GL_TEXTURE_2D over sprite-texture glBindTexture
-                0 0 glTexCoord2d 0 0 glVertex2i
+                init-texture
-                0 1 glTexCoord2d 0 over glVertex2i
+                dup sprite-dim2 gl-fill-rect
-                1 1 glTexCoord2d 2dup glVertex2i
+            ] do-matrix
-                1 0 glTexCoord2d over 0 glVertex2i
+            sprite-width 0 0 glTranslatef
-            ] do-state
-            drop 0 0 glTranslatef
         ] make-dlist
     ] do-matrix ;
+
+: init-sprite ( texture sprite -- )
+    [ set-sprite-texture ] keep
+    [ make-sprite-dlist ] keep set-sprite-dlist ;

library/sdl/load.factor

@@ -10,7 +10,6 @@ USING: alien io kernel parser sequences ;
     "/library/sdl/sdl.factor"
     "/library/sdl/sdl-video.factor"
     "/library/sdl/sdl-event.factor"
-    "/library/sdl/sdl-gfx.factor"
     "/library/sdl/sdl-keysym.factor"
     "/library/sdl/sdl-keyboard.factor"
     "/library/sdl/sdl-utils.factor"

library/sdl/sdl-gfx.factor

@@ -1,108 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: sdl USING: alien ;
-
-: pixelColor ( surface x y color -- )
-    "void" "sdl-gfx" "pixelColor"
-    [ "surface*" "short" "short" "uint" ]
-    alien-invoke ;
-
-: hlineColor ( surface x1 x2 y color -- )
-    "void" "sdl-gfx" "hlineColor"
-    [ "surface*" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: vlineColor ( surface x y1 y2 color -- )
-    "void" "sdl-gfx" "vlineColor"
-    [ "surface*" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: rectangleColor ( surface x1 y1 x2 y2 color -- )
-    "void" "sdl-gfx" "rectangleColor"
-    [ "surface*" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: boxColor ( surface x1 y1 x2 y2 color -- )
-    "void" "sdl-gfx" "boxColor"
-    [ "surface*" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: lineColor ( surface x1 y1 x2 y2 color -- )
-    "void" "sdl-gfx" "lineColor"
-    [ "surface*" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: aalineColor ( surface x1 y1 x2 y2 color -- )
-    "void" "sdl-gfx" "aalineColor"
-    [ "surface*" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: circleColor ( surface x y r color -- )
-    "void" "sdl-gfx" "circleColor"
-    [ "surface*" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: aacircleColor ( surface x y r color -- )
-    "void" "sdl-gfx" "aacircleColor"
-    [ "surface*" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: filledCircleColor ( surface x y r color -- )
-    "void" "sdl-gfx" "filledCircleColor"
-    [ "surface*" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: ellipseColor ( surface x y rx ry color -- )
-    "void" "sdl-gfx" "ellipseColor"
-    [ "surface*" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: aaellipseColor ( surface x y rx ry color -- )
-    "void" "sdl-gfx" "aaellipseColor"
-    [ "surface*" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: filledEllipseColor ( surface x y rx ry color -- )
-    "void" "sdl-gfx" "filledEllipseColor"
-    [ "surface*" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: trigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
-    "void" "sdl-gfx" "trigonColor"
-    [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: aatrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
-    "void" "sdl-gfx" "aatrigonColor"
-    [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: filledTrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
-    "void" "sdl-gfx" "filledTrigonColor"
-    [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
-    alien-invoke ;
-
-: polygonColor ( surface vx vy n color -- )
-    "void" "sdl-gfx" "polygonColor"
-    [ "surface*" "short*" "short*" "int" "int" ]
-    alien-invoke ;
-
-: aapolygonColor ( surface vx vy n color -- )
-    "void" "sdl-gfx" "aapolygonColor"
-    [ "surface*" "short*" "short*" "int" "int" ]
-    alien-invoke ;
-
-: filledPolygonColor ( surface vx vy n color -- )
-    "void" "sdl-gfx" "filledPolygonColor"
-    [ "surface*" "short*" "short*" "int" "int" ]
-    alien-invoke ;
-
-: characterColor ( surface x y c color -- )
-    "void" "sdl-gfx" "characterColor"
-    [ "surface*" "short" "short" "char" "uint" ]
-    alien-invoke ;
-
-: stringColor ( surface x y str color -- )
-    "void" "sdl-gfx" "stringColor"
-    [ "surface*" "short" "short" "char*" "uint" ]
-    alien-invoke ;

library/sdl/sdl-utils.factor

@@ -30,28 +30,6 @@ SYMBOL: bpp
     [ [ >r init-sdl r> call ] [ SDL_Quit ] cleanup ] with-scope ;
     inline
 
-: rgb ( [ r g b ] -- n )
-    first3
-    255
-    swap >fixnum 8 shift bitor
-    swap >fixnum 16 shift bitor
-    swap >fixnum 24 shift bitor ;
-
-: make-rect ( x y w h -- rect )
-    <sdl-rect>
-    [ set-sdl-rect-h ] keep
-    [ set-sdl-rect-w ] keep
-    [ set-sdl-rect-y ] keep
-    [ set-sdl-rect-x ] keep ;
-
-: with-pixels ( quot -- )
-    width get [
-        height get [
-            [ rot dup slip swap surface get swap ] 2keep
-            [ rot pixelColor ] 2keep
-        ] repeat
-    ] repeat drop ; inline
-
 : must-lock-surface? ( -- ? )
     #! This is a macro in SDL_video.h.
     surface get dup surface-offset 0 = [

library/test/math/integer.factor

@@ -85,7 +85,8 @@ unit-test
 [ 0 ] [ -7/8 ceiling ] unit-test
 [ -1 ] [ -3/2 ceiling ] unit-test
 
-[ 2 ] [ 1 next-power-of-2 ] unit-test
+[ 0 ] [ 0 next-power-of-2 ] unit-test
+[ 1 ] [ 1 next-power-of-2 ] unit-test
 [ 2 ] [ 2 next-power-of-2 ] unit-test
 [ 4 ] [ 3 next-power-of-2 ] unit-test
 [ 16 ] [ 13 next-power-of-2 ] unit-test

library/ui/editors.factor

@@ -54,7 +54,7 @@ TUPLE: editor line caret ;
 
 : run-char-widths ( font str -- wlist )
     #! List of x co-ordinates of each character.
-    >array [ char-size drop ] map-with
+    >array [ char-width ] map-with
     dup 0 [ + ] accumulate swap 2 v/n v+ ;
 
 : x>offset ( x font str -- offset )
@@ -122,7 +122,7 @@ C: editor ( text -- )
     dup editor-actions ;
 
 : offset>x ( gadget offset str -- x )
-    head-slice >r gadget-font r> string-size drop ;
+    head-slice >r gadget-font r> string-width ;
 
 : caret-loc ( editor -- x y )
     dup editor-line [ caret-pos line-text get ] bind offset>x

library/ui/labels.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets-labels
 USING: arrays freetype gadgets gadgets-layouts generic
-hashtables io kernel math namespaces sequences styles ;
+hashtables io kernel math namespaces opengl sequences styles ;
 
 ! A label gadget draws a string.
 TUPLE: label text ;
@@ -15,13 +15,14 @@ C: label ( text -- label )
     [ 2dup [ set-label-text ] keep relayout ] unless 2drop ;
 
 : label-size ( gadget text -- dim )
-    dup gadget-font swap label-text string-size 0 3array ;
+    dup gadget-font dup font-height >r
+    swap label-text string-width r> 0 3array ;
 
 M: label pref-dim ( label -- dim )
     label-size ;
 
 : draw-label ( label -- )
-    dup gadget-font swap label-text draw-string ;
+    dup fg gl-color dup gadget-font swap label-text draw-string ;
 
 M: label draw-gadget* ( label -- )
     dup delegate draw-gadget* draw-label ;

library/ui/paint.factor

@@ -81,10 +81,10 @@ TUPLE: solid ;
 
 ! Solid pen
 M: solid draw-interior
-    drop dup rect-dim swap bg gl-fill-rect ;
+    drop dup bg gl-color rect-dim gl-fill-rect ;
 
 M: solid draw-boundary
-    drop dup rect-dim @{ 1 1 0 }@ v- swap fg gl-rect ;
+    drop dup fg gl-color rect-dim @{ 1 1 0 }@ v- gl-rect ;
 
 ! Rollover only
 TUPLE: rollover-only ;
@@ -115,10 +115,10 @@ M: gadget draw-gadget* ( gadget -- )
 TUPLE: polygon points ;
 
 M: polygon draw-boundary ( gadget polygon -- )
-    polygon-points swap fg gl-poly ;
+    swap fg gl-color polygon-points gl-poly ;
 
 M: polygon draw-interior ( gadget polygon -- )
-    polygon-points swap bg gl-fill-poly ;
+    swap bg gl-color polygon-points gl-fill-poly ;
 
 : arrow-up    @{ @{ 3 0 0 }@ @{ 6 6 0 }@ @{ 0 6 0 }@ }@ ;
 : arrow-right @{ @{ 0 0 0 }@ @{ 6 3 0 }@ @{ 0 6 0 }@ }@ ;

library/ui/world.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: alien arrays errors gadgets-layouts generic io kernel
+USING: alien arrays errors freetype gadgets-layouts generic io
-lists math memory namespaces opengl prettyprint sdl
+kernel lists math memory namespaces opengl prettyprint sdl
 sequences sequences strings styles threads ;
 
 ! The world gadget is the top level gadget that all (visible)
@@ -118,5 +118,6 @@ M: quit-event handle-event ( event -- )
     drop stop-world ;
 
 M: resize-event handle-event ( event -- )
+    flush-fonts
     gl-resize
     width get height get 0 3array world get set-gadget-dim ;