Merge branch 'master' of factorcode.org:/git/factor
Eduardo Cavazos
commit
e8be61ece5
|
|
@ -1,73 +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 ;
|
||||
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? bytes ;
|
||||
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> ;
|
||||
|
||||
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 [
|
||||
0 0 glRasterPos2i
|
||||
1.0 -1.0 glPixelZoom
|
||||
[ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
|
||||
[ cairo>bytes ] tri glDrawPixels
|
||||
] with-translation ;
|
||||
|
||||
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> >>bytes ;
|
||||
|
||||
: <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,20 +0,0 @@
|
|||
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 ;
|
||||
|
||||
: <pango-gadget> ( quot -- gadget )
|
||||
[ cr layout pango_cairo_show_layout ] (pango-gadget) ;
|
||||
|
||||
USING: prettyprint sequences ui.gadgets.panes ;
|
||||
: hello-pango ( -- )
|
||||
50 [ 6 + ] map [
|
||||
"Sans Bold " swap unparse append
|
||||
[ layout-font "Hello, Pango!" layout-text ] curry
|
||||
<pango-gadget> gadget.
|
||||
] each ;
|
||||
|
||||
MAIN: hello-pango
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ;
|
|||
TUPLE: simple-statement < statement ;
|
||||
TUPLE: prepared-statement < statement ;
|
||||
|
||||
SINGLETON: throwable
|
||||
SINGLETON: nonthrowable
|
||||
|
||||
: make-throwable ( obj -- obj' )
|
||||
dup sequence? [
|
||||
[ make-throwable ] map
|
||||
] [
|
||||
throwable >>type
|
||||
] if ;
|
||||
|
||||
: make-nonthrowable ( obj -- obj' )
|
||||
dup sequence? [
|
||||
[ make-nonthrowable ] map
|
||||
] [
|
||||
nonthrowable >>type
|
||||
] if ;
|
||||
|
||||
TUPLE: result-set sql in-params out-params handle n max ;
|
||||
|
||||
: construct-statement ( sql in out class -- statement )
|
||||
new
|
||||
swap >>out-params
|
||||
swap >>in-params
|
||||
swap >>sql
|
||||
throwable >>type ;
|
||||
swap >>sql ;
|
||||
|
||||
HOOK: <simple-statement> db ( str in out -- statement )
|
||||
HOOK: <prepared-statement> db ( str in out -- statement )
|
||||
|
|
@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? )
|
|||
|
||||
GENERIC: execute-statement* ( statement type -- )
|
||||
|
||||
M: throwable execute-statement* ( statement type -- )
|
||||
M: object execute-statement* ( statement type -- )
|
||||
drop query-results dispose ;
|
||||
|
||||
M: nonthrowable execute-statement* ( statement type -- )
|
||||
drop [ query-results dispose ] [ 2drop ] recover ;
|
||||
|
||||
: execute-statement ( statement -- )
|
||||
dup sequence? [
|
||||
[ execute-statement ] each
|
||||
|
|
|
|||
|
|
@ -8,9 +8,8 @@ IN: db.queries
|
|||
GENERIC: where ( specs obj -- )
|
||||
|
||||
: maybe-make-retryable ( statement -- statement )
|
||||
dup in-params>> [ generator-bind? ] contains? [
|
||||
make-retryable
|
||||
] when ;
|
||||
dup in-params>> [ generator-bind? ] contains?
|
||||
[ make-retryable ] when ;
|
||||
|
||||
: query-make ( class quot -- )
|
||||
>r sql-props r>
|
||||
|
|
|
|||
|
|
@ -199,10 +199,9 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
: test-sqlite ( quot -- )
|
||||
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
|
||||
|
||||
! : test-postgresql ( quot -- )
|
||||
! >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
|
||||
: test-postgresql ( quot -- )
|
||||
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
|
||||
|
||||
: test-postgresql drop ;
|
||||
: test-repeated-insert
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
[ ] [ person1 get insert-tuple ] unit-test
|
||||
|
|
|
|||
|
|
@ -112,8 +112,8 @@ M: retryable execute-statement* ( statement type -- )
|
|||
|
||||
: recreate-table ( class -- )
|
||||
[
|
||||
drop-sql-statement make-nonthrowable
|
||||
[ execute-statement ] with-disposals
|
||||
[ drop-sql-statement [ execute-statement ] with-disposals
|
||||
] curry ignore-errors
|
||||
] [ create-table ] bi ;
|
||||
|
||||
: ensure-table ( class -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,43 @@
|
|||
USING: arrays json.reader kernel multiline strings tools.test ;
|
||||
IN: json.reader.tests
|
||||
|
||||
{ f } [ "false" json> ] unit-test
|
||||
{ t } [ "true" json> ] unit-test
|
||||
{ json-null } [ "null" json> ] unit-test
|
||||
{ 0 } [ "0" json> ] unit-test
|
||||
{ 102 } [ "102" json> ] unit-test
|
||||
{ -102 } [ "-102" json> ] unit-test
|
||||
{ 102 } [ "+102" json> ] unit-test
|
||||
{ 102.0 } [ "102.0" json> ] unit-test
|
||||
{ 102.5 } [ "102.5" json> ] unit-test
|
||||
{ 102.5 } [ "102.50" json> ] unit-test
|
||||
{ -10250 } [ "-102.5e2" json> ] unit-test
|
||||
{ -10250 } [ "-102.5E+2" json> ] unit-test
|
||||
{ 10.25 } [ "1025e-2" json> ] unit-test
|
||||
{ 0.125 } [ "0.125" json> ] unit-test
|
||||
{ -0.125 } [ "-0.125" json> ] unit-test
|
||||
|
||||
{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
|
||||
{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
|
||||
{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
|
||||
{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
|
||||
|
||||
{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
|
||||
{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
|
||||
{ H{
|
||||
{ "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
|
||||
{ "prime" { 2 3 5 7 11 13 } }
|
||||
} } [ <" {
|
||||
"fib": [1, 1, 2, 3, 5, 8,
|
||||
{ "etc":"etc" } ],
|
||||
"prime":
|
||||
[ 2,3, 5,7,
|
||||
11,
|
||||
13
|
||||
] }
|
||||
"> json> ] unit-test
|
||||
|
||||
{ 0 } [ " 0" json> ] unit-test
|
||||
{ 0 } [ "0 " json> ] unit-test
|
||||
{ 0 } [ " 0 " json> ] unit-test
|
||||
|
||||
|
|
@ -7,6 +7,8 @@ IN: json.reader
|
|||
|
||||
! Grammar for JSON from RFC 4627
|
||||
|
||||
SYMBOL: json-null
|
||||
|
||||
: [<&>] ( quot -- quot )
|
||||
{ } make unclip [ <&> ] reduce ;
|
||||
|
||||
|
|
@ -17,8 +19,7 @@ LAZY: 'ws' ( -- parser )
|
|||
" " token
|
||||
"\n" token <|>
|
||||
"\r" token <|>
|
||||
"\t" token <|>
|
||||
"" token <|> ;
|
||||
"\t" token <|> <*> ;
|
||||
|
||||
LAZY: spaced ( parser -- parser )
|
||||
'ws' swap &> 'ws' <& ;
|
||||
|
|
@ -42,24 +43,39 @@ LAZY: 'value-separator' ( -- parser )
|
|||
"," token spaced ;
|
||||
|
||||
LAZY: 'false' ( -- parser )
|
||||
"false" token ;
|
||||
"false" token [ drop f ] <@ ;
|
||||
|
||||
LAZY: 'null' ( -- parser )
|
||||
"null" token ;
|
||||
"null" token [ drop json-null ] <@ ;
|
||||
|
||||
LAZY: 'true' ( -- parser )
|
||||
"true" token ;
|
||||
"true" token [ drop t ] <@ ;
|
||||
|
||||
LAZY: 'quot' ( -- parser )
|
||||
"\"" token ;
|
||||
|
||||
LAZY: 'hex-digit' ( -- parser )
|
||||
[ digit> ] satisfy [ digit> ] <@ ;
|
||||
|
||||
: hex-digits>ch ( digits -- ch )
|
||||
0 [ swap 16 * + ] reduce ;
|
||||
|
||||
LAZY: 'string-char' ( -- parser )
|
||||
[ quotable? ] satisfy
|
||||
"\\b" token [ drop 8 ] <@ <|>
|
||||
"\\t" token [ drop CHAR: \t ] <@ <|>
|
||||
"\\n" token [ drop CHAR: \n ] <@ <|>
|
||||
"\\f" token [ drop 12 ] <@ <|>
|
||||
"\\r" token [ drop CHAR: \r ] <@ <|>
|
||||
"\\\"" token [ drop CHAR: " ] <@ <|>
|
||||
"\\/" token [ drop CHAR: / ] <@ <|>
|
||||
"\\\\" token [ drop CHAR: \\ ] <@ <|>
|
||||
"\\u" token 'hex-digit' 4 exactly-n &>
|
||||
[ hex-digits>ch ] <@ <|> ;
|
||||
|
||||
LAZY: 'string' ( -- parser )
|
||||
'quot'
|
||||
[
|
||||
[ quotable? ] keep
|
||||
[ CHAR: \\ = or ] keep
|
||||
CHAR: " = not and
|
||||
] satisfy <*> &>
|
||||
'string-char' <*> &>
|
||||
'quot' <& [ >string ] <@ ;
|
||||
|
||||
DEFER: 'value'
|
||||
|
|
@ -86,6 +102,9 @@ LAZY: 'minus' ( -- parser )
|
|||
LAZY: 'plus' ( -- parser )
|
||||
"+" token ;
|
||||
|
||||
LAZY: 'sign' ( -- parser )
|
||||
'minus' 'plus' <|> ;
|
||||
|
||||
LAZY: 'zero' ( -- parser )
|
||||
"0" token [ drop 0 ] <@ ;
|
||||
|
||||
|
|
@ -116,11 +135,11 @@ LAZY: 'e' ( -- parser )
|
|||
: sign-number ( pair -- number )
|
||||
#! Pair is { minus? num }
|
||||
#! Convert the json number value to a factor number
|
||||
dup second swap first [ -1 * ] when ;
|
||||
dup second swap first [ first "-" = [ -1 * ] when ] when* ;
|
||||
|
||||
LAZY: 'exp' ( -- parser )
|
||||
'e'
|
||||
'minus' 'plus' <|> <?> &>
|
||||
'sign' <?> &>
|
||||
'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
|
||||
|
||||
: sequence>frac ( seq -- num )
|
||||
|
|
@ -136,7 +155,7 @@ LAZY: 'frac' ( -- parser )
|
|||
dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
|
||||
|
||||
LAZY: 'number' ( -- parser )
|
||||
'minus' <?>
|
||||
'sign' <?>
|
||||
[ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
|
||||
'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
|
||||
|
||||
|
|
@ -149,7 +168,7 @@ LAZY: 'value' ( -- parser )
|
|||
'object' ,
|
||||
'array' ,
|
||||
'number' ,
|
||||
] [<|>] ;
|
||||
] [<|>] spaced ;
|
||||
|
||||
: json> ( string -- object )
|
||||
#! Parse a json formatted string to a factor object
|
||||
|
|
|
|||
|
|
@ -58,3 +58,6 @@ M: memoized reset-word
|
|||
|
||||
: reset-memoized ( word -- )
|
||||
"memoize" word-prop clear-assoc ;
|
||||
|
||||
: invalidate-memoized ! ( inputs... word )
|
||||
[ #in packer call ] [ "memoize" word-prop delete-at ] bi ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! USING: kernel quotations namespaces sequences assocs.lib ;
|
||||
|
||||
USING: kernel namespaces namespaces.private quotations sequences
|
||||
assocs.lib math.parser math sequences.lib locals ;
|
||||
assocs.lib math.parser math sequences.lib locals mirrors ;
|
||||
|
||||
IN: namespaces.lib
|
||||
|
||||
|
|
@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- )
|
|||
] with-scope
|
||||
]
|
||||
] ;
|
||||
|
||||
: make-object ( quot class -- object )
|
||||
new [ <mirror> swap bind ] keep ; inline
|
||||
|
||||
: with-object ( object quot -- )
|
||||
[ <mirror> ] dip bind ; inline
|
||||
|
|
|
|||
|
|
@ -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>> ;
|
||||
|
|
@ -2,10 +2,10 @@
|
|||
! 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 ;
|
||||
IN: cairo.pango
|
||||
alien.syntax system combinators alien
|
||||
arrays pango pango.fonts ;
|
||||
IN: pango.cairo
|
||||
|
||||
<< "pangocairo" {
|
||||
! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
|
||||
|
|
@ -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
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -162,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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
! Copyright (C) 2008 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: pango.cairo cairo cairo.ffi cairo.gadgets
|
||||
alien.c-types kernel math ;
|
||||
IN: pango.cairo.gadgets
|
||||
|
||||
: (pango-gadget) ( setup show -- gadget )
|
||||
[ drop layout-size ]
|
||||
[ compose [ with-pango ] curry <cairo-gadget> ] 2bi ;
|
||||
|
||||
: <pango-gadget> ( quot -- gadget )
|
||||
[ cr layout pango_cairo_show_layout ] (pango-gadget) ;
|
||||
|
||||
USING: prettyprint sequences ui.gadgets.panes
|
||||
threads io.backend io.encodings.utf8 io.files ;
|
||||
: hello-pango ( -- )
|
||||
50 [ 6 + ] map [
|
||||
"Sans " swap unparse append
|
||||
[
|
||||
cr 0 1 0.2 0.6 cairo_set_source_rgba
|
||||
layout-font "今日は、 Pango!" layout-text
|
||||
] curry
|
||||
<pango-gadget> gadget. yield
|
||||
] each
|
||||
[
|
||||
"resource:extra/pango/cairo/gadgets/gadgets.factor"
|
||||
normalize-path utf8 file-contents layout-text
|
||||
] <pango-gadget> gadget. ;
|
||||
|
||||
MAIN: hello-pango
|
||||
|
|
@ -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 <int> 0 <int> [ pango_font_map_list_families ] 2keep
|
||||
*int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
|
||||
|
||||
: list-faces ( PangoFontFamily* -- PangoFontFace*-seq )
|
||||
0 <int> 0 <int> [ pango_font_family_list_faces ] 2keep
|
||||
*int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
|
||||
|
||||
: list-sizes ( PangoFontFace* -- ints )
|
||||
0 <int> 0 <int> [ pango_font_face_list_sizes ] 2keep
|
||||
*int swap *void* [ swap c-int-array> ] [ g_free ] bi ;
|
||||
|
||||
: monospace? ( PangoFontFamily* -- ? )
|
||||
pango_font_family_is_monospace 1 = ;
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
! 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 ) ;
|
||||
|
||||
! glib functions
|
||||
|
||||
TYPEDEF: void* gpointer
|
||||
|
||||
FUNCTION: void
|
||||
g_object_unref ( gpointer object ) ;
|
||||
|
||||
FUNCTION: void
|
||||
g_free ( gpointer mem ) ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tools for working with URLs (uniform resource locators)
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
web
|
||||
network
|
||||
|
|
@ -0,0 +1,194 @@
|
|||
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
|
||||
|
||||
[ "b" ] [ "a" "b" url-append-path ] unit-test
|
||||
|
||||
[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test
|
||||
|
||||
[ "a/b" ] [ "a/" "b" url-append-path ] unit-test
|
||||
|
||||
[ "/b" ] [ "a" "/b" url-append-path ] unit-test
|
||||
|
||||
[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test
|
||||
|
||||
[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
|
||||
|
||||
[
|
||||
TUPLE{ url
|
||||
protocol: "http"
|
||||
host: "www.apple.com"
|
||||
port: 1234
|
||||
path: "/a/path"
|
||||
}
|
||||
] [
|
||||
TUPLE{ url
|
||||
protocol: "http"
|
||||
host: "www.apple.com"
|
||||
port: 1234
|
||||
path: "/foo"
|
||||
}
|
||||
|
||||
TUPLE{ url
|
||||
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
|
||||
protocol: "http"
|
||||
host: "www.apple.com"
|
||||
port: 1234
|
||||
path: "/a/path/"
|
||||
}
|
||||
|
||||
TUPLE{ url
|
||||
path: "relative/path"
|
||||
query: H{ { "a" "b" } }
|
||||
anchor: "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
|
||||
protocol: "http"
|
||||
host: "www.apple.com"
|
||||
port: 1234
|
||||
path: "/a/path/"
|
||||
}
|
||||
|
||||
TUPLE{ url
|
||||
path: "relative/path"
|
||||
query: H{ { "a" "b" } }
|
||||
anchor: "foo"
|
||||
}
|
||||
|
||||
derive-url
|
||||
] unit-test
|
||||
|
||||
[
|
||||
TUPLE{ url
|
||||
protocol: "http"
|
||||
host: "www.apple.com"
|
||||
path: "/xxx/baz"
|
||||
}
|
||||
] [
|
||||
TUPLE{ url
|
||||
protocol: "http"
|
||||
host: "www.apple.com"
|
||||
path: "/xxx/bar"
|
||||
}
|
||||
|
||||
TUPLE{ url
|
||||
path: "baz"
|
||||
}
|
||||
|
||||
derive-url
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,160 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
|
||||
: query-param ( request key -- value )
|
||||
swap query>> at ;
|
||||
|
||||
: set-query-param ( request value key -- request )
|
||||
pick query>> set-at ;
|
||||
|
||||
: parse-host ( string -- host port )
|
||||
":" split1 [ url-decode ] [
|
||||
dup [
|
||||
string>number
|
||||
dup [ "Invalid port" throw ] unless
|
||||
] when
|
||||
] bi* ;
|
||||
|
||||
: parse-host-part ( protocol rest -- string' )
|
||||
[ "protocol" set ] [
|
||||
"//" ?head [ "Invalid URL" throw ] unless
|
||||
"/" split1 [
|
||||
parse-host [ "host" set ] [ "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 )
|
||||
[
|
||||
<mirror> [
|
||||
"protocol" get [ unparse-host-part ] when*
|
||||
"path" get url-encode %
|
||||
"query" get [ "?" % assoc>query % ] when*
|
||||
"anchor" get [ "#" % url-encode % ] when*
|
||||
] bind
|
||||
] "" make ;
|
||||
|
||||
: url-append-path ( path1 path2 -- path )
|
||||
{
|
||||
{ [ dup "/" head? ] [ nip ] }
|
||||
{ [ dup empty? ] [ drop ] }
|
||||
{ [ over "/" tail? ] [ append ] }
|
||||
{ [ "/" pick start not ] [ nip ] }
|
||||
[ [ "/" last-split1 drop "/" ] dip 3append ]
|
||||
} cond ;
|
||||
|
||||
: derive-url ( base url -- url' )
|
||||
[ clone dup ] dip
|
||||
2dup [ path>> ] bi@ url-append-path
|
||||
[ [ <mirror> ] bi@ [ nip ] assoc-filter update ] dip
|
||||
>>path ;
|
||||
|
||||
: relative-url ( url -- url' )
|
||||
clone f >>protocol f >>host f >>port ;
|
||||
Loading…
Reference in New Issue