diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index bda18d04b4..f5f4d3e965 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -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?>> ; -: ( width height quot -- cairo-gadget ) - cairo-gadget construct-gadget - swap >>quot - swap >>height - swap >>width ; - -: ( width height quot -- 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 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 ; +: ( dim quot -- ) + over 2^-bounds swap copy-cairo + GL_BGRA rot ; -: 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 ; -: ( width height bytes -- cairo-gadget ) - >r [ ] r> >>texture ; - : ( 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 - ; + GL_BGRA rot ; diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index fa12f96622..44ebfc30a5 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -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 ] 2bi ; + [ compose [ with-pango ] curry ] 2bi ; : ( quot -- gadget ) [ cr layout pango_cairo_show_layout ] (pango-gadget) ; diff --git a/extra/cairo/pango/pango.factor b/extra/cairo/pango/pango.factor index 3f702769d8..bb9c473047 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/cairo/pango/pango.factor @@ -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 diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 3cc63922f8..0e83381349 100644 --- a/extra/cairo/samples/samples.factor +++ b/extra/cairo/samples/samples.factor @@ -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 gadget. ] each ; + [ { 256 256 } swap 1quotation gadget. ] each ; - MAIN: samples \ No newline at end of file + MAIN: samples diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor new file mode 100644 index 0000000000..1a15283048 --- /dev/null +++ b/extra/opengl/gadgets/gadgets.factor @@ -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 + +: ( 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>> ;