From 1682a5512ac7027f49c18ec9d536eeeba03101d4 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 22:26:44 -0600 Subject: [PATCH 01/21] Minor docs fix and cleanup in http.server.static --- basis/http/server/static/static-docs.factor | 2 +- basis/http/server/static/static.factor | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor index fbe20b5fcd..bbad56a6f1 100644 --- a/basis/http/server/static/static-docs.factor +++ b/basis/http/server/static/static-docs.factor @@ -38,7 +38,7 @@ $nl "If all you want to do is serve files from a directory, the following phrase does the trick:" { $code "USING: namespaces http.server http.server.static ;" - "/var/www/mysite.com/ main-responder set" + "\"/var/www/mysite.com/\" main-responder set" "8080 httpd" } { $subsection "http.server.static.extend" } ; diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 53d3d4f917..5d5ad7d2b8 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ; [ file-responder get hook>> call ] [ 2drop <304> ] if ; : serving-path ( filename -- filename ) - file-responder get root>> trim-tail-separators - "/" - rot "" or trim-head-separators 3append ; + [ file-responder get root>> trim-tail-separators "/" ] dip + "" or trim-head-separators 3append ; : serve-file ( filename -- response ) dup mime-type From f3e8bc12472d409c5c1d27d5c817bd8a664c5ba7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:55:38 -0600 Subject: [PATCH 02/21] make hexdump work for byte-vectors --- basis/tools/hexdump/hexdump.factor | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index b646760889..335e32e0a3 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays io io.streams.string kernel math math.parser -namespaces sequences splitting grouping strings ascii byte-arrays ; +namespaces sequences splitting grouping strings ascii +byte-arrays byte-vectors ; IN: tools.hexdump hex-digits write ] [ >ascii write ] bi nl ; +: hexdump-bytes + [ length write-header ] + [ 16 [ write-hex-line ] each-index ] bi ; + PRIVATE> GENERIC: hexdump. ( byte-array -- ) -M: byte-array hexdump. - [ length write-header ] - [ 16 [ write-hex-line ] each-index ] bi ; +M: byte-array hexdump. hexdump-bytes ; + +M: byte-vector hexdump. hexdump-bytes ; : hexdump ( byte-array -- str ) [ hexdump. ] with-string-writer ; From cd82735dea927dfb4dcc18e7d3416ec0ea57c210 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:55:56 -0600 Subject: [PATCH 03/21] remove zlib --- basis/zlib/authors.txt | 1 - basis/zlib/ffi/authors.txt | 1 - basis/zlib/ffi/ffi.factor | 30 ---------------------- basis/zlib/zlib-tests.factor | 9 ------- basis/zlib/zlib.factor | 48 ------------------------------------ 5 files changed, 89 deletions(-) delete mode 100755 basis/zlib/authors.txt delete mode 100755 basis/zlib/ffi/authors.txt delete mode 100755 basis/zlib/ffi/ffi.factor delete mode 100755 basis/zlib/zlib-tests.factor delete mode 100755 basis/zlib/zlib.factor diff --git a/basis/zlib/authors.txt b/basis/zlib/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/zlib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/zlib/ffi/authors.txt b/basis/zlib/ffi/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/zlib/ffi/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor deleted file mode 100755 index bda2809f56..0000000000 --- a/basis/zlib/ffi/ffi.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax combinators system ; -IN: zlib.ffi - -<< "zlib" { - { [ os winnt? ] [ "zlib1.dll" ] } - { [ os macosx? ] [ "libz.dylib" ] } - { [ os unix? ] [ "libz.so" ] } -} cond "cdecl" add-library >> - -LIBRARY: zlib - -CONSTANT: Z_OK 0 -CONSTANT: Z_STREAM_END 1 -CONSTANT: Z_NEED_DICT 2 -CONSTANT: Z_ERRNO -1 -CONSTANT: Z_STREAM_ERROR -2 -CONSTANT: Z_DATA_ERROR -3 -CONSTANT: Z_MEM_ERROR -4 -CONSTANT: Z_BUF_ERROR -5 -CONSTANT: Z_VERSION_ERROR -6 - -TYPEDEF: void Bytef -TYPEDEF: ulong uLongf -TYPEDEF: ulong uLong - -FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; -FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ; -FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor deleted file mode 100755 index 0ac77277dc..0000000000 --- a/basis/zlib/zlib-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test zlib classes ; -IN: zlib.tests - -: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; - -[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test -[ t ] [ compress-me compress compressed instance? ] unit-test diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor deleted file mode 100755 index b40d9c2a98..0000000000 --- a/basis/zlib/zlib.factor +++ /dev/null @@ -1,48 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax byte-arrays combinators -kernel math math.functions sequences system accessors -libc ; -QUALIFIED: zlib.ffi -IN: zlib - -TUPLE: compressed data length ; - -: ( data length -- compressed ) - compressed new - swap >>length - swap >>data ; - -ERROR: zlib-failed n string ; - -: zlib-error-message ( n -- * ) - dup zlib.ffi:Z_ERRNO = [ - drop errno "native libc error" - ] [ - dup { - "no error" "libc_error" - "stream error" "data error" - "memory error" "buffer error" "zlib version error" - } ?nth - ] if zlib-failed ; - -: zlib-error ( n -- ) - dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; - -: compressed-size ( byte-array -- n ) - length 1001/1000 * ceiling 12 + ; - -: compress ( byte-array -- compressed ) - [ - [ compressed-size dup length ] keep [ - dup length zlib.ffi:compress zlib-error - ] 3keep drop *ulong head - ] keep length ; - -: uncompress ( compressed -- byte-array ) - [ - length>> [ ] keep 2dup - ] [ - data>> dup length - zlib.ffi:uncompress zlib-error - ] bi *ulong head ; From 753cfcfd05ccb33af75cea89424b64f82fc54253 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:56:22 -0600 Subject: [PATCH 04/21] support .tif, start 96 bpp --- basis/images/images.factor | 14 ++++++++++++-- basis/images/loader/loader.factor | 1 + basis/images/tiff/tiff.factor | 7 ++++--- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 46c0936644..e8f5530706 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors grouping sequences combinators ; +USING: kernel accessors grouping sequences combinators +math specialized-arrays.direct.uint byte-arrays ; IN: images -SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR +32R32G32B ; TUPLE: image dim component-order byte-order bitmap ; @@ -15,6 +17,14 @@ GENERIC: load-image* ( path tuple -- image ) dup component-order>> { { RGBA [ ] } + { 32R32G32B [ + [ + ! >byte-array + ! dup length 4 /i [ 32 2^ /i ] map + ! >byte-array + ! 4 le> [ 32 2^ /i ] map concat + ] change-bitmap + ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 9e3f901269..6f2ae47c61 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -10,6 +10,7 @@ ERROR: unknown-image-extension extension ; : image-class ( path -- class ) file-extension >lower { { "bmp" [ bitmap-image ] } + { "tif" [ tiff-image ] } { "tiff" [ tiff-image ] } [ unknown-image-extension ] } case ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 0b749d0ade..baac3a2dfb 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -276,9 +276,10 @@ ERROR: unhandled-compression compression ; ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) - bits-per-sample find-tag sum { - { 32 [ RGBA ] } - { 24 [ RGB ] } + bits-per-sample find-tag { + { { 32 32 32 } [ 32R32G32B ] } + { { 8 8 8 8 } [ RGBA ] } + { { 8 8 8 } [ RGB ] } [ unknown-component-order ] } case ; From 3fb733b53cb07188827246afbe23c78177c2a1cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 10:16:58 -0600 Subject: [PATCH 05/21] add 48bpp mode to tiff --- basis/images/images.factor | 10 +--------- basis/images/tiff/tiff.factor | 1 + 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index e8f5530706..41d96a673b 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -5,7 +5,7 @@ math specialized-arrays.direct.uint byte-arrays ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR -32R32G32B ; +16R16G16B 32R32G32B ; TUPLE: image dim component-order byte-order bitmap ; @@ -17,14 +17,6 @@ GENERIC: load-image* ( path tuple -- image ) dup component-order>> { { RGBA [ ] } - { 32R32G32B [ - [ - ! >byte-array - ! dup length 4 /i [ 32 2^ /i ] map - ! >byte-array - ! 4 le> [ 32 2^ /i ] map concat - ] change-bitmap - ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index baac3a2dfb..28eee7d98a 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -278,6 +278,7 @@ ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { { { 32 32 32 } [ 32R32G32B ] } + { { 16 16 16 } [ 16R16G16B ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } [ unknown-component-order ] From cdc5aa60b0d304c10af3fb2f41c05de7464ef4eb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 10:48:11 -0600 Subject: [PATCH 06/21] add a stack effect to tuple article --- core/classes/tuple/tuple-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 561d0962ff..0469f3564a 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples" } "An example of using a changer:" { $code - ": positions" + ": positions ( -- seq )" " {" " \"junior programmer\"" " \"senior programmer\"" From fb844f2ac03aa0a03ff8448c7124d7f5bc7ef163 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 13 Feb 2009 11:54:07 -0600 Subject: [PATCH 07/21] twitter timelines --- extra/twitter/twitter.factor | 85 +++++++++++++++++++++++++++++++++--- 1 file changed, 80 insertions(+), 5 deletions(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index 707bcceda6..f9806a7c4f 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -1,9 +1,67 @@ -USING: accessors assocs hashtables http http.client json.reader -kernel namespaces urls.secure urls.encoding ; +USING: accessors assocs combinators hashtables http +http.client json.reader kernel macros namespaces sequences +urls.secure urls.encoding ; IN: twitter SYMBOLS: twitter-username twitter-password ; +TUPLE: twitter-status + created-at + id + text + source + truncated? + in-reply-to-status-id + in-reply-to-user-id + favorited? + user ; +TUPLE: twitter-user + id + name + screen-name + description + location + profile-image-url + url + protected? + followers-count ; + +MACRO: keys-boa ( keys class -- ) + [ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ; + +: ( assoc -- user ) + { + "id" + "name" + "screen_name" + "description" + "location" + "profile_image_url" + "url" + "protected" + "followers_count" + } twitter-user keys-boa ; + +: ( assoc -- tweet ) + clone "user" over [ ] change-at + { + "created_at" + "id" + "text" + "source" + "truncated" + "in_reply_to_status_id" + "in_reply_to_user_id" + "favorited" + "user" + } twitter-status keys-boa ; + +: json>twitter-statuses ( json-array -- tweets ) + json> [ ] map ; + +: json>twitter-status ( json-object -- tweet ) + json> ; + : set-twitter-credentials ( username password -- ) [ twitter-username set ] [ twitter-password set ] bi* ; @@ -13,10 +71,27 @@ SYMBOLS: twitter-username twitter-password ; : update-post-data ( update -- assoc ) "status" associate ; -: tweet* ( string -- result ) +: (tweet) ( string -- json ) update-post-data "https://twitter.com/statuses/update.json" set-request-twitter-auth - http-request nip json> ; + http-request nip ; -: tweet ( string -- ) tweet* drop ; +: tweet* ( string -- tweet ) + (tweet) json>twitter-status ; +: tweet ( string -- ) (tweet) drop ; + +: public-timeline ( -- tweets ) + "https://twitter.com/statuses/public_timeline.json" + set-request-twitter-auth + http-request nip json>twitter-statuses ; + +: friends-timeline ( -- tweets ) + "https://twitter.com/statuses/friends_timeline.json" + set-request-twitter-auth + http-request nip json>twitter-statuses ; + +: user-timeline ( username -- tweets ) + "https://twitter.com/statuses/user_timeline/" ".json" surround + set-request-twitter-auth + http-request nip json>twitter-statuses ; From 435a14f3b654193e16d35c20314189cfde4c7c1c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 11:57:45 -0600 Subject: [PATCH 08/21] add stack effect, oops --- basis/tools/hexdump/hexdump.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index 335e32e0a3..63b55729fb 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -27,7 +27,7 @@ IN: tools.hexdump : write-hex-line ( bytes lineno -- ) write-offset [ >hex-digits write ] [ >ascii write ] bi nl ; -: hexdump-bytes +: hexdump-bytes ( bytes -- ) [ length write-header ] [ 16 [ write-hex-line ] each-index ] bi ; From bd17f149290c3db90493ce1a45363db3461cc70c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 12:12:08 -0600 Subject: [PATCH 09/21] drawing 96bpp images works, add lots of previously unknown ifd fields --- basis/images/images.factor | 23 +++++++++++++++++------ basis/images/tiff/tiff.factor | 23 +++++++++++++++++------ 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 41d96a673b..e366dd2700 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -5,7 +5,7 @@ math specialized-arrays.direct.uint byte-arrays ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR -16R16G16B 32R32G32B ; +R16G16B16 R32G32B32 ; TUPLE: image dim component-order byte-order bitmap ; @@ -13,22 +13,32 @@ TUPLE: image dim component-order byte-order bitmap ; GENERIC: load-image* ( path tuple -- image ) +: add-dummy-alpha ( seq -- seq' ) + 3 + [ 255 suffix ] map concat ; + : normalize-component-order ( image -- image ) dup component-order>> { { RGBA [ ] } + { R32G32B32 [ + [ + dup length 4 / + [ bits>float 255.0 * >integer ] map + >byte-array add-dummy-alpha + ] change-bitmap + ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each ] change-bitmap ] } - { RGB [ - [ 3 [ 255 suffix ] map concat ] change-bitmap - ] } + { RGB [ [ add-dummy-alpha ] change-bitmap ] } { BGR [ [ - 3 dup [ [ 0 3 ] dip reverse-here ] each - [ 255 suffix ] map concat + 3 + [ [ [ 0 3 ] dip reverse-here ] each ] + [ add-dummy-alpha ] bi ] change-bitmap ] } } case @@ -39,5 +49,6 @@ GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; : normalize-image ( image -- image ) + [ >byte-array ] change-bitmap normalize-component-order normalize-scan-line-order ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 28eee7d98a..db5141521d 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -3,7 +3,7 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian constructors sequences arrays math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays -grouping images compression.lzw fry ; +grouping images compression.lzw fry strings ; IN: images.tiff TUPLE: tiff-image < image ; @@ -115,8 +115,9 @@ ERROR: bad-extra-samples n ; SINGLETONS: image-length image-width x-resolution y-resolution rows-per-strip strip-offsets strip-byte-counts bits-per-sample -samples-per-pixel new-subfile-type orientation -unhandled-ifd-entry ; +samples-per-pixel new-subfile-type orientation software +date-time photoshop exif-ifd sub-ifd inter-color-profile +xmp iptc unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -185,6 +186,7 @@ ERROR: unknown-ifd-type n ; { 10 [ 8 * ] } { 11 [ 4 * ] } { 12 [ 8 * ] } + { 13 [ 4 * ] } [ unknown-ifd-type ] } case ; @@ -200,6 +202,7 @@ ERROR: bad-small-ifd-type n ; { 8 [ 2 head endian> 16 >signed ] } { 9 [ endian> 32 >signed ] } { 11 [ endian> bits>float ] } + { 13 [ endian> 32 >signed ] } [ bad-small-ifd-type ] } case ; @@ -246,10 +249,18 @@ ERROR: bad-small-ifd-type n ; { 283 [ y-resolution ] } { 284 [ planar-configuration ] } { 296 [ lookup-resolution-unit resolution-unit ] } + { 305 [ >string software ] } + { 306 [ >string date-time ] } { 317 [ lookup-predictor predictor ] } + { 330 [ sub-ifd ] } { 338 [ lookup-extra-samples extra-samples ] } { 339 [ lookup-sample-format sample-format ] } - [ nip unhandled-ifd-entry ] + { 700 [ >string xmp ] } + { 34377 [ photoshop ] } + { 34665 [ exif-ifd ] } + { 33723 [ iptc ] } + { 34675 [ inter-color-profile ] } + [ nip unhandled-ifd-entry swap ] } case ; : process-ifd ( ifd -- ifd ) @@ -277,8 +288,8 @@ ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { - { { 32 32 32 } [ 32R32G32B ] } - { { 16 16 16 } [ 16R16G16B ] } + { { 32 32 32 } [ R32G32B32 ] } + { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } [ unknown-component-order ] From 1424380e5b1490d5df6975359dd24ef2da29134c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 13:04:14 -0600 Subject: [PATCH 10/21] x/y resolution should be a scalar --- basis/images/tiff/tiff.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index db5141521d..674188992a 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -245,8 +245,8 @@ ERROR: bad-small-ifd-type n ; { 277 [ samples-per-pixel ] } { 278 [ rows-per-strip ] } { 279 [ strip-byte-counts ] } - { 282 [ x-resolution ] } - { 283 [ y-resolution ] } + { 282 [ first x-resolution ] } + { 283 [ first y-resolution ] } { 284 [ planar-configuration ] } { 296 [ lookup-resolution-unit resolution-unit ] } { 305 [ >string software ] } From 53f6d394ea3d2e0c3bfe4408cb7c16f82f8002b3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 13 Feb 2009 13:07:48 -0600 Subject: [PATCH 11/21] let the world know you tweet from factor --- extra/twitter/twitter.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index f9806a7c4f..2172d7cf81 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -3,7 +3,9 @@ http.client json.reader kernel macros namespaces sequences urls.secure urls.encoding ; IN: twitter -SYMBOLS: twitter-username twitter-password ; +SYMBOLS: twitter-username twitter-password twitter-source ; + +twitter-source [ "factor" ] initialize TUPLE: twitter-status created-at @@ -69,7 +71,8 @@ MACRO: keys-boa ( keys class -- ) twitter-username twitter-password [ get ] bi@ set-basic-auth ; : update-post-data ( update -- assoc ) - "status" associate ; + "status" associate + [ twitter-source get "source" ] dip [ set-at ] keep ; : (tweet) ( string -- json ) update-post-data "https://twitter.com/statuses/update.json" From c6680eee60a3bbd432750ab4733f039c98ab9d73 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 13 Feb 2009 15:10:34 -0600 Subject: [PATCH 12/21] Making xml-undo words private; adding bytes>xml word --- basis/xml/syntax/syntax.factor | 4 ++++ basis/xml/tests/test.factor | 12 +++++++++--- basis/xml/xml-docs.factor | 9 +++++++-- basis/xml/xml.factor | 5 ++++- 4 files changed, 24 insertions(+), 6 deletions(-) diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 8e6bebfe6b..067bb9ec11 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -174,6 +174,8 @@ PRIVATE> : [XML "XML]" [ string>chunk ] parse-def ; parsing +enum ] ; \ interpolate-xml 1 [ undo-xml ] define-pop-inverse + +PRIVATE> diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index b1f6cf002f..0372132736 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -3,7 +3,7 @@ IN: xml.tests USING: kernel xml tools.test io namespaces make sequences xml.errors xml.entities.html parser strings xml.data io.files -xml.traversal continuations assocs +xml.traversal continuations assocs io.encodings.binary sequences.deep accessors io.streams.string ; ! This is insufficient @@ -12,8 +12,14 @@ sequences.deep accessors io.streams.string ; \ string>xml must-infer SYMBOL: xml-file -[ ] [ "resource:basis/xml/tests/test.xml" - [ file>xml ] with-html-entities xml-file set ] unit-test +[ ] [ + "resource:basis/xml/tests/test.xml" + [ file>xml ] with-html-entities xml-file set +] unit-test +[ t ] [ + "resource:basis/xml/tests/test.xml" binary file-contents + [ bytes>xml ] with-html-entities xml-file get = +] unit-test [ "1.0" ] [ xml-file get prolog>> version>> ] unit-test [ f ] [ xml-file get prolog>> standalone>> ] unit-test [ "a" ] [ xml-file get space>> ] unit-test diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 024b086ef9..77969c55cd 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax xml.data io strings ; +USING: help.markup help.syntax xml.data io strings byte-arrays ; IN: xml HELP: string>xml @@ -16,7 +16,11 @@ HELP: file>xml { $values { "filename" string } { "xml" xml } } { $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ; -{ string>xml read-xml file>xml } related-words +HELP: bytes>xml +{ $values { "byte-array" byte-array } { "xml" xml } } +{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ; + +{ string>xml read-xml file>xml bytes>xml } related-words HELP: read-xml-chunk { $values { "stream" "an input stream" } { "seq" "a sequence of elements" } } @@ -68,6 +72,7 @@ ARTICLE: { "xml" "reading" } "Reading XML" { $subsection read-xml-chunk } { $subsection string>xml-chunk } { $subsection file>xml } + { $subsection bytes>xml } "To read a DTD:" { $subsection read-dtd } { $subsection file>dtd } diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 57c1b6dbd3..073f46cbae 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files io.streams.string kernel namespaces sequences strings io.encodings.utf8 xml.data xml.errors xml.elements ascii xml.entities xml.writer xml.state xml.autoencoding assocs xml.tokenize -combinators.short-circuit xml.name splitting ; +combinators.short-circuit xml.name splitting io.streams.byte-array ; IN: xml : file>xml ( filename -- xml ) binary read-xml ; +: bytes>xml ( byte-array -- xml ) + binary read-xml ; + : read-dtd ( stream -- dtd ) [ H{ } clone extra-entities set From 0ce47f84c607b594da2c4854cfc3db3c9a1457f5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:14:09 -0600 Subject: [PATCH 13/21] use decode instead of >string in images.tiff --- basis/images/tiff/tiff.factor | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 674188992a..f57f15ae20 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators io io.encodings.binary io.files kernel -pack endian constructors sequences arrays math.order math.parser -prettyprint classes io.binary assocs math math.bitwise byte-arrays -grouping images compression.lzw fry strings ; +USING: accessors arrays assocs byte-arrays classes combinators +compression.lzw constructors endian fry grouping images io +io.binary io.encodings.ascii io.encodings.binary +io.encodings.string io.encodings.utf8 io.files kernel math +math.bitwise math.order math.parser pack prettyprint sequences +strings ; IN: images.tiff TUPLE: tiff-image < image ; @@ -249,13 +251,13 @@ ERROR: bad-small-ifd-type n ; { 283 [ first y-resolution ] } { 284 [ planar-configuration ] } { 296 [ lookup-resolution-unit resolution-unit ] } - { 305 [ >string software ] } - { 306 [ >string date-time ] } + { 305 [ ascii decode software ] } + { 306 [ ascii decode date-time ] } { 317 [ lookup-predictor predictor ] } { 330 [ sub-ifd ] } { 338 [ lookup-extra-samples extra-samples ] } { 339 [ lookup-sample-format sample-format ] } - { 700 [ >string xmp ] } + { 700 [ utf8 decode xmp ] } { 34377 [ photoshop ] } { 34665 [ exif-ifd ] } { 33723 [ iptc ] } From 813b0cb803e79eab45b58cb41c89510257290432 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:46:36 -0600 Subject: [PATCH 14/21] get the byte ordering correct for tiffs --- basis/images/bitmap/bitmap.factor | 4 ++-- basis/images/images.factor | 2 +- basis/images/tiff/tiff.factor | 17 +++++++++++++++-- 3 files changed, 18 insertions(+), 5 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index c9bb15192b..6713a729b5 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns combinators fry grouping io io.binary io.encodings.binary io.files kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary ; +strings images endian summary annotations ; IN: images.bitmap TUPLE: bitmap-image < image ; @@ -105,7 +105,7 @@ ERROR: unknown-component-order bitmap ; { [ [ width>> ] [ height>> ] bi 2array ] [ bitmap>component-order ] - [ drop little-endian ] ! XXX + [ drop little-endian ] !XXX [ buffer>> ] } cleave bitmap-image boa ; diff --git a/basis/images/images.factor b/basis/images/images.factor index e366dd2700..11452aa7d2 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -7,7 +7,7 @@ IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 ; -TUPLE: image dim component-order byte-order bitmap ; +TUPLE: image dim component-order bitmap ; : ( -- image ) image new ; inline diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 674188992a..8e981a8163 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -286,6 +286,18 @@ ERROR: unhandled-compression compression ; ERROR: unknown-component-order ifd ; +: fix-bitmap-endianness ( ifd -- ifd ) + dup [ bitmap>> ] [ bits-per-sample find-tag ] bi + { + { { 32 32 32 32 } [ 4 seq>native-endianness ] } + { { 32 32 32 } [ 4 seq>native-endianness ] } + { { 16 16 16 16 } [ 2 seq>native-endianness ] } + { { 16 16 16 } [ 2 seq>native-endianness ] } + { { 8 8 8 8 } [ ] } + { { 8 8 8 } [ ] } + [ unknown-component-order ] + } case >>bitmap ; + : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { { { 32 32 32 } [ R32G32B32 ] } @@ -299,7 +311,6 @@ ERROR: unknown-component-order ifd ; { [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order ] - [ drop big-endian ] ! XXX [ bitmap>> ] } cleave tiff-image boa ; @@ -314,7 +325,9 @@ ERROR: unknown-component-order ifd ; dup ifds>> [ process-ifd read-strips uncompress-strips - strips>bitmap drop + strips>bitmap + fix-bitmap-endianness + drop ] each ] with-endianness ] with-file-reader ; From d7e10c3072c2795614656364b62abfb219b8ef8d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:47:07 -0600 Subject: [PATCH 15/21] remove XXX from bitmaps --- basis/images/bitmap/bitmap.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 6713a729b5..9005776e40 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns combinators fry grouping io io.binary io.encodings.binary io.files kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary annotations ; +strings images endian summary ; IN: images.bitmap TUPLE: bitmap-image < image ; @@ -105,7 +105,6 @@ ERROR: unknown-component-order bitmap ; { [ [ width>> ] [ height>> ] bi 2array ] [ bitmap>component-order ] - [ drop little-endian ] !XXX [ buffer>> ] } cleave bitmap-image boa ; From 03839aa3ccceb69355885eb59583f5afa4a16f64 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:47:48 -0600 Subject: [PATCH 16/21] str -> bytes, utility word in endian --- basis/endian/endian.factor | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor index a832d6c0a2..a453a71704 100755 --- a/basis/endian/endian.factor +++ b/basis/endian/endian.factor @@ -1,39 +1,39 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types namespaces io.binary fry -kernel math ; +kernel math grouping sequences ; IN: endian SINGLETONS: big-endian little-endian ; -: native-endianness ( -- class ) +: compute-native-endianness ( -- class ) 1 *char 0 = big-endian little-endian ? ; : >signed ( x n -- y ) 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; -native-endianness \ native-endianness set-global +SYMBOL: native-endianness +native-endianness [ compute-native-endianness ] initialize SYMBOL: endianness +endianness [ native-endianness get-global ] initialize -\ native-endianness get-global endianness set-global - -HOOK: >native-endian native-endianness ( obj n -- str ) +HOOK: >native-endian native-endianness ( obj n -- bytes ) M: big-endian >native-endian >be ; M: little-endian >native-endian >le ; -HOOK: unsigned-native-endian> native-endianness ( obj -- str ) +HOOK: unsigned-native-endian> native-endianness ( obj -- bytes ) M: big-endian unsigned-native-endian> be> ; M: little-endian unsigned-native-endian> le> ; -: signed-native-endian> ( obj n -- str ) +: signed-native-endian> ( obj n -- n' ) [ unsigned-native-endian> ] dip >signed ; -HOOK: >endian endianness ( obj n -- str ) +HOOK: >endian endianness ( obj n -- bytes ) M: big-endian >endian >be ; @@ -45,13 +45,13 @@ M: big-endian endian> be> ; M: little-endian endian> le> ; -HOOK: unsigned-endian> endianness ( obj -- str ) +HOOK: unsigned-endian> endianness ( obj -- bytes ) M: big-endian unsigned-endian> be> ; M: little-endian unsigned-endian> le> ; -: signed-endian> ( obj n -- str ) +: signed-endian> ( obj n -- bytes ) [ unsigned-endian> ] dip >signed ; : with-endianness ( endian quot -- ) @@ -65,3 +65,15 @@ M: little-endian unsigned-endian> le> ; : with-native-endian ( quot -- ) \ native-endianness get-global swap with-endianness ; inline + +: seq>native-endianness ( seq n -- seq' ) + native-endianness get-global dup endianness get = [ + 2drop + ] [ + [ [ ] keep ] dip + little-endian = [ + '[ be> _ >le ] map + ] [ + '[ le> _ >be ] map + ] if concat + ] if ; inline From 8223f4277514255eaf0a5f5d71ed8bfbce9904ed Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:52:17 -0600 Subject: [PATCH 17/21] decode uname strings as utf8 --- extra/system-info/linux/linux.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/system-info/linux/linux.factor b/extra/system-info/linux/linux.factor index 00a49fb2a2..b77e1fe649 100644 --- a/extra/system-info/linux/linux.factor +++ b/extra/system-info/linux/linux.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: unix alien alien.c-types kernel math sequences strings -io.backend.unix splitting ; +io.backend.unix splitting io.encodings.utf8 io.encodings.string ; IN: system-info.linux : (uname) ( buf -- int ) @@ -9,7 +9,7 @@ IN: system-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep - "\0" split harvest [ >string ] map + "\0" split harvest [ utf8 decode ] map 6 "" pad-tail ; : sysname ( -- string ) uname first ; From 3cf4c6fee20e5a36088a16a155e2f648e6d092ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:56:22 -0600 Subject: [PATCH 18/21] support 48bpp tiffs --- basis/images/images.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 11452aa7d2..32fbc54978 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors grouping sequences combinators -math specialized-arrays.direct.uint byte-arrays ; +math specialized-arrays.direct.uint byte-arrays +specialized-arrays.direct.ushort ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR @@ -28,6 +29,13 @@ GENERIC: load-image* ( path tuple -- image ) >byte-array add-dummy-alpha ] change-bitmap ] } + { R16G16B16 [ + [ + dup length 2 / + [ -8 shift ] map + >byte-array add-dummy-alpha + ] change-bitmap + ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each From 8253bf4662a141ea0b54af9dab66f667c032369c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 13 Feb 2009 16:05:18 -0600 Subject: [PATCH 19/21] Another failing test in db.sqlite --- basis/db/sqlite/sqlite-tests.factor | 36 +++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index e05d992014..529de9774b 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -127,3 +127,39 @@ hi "HELLO" { hi drop-table ] with-db ] unit-test + +TUPLE: show id ; +TUPLE: user username data ; +TUPLE: watch show user ; + +user "USER" { + { "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ } + { "data" "DATA" TEXT } +} define-persistent + +show "SHOW" { + { "id" "ID" +db-assigned-id+ } +} define-persistent + +watch "WATCH" { + { "user" "USER" TEXT +not-null+ + { +foreign-id+ user "USERNAME" } +user-assigned-id+ } + { "show" "SHOW" BIG-INTEGER +not-null+ + { +foreign-id+ show "ID" } +user-assigned-id+ } +} define-persistent + +[ T{ user { username "littledan" } { data "foo" } } ] [ + test.db [ + user create-table + show create-table + watch create-table + "littledan" "foo" user boa insert-tuple + "mark" "bar" user boa insert-tuple + show new insert-tuple + show new select-tuple + "littledan" f user boa select-tuple + watch boa insert-tuple + watch new select-tuple + user>> f user boa select-tuple + ] with-db +] unit-test From f3db8fdc4a4a88502c2d2527da9d491eb2670e07 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 13 Feb 2009 16:07:17 -0600 Subject: [PATCH 20/21] Another failing unit test for db.sqlite --- basis/db/sqlite/sqlite-tests.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 529de9774b..5ad4b0c889 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -163,3 +163,5 @@ watch "WATCH" { user>> f user boa select-tuple ] with-db ] unit-test + +[ \ swap ensure-table ] must-fail From 3c00e7270604518fe27f4b998061b521c6edfe37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Feb 2009 18:06:55 -0600 Subject: [PATCH 21/21] Clean up extra/twitter a little bit --- extra/twitter/twitter.factor | 73 +++++++++++++++++++++++++----------- 1 file changed, 52 insertions(+), 21 deletions(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index 2172d7cf81..d70828b310 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -1,12 +1,41 @@ +! Copyright (C) 2009 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators hashtables http http.client json.reader kernel macros namespaces sequences -urls.secure urls.encoding ; +urls.secure fry ; IN: twitter +! Configuration SYMBOLS: twitter-username twitter-password twitter-source ; twitter-source [ "factor" ] initialize +: set-twitter-credentials ( username password -- ) + [ twitter-username set ] [ twitter-password set ] bi* ; + + + +! Data types + TUPLE: twitter-status created-at id @@ -28,8 +57,7 @@ TUPLE: twitter-user protected? followers-count ; -MACRO: keys-boa ( keys class -- ) - [ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ; + ( assoc -- user ) { @@ -64,37 +92,40 @@ MACRO: keys-boa ( keys class -- ) : json>twitter-status ( json-object -- tweet ) json> ; -: set-twitter-credentials ( username password -- ) - [ twitter-username set ] [ twitter-password set ] bi* ; +PRIVATE> -: set-request-twitter-auth ( request -- request ) - twitter-username twitter-password [ get ] bi@ set-basic-auth ; +! Updates + - set-request-twitter-auth - http-request nip ; + update-post-data "update" [ ] twitter-request ; + +PRIVATE> : tweet* ( string -- tweet ) (tweet) json>twitter-status ; : tweet ( string -- ) (tweet) drop ; +! Timelines + ] twitter-request json>twitter-statuses ; + +PRIVATE> + : public-timeline ( -- tweets ) - "https://twitter.com/statuses/public_timeline.json" - set-request-twitter-auth - http-request nip json>twitter-statuses ; + "public_timeline" timeline ; : friends-timeline ( -- tweets ) - "https://twitter.com/statuses/friends_timeline.json" - set-request-twitter-auth - http-request nip json>twitter-statuses ; + "friends_timeline" timeline ; : user-timeline ( username -- tweets ) - "https://twitter.com/statuses/user_timeline/" ".json" surround - set-request-twitter-auth - http-request nip json>twitter-statuses ; + "user_timeline/" prepend timeline ;