Refactored cairo gadgets, basing them on the texture-gadget in opengl.gadgets
Matthew Willis
parent
394b14d501
commit
610c47eb18
|
|
@ -1,100 +1,39 @@
|
|||
! Copyright (C) 2008 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
|
||||
math byte-arrays ui.gadgets accessors arrays
|
||||
namespaces io.backend memoize colors ;
|
||||
USING: sequences math opengl.gadgets kernel
|
||||
byte-arrays cairo.ffi cairo io.backend
|
||||
opengl.gl arrays ;
|
||||
|
||||
IN: cairo.gadgets
|
||||
|
||||
! We need two kinds of gadgets:
|
||||
! one performs the cairo ops once and caches the bytes, the other
|
||||
! performs cairo ops every refresh
|
||||
|
||||
TUPLE: cairo-gadget width height quot cache? texture ;
|
||||
PREDICATE: cached-cairo < cairo-gadget cache?>> ;
|
||||
: <cairo-gadget> ( width height quot -- cairo-gadget )
|
||||
cairo-gadget construct-gadget
|
||||
swap >>quot
|
||||
swap >>height
|
||||
swap >>width ;
|
||||
|
||||
: <cached-cairo> ( width height quot -- cairo-gadget )
|
||||
<cairo-gadget> t >>cache? ;
|
||||
|
||||
: width>stride ( width -- stride ) 4 * ;
|
||||
|
||||
: copy-cairo ( width height quot -- byte-array )
|
||||
>r over width>stride
|
||||
: copy-cairo ( dim quot -- byte-array )
|
||||
>r first2 over width>stride
|
||||
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
|
||||
[ cairo_image_surface_create_for_data ] 3bi
|
||||
r> with-cairo-from-surface ;
|
||||
|
||||
: cairo>bytes ( gadget -- byte-array )
|
||||
[ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
|
||||
: <cairo-gadget> ( dim quot -- )
|
||||
over 2^-bounds swap copy-cairo
|
||||
GL_BGRA rot <texture-gadget> ;
|
||||
|
||||
: cairo>png ( gadget path -- )
|
||||
>r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
|
||||
[ height>> ] tri over width>stride
|
||||
cairo_image_surface_create_for_data
|
||||
r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
|
||||
|
||||
: with-cairo-gl ( quot -- )
|
||||
>r origin get [
|
||||
0 0 glRasterPos2i
|
||||
1.0 -1.0 glPixelZoom
|
||||
] r> compose with-translation ;
|
||||
|
||||
M: cairo-gadget draw-gadget* ( gadget -- )
|
||||
[
|
||||
[ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
|
||||
[ cairo>bytes ] tri glDrawPixels
|
||||
] with-cairo-gl ;
|
||||
|
||||
MEMO: render-to-texture ( gadget -- )
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D over texture>> glBindTexture
|
||||
>r GL_TEXTURE_2D 0 GL_RGBA r>
|
||||
[ width>> ] [ height>> 0 GL_BGRA GL_UNSIGNED_BYTE ]
|
||||
[ cairo>bytes ] tri glTexImage2D
|
||||
init-texture
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] do-attribs ;
|
||||
|
||||
M: cached-cairo draw-gadget* ( gadget -- )
|
||||
GL_TEXTURE_2D [
|
||||
[
|
||||
dup render-to-texture
|
||||
white gl-color
|
||||
GL_TEXTURE_2D over texture>> glBindTexture
|
||||
GL_QUADS [
|
||||
[ width>> ] [ height>> ] bi 2array four-sides
|
||||
] do-state
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-cairo-gl
|
||||
] do-enabled ;
|
||||
|
||||
M: cached-cairo graft* ( gadget -- )
|
||||
gen-texture >>texture drop ;
|
||||
|
||||
M: cached-cairo ungraft* ( gadget -- )
|
||||
[ texture>> delete-texture ]
|
||||
[ \ render-to-texture invalidate-memoized ] bi ;
|
||||
|
||||
M: cairo-gadget pref-dim* ( gadget -- rect )
|
||||
[ width>> ] [ height>> ] bi 2array ;
|
||||
! maybe also texture>png
|
||||
! : cairo>png ( gadget path -- )
|
||||
! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
|
||||
! [ height>> ] tri over width>stride
|
||||
! cairo_image_surface_create_for_data
|
||||
! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
|
||||
|
||||
: copy-surface ( surface -- )
|
||||
cr swap 0 0 cairo_set_source_surface
|
||||
cr cairo_paint ;
|
||||
|
||||
: <bytes-gadget> ( width height bytes -- cairo-gadget )
|
||||
>r [ ] <cached-cairo> r> >>texture ;
|
||||
|
||||
: <png-gadget> ( path -- gadget )
|
||||
normalize-path cairo_image_surface_create_from_png
|
||||
[ cairo_image_surface_get_width ]
|
||||
[ cairo_image_surface_get_height 2dup ]
|
||||
[ cairo_image_surface_get_height 2array dup 2^-bounds ]
|
||||
[ [ copy-surface ] curry copy-cairo ] tri
|
||||
<bytes-gadget> ;
|
||||
GL_BGRA rot <texture-gadget> ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,12 @@
|
|||
! Copyright (C) 2008 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cairo.pango cairo cairo.ffi cairo.gadgets
|
||||
alien.c-types kernel math ;
|
||||
IN: cairo.pango.gadgets
|
||||
|
||||
: (pango-gadget) ( setup show -- gadget )
|
||||
[ drop layout-size ]
|
||||
[ compose [ with-pango ] curry <cached-cairo> ] 2bi ;
|
||||
[ compose [ with-pango ] curry <cairo-gadget> ] 2bi ;
|
||||
|
||||
: <pango-gadget> ( quot -- gadget )
|
||||
[ cr layout pango_cairo_show_layout ] (pango-gadget) ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
! pangocairo bindings, from pango/pangocairo.h
|
||||
USING: cairo.ffi alien.c-types math
|
||||
alien.syntax system combinators alien
|
||||
pango pango.fonts ;
|
||||
arrays pango pango.fonts ;
|
||||
IN: cairo.pango
|
||||
|
||||
<< "pangocairo" {
|
||||
|
|
@ -115,8 +115,8 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
|
|||
>r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
|
||||
r> [ with-pango ] curry with-cairo-from-surface ; inline
|
||||
|
||||
: layout-size ( quot -- width height )
|
||||
[ layout pango-layout-get-pixel-size ] compose dummy-pango ; inline
|
||||
: layout-size ( quot -- dim )
|
||||
[ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
|
||||
|
||||
: layout-font ( str -- )
|
||||
pango_font_description_from_string
|
||||
|
|
|
|||
|
|
@ -142,6 +142,6 @@ IN: cairo.samples
|
|||
USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
|
||||
: samples ( -- )
|
||||
{ arc clip clip-image dash gradient text utf8 }
|
||||
[ 256 256 rot 1quotation <cached-cairo> gadget. ] each ;
|
||||
[ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
|
||||
|
||||
MAIN: samples
|
||||
MAIN: samples
|
||||
|
|
|
|||
|
|
@ -0,0 +1,72 @@
|
|||
! Copyright (C) 2008 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: locals math.functions math namespaces
|
||||
opengl.gl accessors kernel opengl ui.gadgets
|
||||
destructors sequences ui.render colors ;
|
||||
IN: opengl.gadgets
|
||||
|
||||
TUPLE: texture-gadget bytes format dim tex ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
:: render ( gadget -- )
|
||||
GL_ENABLE_BIT [
|
||||
GL_TEXTURE_2D glEnable
|
||||
GL_TEXTURE_2D gadget tex>> glBindTexture
|
||||
GL_TEXTURE_2D
|
||||
0
|
||||
GL_RGBA
|
||||
gadget dim>> 2^-bounds first2
|
||||
0
|
||||
gadget format>>
|
||||
GL_UNSIGNED_BYTE
|
||||
gadget bytes>>
|
||||
glTexImage2D
|
||||
init-texture
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] do-attribs ;
|
||||
|
||||
:: four-corners ( dim -- )
|
||||
[let* | w [ dim first ]
|
||||
h [ dim second ]
|
||||
dim' [ dim dup 2^-bounds [ /f ] 2map ]
|
||||
w' [ dim' first ]
|
||||
h' [ dim' second ] |
|
||||
0 0 glTexCoord2d 0 0 glVertex2d
|
||||
0 h' glTexCoord2d 0 h glVertex2d
|
||||
w' h' glTexCoord2d w h glVertex2d
|
||||
w' 0 glTexCoord2d w 0 glVertex2d
|
||||
] ;
|
||||
|
||||
M: texture-gadget draw-gadget* ( gadget -- )
|
||||
origin get [
|
||||
GL_ENABLE_BIT [
|
||||
white gl-color
|
||||
1.0 -1.0 glPixelZoom
|
||||
GL_TEXTURE_2D glEnable
|
||||
GL_TEXTURE_2D over tex>> glBindTexture
|
||||
GL_QUADS [
|
||||
dim>> four-corners
|
||||
] do-state
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] do-attribs
|
||||
] with-translation ;
|
||||
|
||||
M: texture-gadget graft* ( gadget -- )
|
||||
gen-texture >>tex [ render ]
|
||||
[ f >>bytes f >>format drop ] bi ;
|
||||
|
||||
M: texture-gadget ungraft* ( gadget -- )
|
||||
tex>> delete-texture ;
|
||||
|
||||
M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;
|
||||
Loading…
Reference in New Issue