From 0c8d14537879f577904dc7c7dbe78b8636c2cc89 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 24 May 2008 20:03:31 -0700 Subject: [PATCH 01/11] changed "cairo.pango.gadgets" run to use Japanese --- extra/cairo/pango/gadgets/gadgets.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 780881e872..48e5e683a9 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -12,8 +12,8 @@ IN: cairo.pango.gadgets USING: prettyprint sequences ui.gadgets.panes ; : hello-pango ( -- ) 50 [ 6 + ] map [ - "Sans Bold " swap unparse append - [ layout-font "Hello, Pango!" layout-text ] curry + "Sans " swap unparse append + [ layout-font "今日は、 Pango!" layout-text ] curry gadget. ] each ; From d5f6cf4d057cd4e9d9ddaa4658bbb3cfde0b594b Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 24 May 2008 20:04:12 -0700 Subject: [PATCH 02/11] Initial commit of GL texture gadgets --- extra/cairo/gadgets/gadgets.factor | 59 +++++++++++++++++++++--------- 1 file changed, 42 insertions(+), 17 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index e0daefd63c..fa5364557e 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -2,7 +2,7 @@ ! 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 ; +namespaces io.backend memoize ; IN: cairo.gadgets @@ -10,7 +10,7 @@ IN: cairo.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? bytes ; +TUPLE: cairo-gadget width height quot cache? texture ; PREDICATE: cached-cairo < cairo-gadget cache?>> ; : ( width height quot -- cairo-gadget ) cairo-gadget construct-gadget @@ -29,31 +29,54 @@ PREDICATE: cached-cairo < cairo-gadget cache?>> ; [ cairo_image_surface_create_for_data ] 3bi r> with-cairo-from-surface ; -: (cairo>bytes) ( gadget -- byte-array ) +: cairo>bytes ( gadget -- byte-array ) [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ; -GENERIC: cairo>bytes -M: cairo-gadget cairo>bytes ( gadget -- byte-array ) - (cairo>bytes) ; - -M: cached-cairo cairo>bytes ( gadget -- byte-array ) - dup bytes>> [ ] [ - dup (cairo>bytes) [ >>bytes drop ] keep - ] ?if ; - : 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 ; -M: cairo-gadget draw-gadget* ( gadget -- ) - origin get [ +: 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-translation ; + ] 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 + 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 ; M: cairo-gadget pref-dim* ( gadget -- rect ) [ width>> ] [ height>> ] bi 2array ; @@ -63,11 +86,13 @@ M: cairo-gadget pref-dim* ( gadget -- rect ) cr cairo_paint ; : ( width height bytes -- cairo-gadget ) - >r [ ] r> >>bytes ; + >r [ ] r> >>texture ; : ( path -- gadget ) normalize-path cairo_image_surface_create_from_png [ cairo_image_surface_get_width ] [ cairo_image_surface_get_height 2dup ] [ [ copy-surface ] curry copy-cairo ] tri - ; \ No newline at end of file + ; + + From 87b6cb5d404861ccbe78abbb199f1d803cc85f98 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 11:59:41 -0700 Subject: [PATCH 03/11] fixed a color issue in texture rendering --- extra/cairo/gadgets/gadgets.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index fa5364557e..bda18d04b4 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -2,7 +2,7 @@ ! 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 ; +namespaces io.backend memoize colors ; IN: cairo.gadgets @@ -64,6 +64,7 @@ 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 @@ -76,7 +77,8 @@ M: cached-cairo graft* ( gadget -- ) gen-texture >>texture drop ; M: cached-cairo ungraft* ( gadget -- ) - texture>> delete-texture ; + [ texture>> delete-texture ] + [ \ render-to-texture invalidate-memoized ] bi ; M: cairo-gadget pref-dim* ( gadget -- rect ) [ width>> ] [ height>> ] bi 2array ; From e1669916f60d279ec1edd3e7edd95b960ea2840a Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 12:00:55 -0700 Subject: [PATCH 04/11] add invalidate-memoized to extra/memoize so that specific entries can be removed from the memoization cache. This is used in cached-cairo ungraft* to ensure that textures re-rendered. --- extra/memoize/memoize.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 4136f9eaff..6a223fdc7e 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -52,3 +52,6 @@ M: memoized definition "memo-quot" word-prop ; : reset-memoized ( word -- ) "memoize" word-prop clear-assoc ; + +: invalidate-memoized ! ( inputs... word ) + [ #in packer call ] [ "memoize" word-prop delete-at ] bi ; From 383784d09ed2061e9f1e8267fabc7df877d1f9d5 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 12:03:26 -0700 Subject: [PATCH 05/11] incorporate color into "cairo.pango.gadgets" run for testing purposes. --- extra/cairo/pango/gadgets/gadgets.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 48e5e683a9..0ba901d453 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -9,12 +9,16 @@ IN: cairo.pango.gadgets : ( quot -- gadget ) [ cr layout pango_cairo_show_layout ] (pango-gadget) ; -USING: prettyprint sequences ui.gadgets.panes ; +USING: prettyprint sequences ui.gadgets.panes +threads ; : hello-pango ( -- ) 50 [ 6 + ] map [ "Sans " swap unparse append - [ layout-font "今日は、 Pango!" layout-text ] curry - gadget. + [ + cr 0 1 0.2 0.6 cairo_set_source_rgba + layout-font "今日は、 Pango!" layout-text + ] curry + gadget. yield ] each ; MAIN: hello-pango From 03ceb011259add3a688a9550a4165b72eb080acf Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 13:24:56 -0700 Subject: [PATCH 06/11] Add a larger text section example to "cairo.pango.gadgets" run --- extra/cairo/pango/gadgets/gadgets.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 0ba901d453..fa12f96622 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -10,7 +10,7 @@ IN: cairo.pango.gadgets [ cr layout pango_cairo_show_layout ] (pango-gadget) ; USING: prettyprint sequences ui.gadgets.panes -threads ; +threads io.backend io.encodings.utf8 io.files ; : hello-pango ( -- ) 50 [ 6 + ] map [ "Sans " swap unparse append @@ -19,6 +19,10 @@ threads ; layout-font "今日は、 Pango!" layout-text ] curry gadget. yield - ] each ; + ] each + [ + "resource:extra/cairo/pango/gadgets/gadgets.factor" + normalize-path utf8 file-contents layout-text + ] gadget. ; MAIN: hello-pango From 683ba1a7634106a9ce3174d330e555c8d85da14f Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 27 May 2008 20:18:31 -0700 Subject: [PATCH 07/11] Separated out cairo.pango into extra/pango and pango.fonts --- extra/cairo/pango/pango.factor | 54 ++++------------------------------ extra/pango/fonts/fonts.factor | 40 +++++++++++++++++++++++++ extra/pango/pango.factor | 54 ++++++++++++++++++++++++++++++++++ 3 files changed, 99 insertions(+), 49 deletions(-) create mode 100644 extra/pango/fonts/fonts.factor create mode 100644 extra/pango/pango.factor diff --git a/extra/cairo/pango/pango.factor b/extra/cairo/pango/pango.factor index 789044f6e1..3f702769d8 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/cairo/pango/pango.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! pangocairo bindings, from pango/pangocairo.h - USING: cairo.ffi alien.c-types math -alien.syntax system combinators alien ; +alien.syntax system combinators alien +pango pango.fonts ; IN: cairo.pango << "pangocairo" { @@ -15,10 +15,6 @@ IN: cairo.pango LIBRARY: pangocairo -TYPEDEF: void* PangoCairoFont -TYPEDEF: void* PangoCairoFontMap -TYPEDEF: void* PangoFontMap - FUNCTION: PangoFontMap* pango_cairo_font_map_new ( ) ; @@ -92,49 +88,6 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ; FUNCTION: void pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Helpful functions from other parts of pango -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: PANGO_SCALE 1024 ; - -FUNCTION: void -pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; - -FUNCTION: char* -pango_layout_get_text ( PangoLayout* layout ) ; - -FUNCTION: void -pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ; - -TYPEDEF: void* PangoFontDescription - -FUNCTION: PangoFontDescription* -pango_font_description_from_string ( char* str ) ; - -FUNCTION: char* -pango_font_description_to_string ( PangoFontDescription* desc ) ; - -FUNCTION: char* -pango_font_description_to_filename ( PangoFontDescription* desc ) ; - -FUNCTION: void -pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ; - -FUNCTION: PangoFontDescription* -pango_layout_get_font_description ( PangoLayout* layout ) ; - -FUNCTION: void -pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; - -FUNCTION: void -pango_font_description_free ( PangoFontDescription* desc ) ; - -TYPEDEF: void* gpointer - -FUNCTION: void -g_object_unref ( gpointer object ) ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Higher level words and combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -173,3 +126,6 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; : layout-text ( str -- ) layout swap -1 pango_layout_set_text ; + +: families ( -- families ) + pango_cairo_font_map_get_default list-families ; diff --git a/extra/pango/fonts/fonts.factor b/extra/pango/fonts/fonts.factor new file mode 100644 index 0000000000..6076b6a254 --- /dev/null +++ b/extra/pango/fonts/fonts.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license +USING: pango alien.syntax alien.c-types +kernel ; +IN: pango.fonts + +LIBRARY: pango + +FUNCTION: void +pango_font_map_list_families ( PangoFontMap* fontmap, PangoFontFamily*** families, int* n_families ) ; + +FUNCTION: char* +pango_font_family_get_name ( PangoFontFamily* family ) ; + +FUNCTION: int +pango_font_family_is_monospace ( PangoFontFamily* family ) ; + +FUNCTION: void +pango_font_family_list_faces ( PangoFontFamily* family, PangoFontFace*** faces, int* n_faces ) ; + +FUNCTION: char* +pango_font_face_get_face_name ( PangoFontFace* face ) ; + +FUNCTION: void +pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ; + +: list-families ( PangoFontMap* -- PangoFontFamily*-seq ) + 0 0 [ pango_font_map_list_families ] 2keep + *int >r *void* r> c-void*-array> ; + +: list-faces ( PangoFontFamily* -- PangoFontFace*-seq ) + 0 0 [ pango_font_family_list_faces ] 2keep + *int >r *void* r> c-void*-array> ; + +: list-sizes ( PangoFontFace* -- ints ) + 0 0 [ pango_font_face_list_sizes ] 2keep + *int >r *void* r> c-int-array> ; + +: monospace? ( PangoFontFamily* -- ? ) + pango_font_family_is_monospace 1 = ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor new file mode 100644 index 0000000000..3836a43e3f --- /dev/null +++ b/extra/pango/pango.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license +USING: system +alien.c-types alien.syntax alien combinators ; +IN: pango + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Helpful functions from other parts of pango +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +<< "pango" { +! { [ os winnt? ] [ "libpango-1.dll" ] } +! { [ os macosx? ] [ "libpango.dylib" ] } + { [ os unix? ] [ "libpango-1.0.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: pango + +: PANGO_SCALE 1024 ; + +FUNCTION: void +pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; + +FUNCTION: char* +pango_layout_get_text ( PangoLayout* layout ) ; + +FUNCTION: void +pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ; + +FUNCTION: PangoFontDescription* +pango_font_description_from_string ( char* str ) ; + +FUNCTION: char* +pango_font_description_to_string ( PangoFontDescription* desc ) ; + +FUNCTION: char* +pango_font_description_to_filename ( PangoFontDescription* desc ) ; + +FUNCTION: void +pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ; + +FUNCTION: PangoFontDescription* +pango_layout_get_font_description ( PangoLayout* layout ) ; + +FUNCTION: void +pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; + +FUNCTION: void +pango_font_description_free ( PangoFontDescription* desc ) ; + +TYPEDEF: void* gpointer + +FUNCTION: void +g_object_unref ( gpointer object ) ; From 610c47eb183272b293c5069c9189277b399c5c7c Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 30 May 2008 10:42:06 -0700 Subject: [PATCH 08/11] Refactored cairo gadgets, basing them on the texture-gadget in opengl.gadgets --- extra/cairo/gadgets/gadgets.factor | 93 ++++-------------------- extra/cairo/pango/gadgets/gadgets.factor | 4 +- extra/cairo/pango/pango.factor | 6 +- extra/cairo/samples/samples.factor | 4 +- extra/opengl/gadgets/gadgets.factor | 72 ++++++++++++++++++ 5 files changed, 96 insertions(+), 83 deletions(-) create mode 100644 extra/opengl/gadgets/gadgets.factor 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>> ; From 1c8b5728754ab4b79aff7fafbf79ef37936ffdc1 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 31 May 2008 01:11:47 -0700 Subject: [PATCH 09/11] cairo.pango renamed to pango.cairo --- .../{cairo/pango/pango.factor => pango/cairo/cairo.factor} | 2 +- extra/{cairo/pango => pango/cairo}/gadgets/gadgets.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) rename extra/{cairo/pango/pango.factor => pango/cairo/cairo.factor} (99%) rename extra/{cairo/pango => pango/cairo}/gadgets/gadgets.factor (85%) diff --git a/extra/cairo/pango/pango.factor b/extra/pango/cairo/cairo.factor similarity index 99% rename from extra/cairo/pango/pango.factor rename to extra/pango/cairo/cairo.factor index bb9c473047..889052c385 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/pango/cairo/cairo.factor @@ -5,7 +5,7 @@ USING: cairo.ffi alien.c-types math alien.syntax system combinators alien arrays pango pango.fonts ; -IN: cairo.pango +IN: pango.cairo << "pangocairo" { ! { [ os winnt? ] [ "libpangocairo-1.dll" ] } diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor similarity index 85% rename from extra/cairo/pango/gadgets/gadgets.factor rename to extra/pango/cairo/gadgets/gadgets.factor index 44ebfc30a5..9e8a99515e 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: cairo.pango cairo cairo.ffi cairo.gadgets +USING: pango.cairo cairo cairo.ffi cairo.gadgets alien.c-types kernel math ; -IN: cairo.pango.gadgets +IN: pango.cairo.gadgets : (pango-gadget) ( setup show -- gadget ) [ drop layout-size ] @@ -23,7 +23,7 @@ threads io.backend io.encodings.utf8 io.files ; gadget. yield ] each [ - "resource:extra/cairo/pango/gadgets/gadgets.factor" + "resource:extra/pango/cairo/gadgets/gadgets.factor" normalize-path utf8 file-contents layout-text ] gadget. ; From 8c686c67f9ae3da30e0231ef4ec1e8e5117d3944 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 31 May 2008 13:41:54 -0700 Subject: [PATCH 10/11] pango.fonts: make sure to free arrays with g_free --- extra/pango/fonts/fonts.factor | 6 +++--- extra/pango/pango.factor | 5 +++++ 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/pango/fonts/fonts.factor b/extra/pango/fonts/fonts.factor index 6076b6a254..d07c71226a 100644 --- a/extra/pango/fonts/fonts.factor +++ b/extra/pango/fonts/fonts.factor @@ -26,15 +26,15 @@ pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ; : list-families ( PangoFontMap* -- PangoFontFamily*-seq ) 0 0 [ pango_font_map_list_families ] 2keep - *int >r *void* r> c-void*-array> ; + *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ; : list-faces ( PangoFontFamily* -- PangoFontFace*-seq ) 0 0 [ pango_font_family_list_faces ] 2keep - *int >r *void* r> c-void*-array> ; + *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ; : list-sizes ( PangoFontFace* -- ints ) 0 0 [ pango_font_face_list_sizes ] 2keep - *int >r *void* r> c-int-array> ; + *int swap *void* [ swap c-int-array> ] [ g_free ] bi ; : monospace? ( PangoFontFamily* -- ? ) pango_font_family_is_monospace 1 = ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index 3836a43e3f..3549d9abb4 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -48,7 +48,12 @@ pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; FUNCTION: void pango_font_description_free ( PangoFontDescription* desc ) ; +! glib functions + TYPEDEF: void* gpointer FUNCTION: void g_object_unref ( gpointer object ) ; + +FUNCTION: void +g_free ( gpointer mem ) ; From 3ab71b00a99f391d9f036585eecc11b039f2d99d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 23:20:24 -0500 Subject: [PATCH 11/11] URLs library, abstracted out from http.server --- extra/urls/authors.txt | 1 + extra/urls/summary.txt | 1 + extra/urls/tags.txt | 2 + extra/urls/urls-tests.factor | 162 +++++++++++++++++++++++++++++++++++ extra/urls/urls.factor | 143 +++++++++++++++++++++++++++++++ 5 files changed, 309 insertions(+) create mode 100644 extra/urls/authors.txt create mode 100644 extra/urls/summary.txt create mode 100644 extra/urls/tags.txt create mode 100644 extra/urls/urls-tests.factor create mode 100644 extra/urls/urls.factor diff --git a/extra/urls/authors.txt b/extra/urls/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/urls/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/urls/summary.txt b/extra/urls/summary.txt new file mode 100644 index 0000000000..caeda3d21a --- /dev/null +++ b/extra/urls/summary.txt @@ -0,0 +1 @@ +Tools for working with URLs (uniform resource locators) diff --git a/extra/urls/tags.txt b/extra/urls/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/urls/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor new file mode 100644 index 0000000000..dd319a1e65 --- /dev/null +++ b/extra/urls/urls-tests.factor @@ -0,0 +1,162 @@ +IN: urls.tests +USING: urls tools.test tuple-syntax arrays kernel assocs ; + +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test +[ f ] [ "%XX%XX%XX" url-decode ] unit-test +[ f ] [ "%XX%XX%X" url-decode ] unit-test + +[ "hello world" ] [ "hello+world" url-decode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ " ! " ] [ "%20%21%20" url-decode ] unit-test +[ "hello world" ] [ "hello world%" url-decode ] unit-test +[ "hello world" ] [ "hello world%x" url-decode ] unit-test +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "%20%21%20" ] [ " ! " url-encode ] unit-test + +[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test + +[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test + +[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test + +[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test + +: urls + { + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com:1234/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/another/fine/path" + anchor: "foo" + } + "http://www.apple.com:1234/another/fine/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + anchor: "foo" + } + "/a/relative/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + } + "/a/relative/path" + } + { + TUPLE{ url + path: "a/relative/path" + } + "a/relative/path" + } + } ; + +urls [ + [ 1array ] [ [ string>url ] curry ] bi* unit-test +] assoc-each + +urls [ + swap [ 1array ] [ [ url>string ] curry ] bi* unit-test +] assoc-each + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } +] [ + TUPLE{ url + path: "/a/path" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + + derive-url +] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor new file mode 100644 index 0000000000..86f3de651d --- /dev/null +++ b/extra/urls/urls.factor @@ -0,0 +1,143 @@ +USING: kernel unicode.categories combinators sequences splitting +fry namespaces assocs arrays strings mirrors +io.encodings.string io.encodings.utf8 +math math.parser accessors namespaces.lib ; +IN: urls + +: url-quotable? ( ch -- ? ) + #! In a URL, can this character be used without + #! URL-encoding? + { + { [ dup letter? ] [ t ] } + { [ dup LETTER? ] [ t ] } + { [ dup digit? ] [ t ] } + { [ dup "/_-.:" member? ] [ t ] } + [ f ] + } cond nip ; foldable + +: push-utf8 ( ch -- ) + 1string utf8 encode + [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + +: url-encode ( str -- str ) + [ + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each + ] "" make ; + +: url-decode-hex ( index str -- ) + 2dup length 2 - >= [ + 2drop + ] [ + [ 1+ dup 2 + ] dip subseq hex> [ , ] when* + ] if ; + +: url-decode-% ( index str -- index str ) + 2dup url-decode-hex [ 3 + ] dip ; + +: url-decode-+-or-other ( index str ch -- index str ) + dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ; + +: url-decode-iter ( index str -- ) + 2dup length >= [ + 2drop + ] [ + 2dup nth dup CHAR: % = [ + drop url-decode-% + ] [ + url-decode-+-or-other + ] if url-decode-iter + ] if ; + +: url-decode ( str -- str ) + [ 0 swap url-decode-iter ] "" make utf8 decode ; + +: add-query-param ( value key assoc -- ) + [ + at [ + { + { [ dup string? ] [ swap 2array ] } + { [ dup array? ] [ swap suffix ] } + { [ dup not ] [ drop ] } + } cond + ] when* + ] 2keep set-at ; + +: query>assoc ( query -- assoc ) + dup [ + "&" split H{ } clone [ + [ + [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip + add-query-param + ] curry each + ] keep + ] when ; + +: assoc>query ( hash -- str ) + [ + { + { [ dup number? ] [ number>string 1array ] } + { [ dup string? ] [ 1array ] } + { [ dup sequence? ] [ ] } + } cond + ] assoc-map + [ + [ + [ url-encode ] dip + [ url-encode "=" swap 3append , ] with each + ] assoc-each + ] { } make "&" join ; + +TUPLE: url protocol host port path query anchor ; + +: parse-host-part ( protocol rest -- string' ) + [ "protocol" set ] [ + "//" ?head [ "Invalid URL" throw ] unless + "/" split1 [ + ":" split1 + [ url-decode "host" set ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when "port" set + ] bi* + ] [ "/" prepend ] bi* + ] bi* ; + +: string>url ( string -- url ) + [ + ":" split1 [ parse-host-part ] when* + "#" split1 [ + "?" split1 [ query>assoc "query" set ] when* + url-decode "path" set + ] [ + url-decode "anchor" set + ] bi* + ] url make-object ; + +: unparse-host-part ( protocol -- ) + % + "://" % + "host" get url-encode % + "port" get [ ":" % # ] when* + "path" get "/" head? [ "Invalid URL" throw ] unless ; + +: url>string ( url -- string ) + [ + [ + "protocol" get [ unparse-host-part ] when* + "path" get url-encode % + "query" get [ "?" % assoc>query % ] when* + "anchor" get [ "#" % url-encode % ] when* + ] bind + ] "" make ; + +: fix-relative-path ( url base -- url base ) + over path>> '[ + "/" ?tail drop "/" , 3append + ] change-path + [ f >>path ] dip ; inline + +: derive-url ( url base -- url' ) + clone + over path>> "/" head? [ fix-relative-path ] unless + [ swap [ nip ] assoc-filter update ] keep ;