>r first2 over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
- r> with-cairo-from-surface ;
+ r> with-cairo-from-surface ; inline
-TUPLE: cairo-gadget < texture-gadget quot ;
+TUPLE: cairo-gadget < texture-gadget dim quot ;
: <cairo-gadget> ( dim quot -- gadget )
cairo-gadget construct-gadget
swap >>quot
swap >>dim ;
-M: cairo-gadget format>> drop GL_BGRA ;
+M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
-M: cairo-gadget render* ( gadget -- )
- dup
- [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi
- >>bytes call-next-method ;
+: render-cairo ( dim quot -- bytes format )
+ >r 2^-bounds r> copy-cairo GL_BGRA ;
+
+M: cairo-gadget render*
+ [ dim>> dup ] [ quot>> ] bi
+ render-cairo render-bytes* ;
! maybe also texture>png
! : cairo>png ( gadget path -- )
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
-: <png-gadget> ( path -- gadget )
- normalize-path cairo_image_surface_create_from_png
+TUPLE: png-gadget < texture-gadget path ;
+: <png> ( path -- gadget )
+ png-gadget construct-gadget
+ swap >>path ;
+
+M: png-gadget render*
+ path>> normalize-path cairo_image_surface_create_from_png
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height 2array dup 2^-bounds ]
[ [ copy-surface ] curry copy-cairo ] tri
- GL_BGRA rot <texture-gadget> ;
-
+ GL_BGRA render-bytes* ;
+M: png-gadget cache-key* path>> ;
{ "face-size*" "size" }
{ "void*" "charmap" } ;
+C-STRUCT: FT_Bitmap
+ { "int" "rows" }
+ { "int" "width" }
+ { "int" "pitch" }
+ { "void*" "buffer" }
+ { "short" "num_grays" }
+ { "char" "pixel_mode" }
+ { "char" "palette_mode" }
+ { "void*" "palette" } ;
+
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ;
FT_RENDER_MODE_LCD
FT_RENDER_MODE_LCD_V ;
+C-ENUM:
+ FT_PIXEL_MODE_NONE
+ FT_PIXEL_MODE_MONO
+ FT_PIXEL_MODE_GRAY
+ FT_PIXEL_MODE_GRAY2
+ FT_PIXEL_MODE_GRAY4
+ FT_PIXEL_MODE_LCD
+ FT_PIXEL_MODE_LCD_V ;
+
FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ;
FUNCTION: void FT_Done_Face ( face* face ) ;
FUNCTION: void FT_Done_FreeType ( void* library ) ;
FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ;
+
! See http://factorcode.org/license.txt for BSD license.
USING: locals math.functions math namespaces
opengl.gl accessors kernel opengl ui.gadgets
+fry assocs
destructors sequences ui.render colors ;
IN: opengl.gadgets
-TUPLE: texture-gadget bytes format dim tex ;
+TUPLE: texture-gadget ;
+
+GENERIC: render* ( gadget -- texture dims )
+GENERIC: cache-key* ( gadget -- key )
+
+M: texture-gadget cache-key* ;
+
+SYMBOL: textures
+SYMBOL: refcounts
+
+: init-cache ( symbol -- )
+ dup get [ drop ] [ H{ } clone swap set-global ] if ;
+
+textures init-cache
+refcounts init-cache
+
+: refcount-change ( gadget quot -- )
+ >r cache-key* refcounts get
+ [ [ 0 ] unless* ] r> compose change-at ;
+
+TUPLE: cache-entry tex dims ;
+C: <entry> cache-entry
+
+: make-entry ( gadget -- entry )
+ dup render* <entry>
+ [ swap cache-key* textures get set-at ] keep ;
+
+: get-entry ( gadget -- {texture,dims} )
+ dup cache-key* textures get at
+ [ nip ] [ make-entry ] if* ;
+
+: get-dims ( gadget -- dims )
+ get-entry dims>> ;
+
+: get-texture ( gadget -- texture )
+ get-entry tex>> ;
+
+: release-texture ( gadget -- )
+ cache-key* textures get delete-at*
+ [ tex>> delete-texture ] [ drop ] if ;
+
+M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
+
+M: texture-gadget ungraft* ( gadget -- )
+ dup [ 1- ] refcount-change
+ dup cache-key* refcounts get at
+ zero? [ release-texture ] [ drop ] if ;
: 2^-ceil ( x -- y )
dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
: 2^-bounds ( dim -- dim' )
[ 2^-ceil ] map ; foldable flushable
-: <texture-gadget> ( bytes format dim -- gadget )
- texture-gadget construct-gadget
- swap >>dim
- swap >>format
- swap >>bytes ;
-
-GENERIC: render* ( texture-gadget -- )
-
-M:: texture-gadget render* ( gadget -- )
+:: (render-bytes) ( dims bytes format texture -- )
GL_ENABLE_BIT [
GL_TEXTURE_2D glEnable
- GL_TEXTURE_2D gadget tex>> glBindTexture
+ GL_TEXTURE_2D texture glBindTexture
GL_TEXTURE_2D
0
GL_RGBA
- gadget dim>> 2^-bounds first2
+ dims 2^-bounds first2
0
- gadget format>>
+ format
GL_UNSIGNED_BYTE
- gadget bytes>>
+ bytes
glTexImage2D
init-texture
GL_TEXTURE_2D 0 glBindTexture
] do-attribs ;
+: render-bytes ( dims bytes format -- texture )
+ gen-texture [ (render-bytes) ] keep ;
+
+: render-bytes* ( dims bytes format -- texture dims )
+ pick >r render-bytes r> ;
+
:: four-corners ( dim -- )
[let* | w [ dim first ]
h [ dim second ]
white gl-color
1.0 -1.0 glPixelZoom
GL_TEXTURE_2D glEnable
- GL_TEXTURE_2D over tex>> glBindTexture
+ GL_TEXTURE_2D over get-texture glBindTexture
GL_QUADS [
- dim>> four-corners
+ get-dims four-corners
] do-state
GL_TEXTURE_2D 0 glBindTexture
] do-attribs
] with-translation ;
-M: texture-gadget graft* ( gadget -- )
- gen-texture >>tex [ render* ]
- [ f >>bytes drop ] bi ;
-
-M: texture-gadget ungraft* ( gadget -- )
- tex>> delete-texture ;
-
-M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;
+M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;
! Higher level words and combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-USING: destructors accessors namespaces kernel cairo ;
-
-TUPLE: pango-layout alien ;
-C: <pango-layout> pango-layout
-M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
-
-: layout ( -- pango-layout ) pango-layout get ;
+USING: pango.layouts
+destructors accessors namespaces kernel cairo ;
: (with-pango) ( layout quot -- )
>r alien>> pango-layout r> with-variable ; inline
-: with-pango ( quot -- )
- cr pango_cairo_create_layout <pango-layout> swap
- [ (with-pango) ] curry with-disposal ; inline
-
-: pango-layout-get-pixel-size ( layout -- width height )
- 0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
- [ *int ] bi@ ;
+: with-pango-cairo ( quot -- )
+ cr pango_cairo_create_layout swap with-layout ;
MEMO: dummy-cairo ( -- cr )
CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ;
: dummy-pango ( quot -- )
- >r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline
+ >r dummy-cairo cairo r> [ with-pango-cairo ] curry with-variable ; inline
: layout-size ( quot -- dim )
[ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
-: layout-font ( str -- )
- pango_font_description_from_string
- dup zero? [ "pango: not a valid font." throw ] when
- layout over pango_layout_set_font_description
- pango_font_description_free ;
-
-: layout-text ( str -- )
- layout swap -1 pango_layout_set_text ;
-
: show-layout ( -- )
cr layout pango_cairo_show_layout ;
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: pango.cairo cairo cairo.ffi
-cairo.gadgets namespaces arrays
-fry accessors ui.gadgets assocs
-sequences shuffle opengl opengl.gadgets
-alien.c-types kernel math ;
-IN: pango.cairo.gadgets
-
-SYMBOL: textures
-SYMBOL: dims
-SYMBOL: refcounts
-
-: init-cache ( symbol -- )
- dup get [ drop ] [ H{ } clone swap set-global ] if ;
-
-textures init-cache
-dims init-cache
-refcounts init-cache
-
-TUPLE: pango-gadget < cairo-gadget text font ;
-
-: cache-key ( gadget -- key )
- [ font>> ] [ text>> ] bi 2array ;
+USING: pango.cairo pango.gadgets
+cairo.gadgets arrays namespaces
+fry accessors ui.gadgets
+sequences opengl.gadgets
+kernel pango.layouts ;
-: refcount-change ( gadget quot -- )
- >r cache-key refcounts get
- [ [ 0 ] unless* ] r> compose change-at ;
-
-: <pango-gadget> ( font text -- gadget )
- pango-gadget construct-gadget
- swap >>text
- swap >>font ;
-
-: setup-layout ( {font,text} -- quot )
- first2 '[ , layout-font , layout-text ] ;
-
-M: pango-gadget quot>> ( gadget -- quot )
- cache-key setup-layout [ show-layout ] compose
- [ with-pango ] curry ;
-
-M: pango-gadget dim>> ( gadget -- dim )
- cache-key dims get [ setup-layout layout-size ] cache ;
-
-M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
+IN: pango.cairo.gadgets
-: release-texture ( gadget -- )
- cache-key textures get delete-at* [ delete-texture ] [ drop ] if ;
+TUPLE: pango-cairo-gadget < pango-gadget ;
-M: pango-gadget ungraft* ( gadget -- )
- dup [ 1- ] refcount-change
- dup cache-key refcounts get at
- zero? [ release-texture ] [ drop ] if ;
+SINGLETON: pango-cairo-backend
+pango-cairo-backend pango-backend set-global
-M: pango-gadget render* ( gadget -- )
- [ gen-texture ] [ cache-key textures get set-at ] bi
- call-next-method ;
+M: pango-cairo-backend construct-pango
+ pango-cairo-gadget construct-gadget ;
-M: pango-gadget tex>> ( gadget -- texture )
- dup cache-key textures get at
- [ nip ] [ dup render* tex>> ] if* ;
+: setup-layout ( gadget -- quot )
+ [ font>> ] [ text>> ] bi
+ '[ , layout-font , layout-text ] ;
-USE: ui.gadgets.panes
-: hello "Sans 50" "hello" <pango-gadget> gadget. ;
+M: pango-cairo-gadget render* ( gadget -- )
+ setup-layout [ layout-size dup ]
+ [
+ '[ [ @ show-layout ] with-pango-cairo ]
+ ] bi render-cairo render-bytes* ;
--- /dev/null
+USING: alien alien.c-types
+math kernel byte-arrays freetype
+opengl.gadgets accessors pango
+ui.gadgets memoize
+arrays sequences libc opengl.gl
+system combinators alien.syntax
+pango.layouts ;
+IN: pango.ft2
+
+<< "pangoft2" {
+! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
+! { [ os macosx? ] [ "libpangocairo.dylib" ] }
+ { [ os unix? ] [ "libpangoft2-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pangoft2
+
+FUNCTION: PangoFontMap*
+pango_ft2_font_map_new ( ) ;
+
+FUNCTION: PangoContext*
+pango_ft2_font_map_create_context ( PangoFT2FontMap* fontmap ) ;
+
+FUNCTION: void
+pango_ft2_render_layout ( FT_Bitmap* bitmap, PangoLayout* layout, int x, int y ) ;
+
+: 4*-ceil ( n -- k*4 )
+ 3 + 4 /i 4 * ;
+
+: <ft-bitmap> ( width height -- ft-bitmap )
+ swap dup
+ 2dup * 4*-ceil
+ "uchar" malloc-array
+ 256
+ FT_PIXEL_MODE_GRAY
+ "FT_Bitmap" <c-object> dup >r
+ {
+ set-FT_Bitmap-rows
+ set-FT_Bitmap-width
+ set-FT_Bitmap-pitch
+ set-FT_Bitmap-buffer
+ set-FT_Bitmap-num_grays
+ set-FT_Bitmap-pixel_mode
+ } set-slots r> ;
+
+: render-layout ( layout -- dims alien )
+ [
+ pango-layout-get-pixel-size
+ 2array dup 2^-bounds first2 <ft-bitmap> dup
+ ] [ 0 0 pango_ft2_render_layout ] bi FT_Bitmap-buffer ;
+
+MEMO: ft2-context ( -- PangoContext* )
+ pango_ft2_font_map_new pango_ft2_font_map_create_context ;
+
+: with-ft2-layout ( quot -- )
+ ft2-context pango_layout_new swap with-layout ; inline
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: pango.ft2 pango.gadgets opengl.gadgets
+accessors kernel opengl.gl libc
+sequences namespaces ui.gadgets pango.layouts ;
+IN: pango.ft2.gadgets
+
+TUPLE: pango-ft2-gadget < pango-gadget ;
+
+SINGLETON: pango-ft2-backend
+pango-ft2-backend pango-backend set-global
+
+M: pango-ft2-backend construct-pango
+ pango-ft2-gadget construct-gadget ;
+
+M: pango-ft2-gadget render*
+ [
+ [ text>> layout-text ] [ font>> layout-font ] bi
+ layout render-layout
+ ] with-ft2-layout [ GL_ALPHA render-bytes* ] keep free ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: opengl.gadgets kernel
+arrays
+accessors ;
+
+IN: pango.gadgets
+
+TUPLE: pango-gadget < texture-gadget text font ;
+
+M: pango-gadget cache-key* [ font>> ] [ text>> ] bi 2array ;
+
+SYMBOL: pango-backend
+HOOK: construct-pango pango-backend ( -- gadget )
+
+: <pango> ( font text -- gadget )
+ construct-pango
+ swap >>text
+ swap >>font ;
--- /dev/null
+USING: alien alien.c-types
+math
+destructors accessors namespaces
+pango kernel ;
+IN: pango.layouts
+
+: pango-layout-get-pixel-size ( layout -- width height )
+ 0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
+ [ *int ] bi@ ;
+
+TUPLE: pango-layout alien ;
+C: <pango-layout> pango-layout
+M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
+
+: layout ( -- pango-layout ) pango-layout get ;
+
+: (with-layout) ( pango-layout quot -- )
+ >r alien>> pango-layout r> with-variable ; inline
+
+: with-layout ( layout quot -- )
+ >r <pango-layout> r> [ (with-layout) ] curry with-disposal ; inline
+
+: layout-font ( str -- )
+ pango_font_description_from_string
+ dup zero? [ "pango: not a valid font." throw ] when
+ layout over pango_layout_set_font_description
+ pango_font_description_free ;
+
+: layout-text ( str -- )
+ layout swap -1 pango_layout_set_text ;
: PANGO_SCALE 1024 ;
+FUNCTION: PangoLayout*
+pango_layout_new ( PangoContext* context ) ;
+
FUNCTION: void
pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
projects / factor.git / commitdiff