! 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>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 ;
+: <cairo-gadget> ( dim quot -- )
+ over 2^-bounds swap copy-cairo
+ GL_BGRA rot <texture-gadget> ;
-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> ;
--- /dev/null
+! 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>> ;