Merge branch 'master' of git://factorcode.org/git/factor

basis/bitstreams/bitstreams-tests.factor

@@ -1,31 +1,27 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors bitstreams io io.streams.string kernel tools.test
-grouping compression.lzw multiline byte-arrays ;
+grouping compression.lzw multiline byte-arrays io.encodings.binary
+io.streams.byte-array ;
 IN: bitstreams.tests
 
-[ 1 ]
+[ 1 t ]
 [ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
 
-[ 254 ]
+[ 254 8 t ]
 [ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
 
-[ 4095 ]
+[ 4095 12 t ]
 [ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
 
 [ B{ 254 } ]
 [
     <string-writer> <bitstream-writer> 254 8 rot
-    [ write-bits ] keep output>> >byte-array
+    [ write-bits ] keep stream>> >byte-array
 ] unit-test
 
+[ 255 8 t ]
+[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
 
-/*
+[ 255 8 f ]
-[
+[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
-    
-] [
-    B{ 7 7 7 8 8 7 7 9 7 }
-    [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ]
-    [ lzw-compress ] bi
-] unit-test
-*/

basis/bitstreams/bitstreams.factor

@@ -4,7 +4,7 @@ USING: accessors byte-arrays destructors fry io kernel locals
 math sequences ;
 IN: bitstreams
 
-TUPLE: bitstream stream current-bits #bits disposed ;
+TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
 TUPLE: bitstream-reader < bitstream ;
 
 : reset-bitstream ( stream -- stream )
@@ -22,8 +22,12 @@ M: bitstream-reader dispose ( stream -- )
     bitstream-reader new-bitstream ; inline
 
 : read-next-byte ( bitstream -- bitstream )
-    dup stream>> stream-read1
+    dup stream>> stream-read1 [
-    [ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline
+        >>current-bits 8 >>#bits
+    ] [
+        0 >>#bits
+        t >>end-of-stream?
+    ] if* ;
 
 : maybe-read-next-byte ( bitstream -- bitstream )
     dup #bits>> 0 = [ read-next-byte ] when ; inline
@@ -31,17 +35,19 @@ M: bitstream-reader dispose ( stream -- )
 : shift-one-bit ( bitstream -- n )
     [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
 
-: next-bit ( bitstream -- n )
+: next-bit ( bitstream -- n/f ? )
-    maybe-read-next-byte [
+    maybe-read-next-byte
-        shift-one-bit
+    dup end-of-stream?>> [
+        drop f
     ] [
-        [ 1- ] change-#bits maybe-read-next-byte drop
+        [ shift-one-bit ]
-    ] bi ; inline
+        [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
+    ] if dup >boolean ;
 
-: read-bit ( bitstream -- n )
+: read-bit ( bitstream -- n ? )
     dup #bits>> 1 = [
         [ current-bits>> 1 bitand ]
-        [ read-next-byte drop ] bi
+        [ read-next-byte drop ] bi t
     ] [
         next-bit
     ] if ; inline
@@ -49,9 +55,12 @@ M: bitstream-reader dispose ( stream -- )
 : bits>integer ( seq -- n )
     0 [ [ 1 shift ] dip bitor ] reduce ; inline
 
-: read-bits ( width bitstream -- n )
+: read-bits ( width bitstream -- n width ? )
-    '[ _ read-bit ] replicate bits>integer ; inline
+    [
-
+        '[ _ read-bit drop ] replicate
+        [ f = ] trim-tail
+        [ bits>integer ] [ length ] bi
+    ] 2keep drop over = ;
 
 TUPLE: bitstream-writer < bitstream ;
 

basis/compression/lzw/lzw.factor

@@ -110,9 +110,23 @@ ERROR: not-in-table ;
 
 : lzw-compress-chars ( lzw -- )
     {
-        [ [ clear-code lzw-compress-char ] [ reset-lzw-compress drop ] bi ]
+        ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
+        [
+            [ clear-code ] dip
+            [ lzw-bit-width-compress ]
+            [ output>> write-bits ] bi
+        ]
         [ (lzw-compress-chars) ]
-        [ end-of-information lzw-compress-char ]
+        [
+            [ k>> ]
+            [ lzw-bit-width-compress ]
+            [ output>> write-bits ] tri
+        ]
+        [
+            [ end-of-information ] dip
+            [ lzw-bit-width-compress ]
+            [ output>> write-bits ] bi
+        ]
         [ ]
     } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
 
@@ -138,7 +152,7 @@ ERROR: not-in-table ;
 : add-to-table ( seq lzw -- ) table>> push ;
 
 : lzw-read ( lzw -- lzw n )
-    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits ;
+    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
 
 DEFER: lzw-uncompress-char
 : handle-clear-code ( lzw -- )

basis/compression/zlib/ffi/ffi.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.syntax combinators system ;
-IN: zlib.ffi
+IN: compression.zlib.ffi
 
 << "zlib" {
     { [ os winnt? ] [ "zlib1.dll" ] }

basis/compression/zlib/zlib-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test zlib classes ;
+USING: kernel tools.test compression.zlib classes ;
-IN: zlib.tests
+IN: compression.zlib.tests
 
 : compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
 

basis/compression/zlib/zlib.factor

@@ -3,8 +3,8 @@
 USING: alien alien.c-types alien.syntax byte-arrays combinators
 kernel math math.functions sequences system accessors
 libc ;
-QUALIFIED: zlib.ffi
+QUALIFIED: compression.zlib.ffi
-IN: zlib
+IN: compression.zlib
 
 TUPLE: compressed data length ;
 
@@ -16,7 +16,7 @@ TUPLE: compressed data length ;
 ERROR: zlib-failed n string ;
 
 : zlib-error-message ( n -- * )
-    dup zlib.ffi:Z_ERRNO = [
+    dup compression.zlib.ffi:Z_ERRNO = [
         drop errno "native libc error"
     ] [
         dup {
@@ -27,7 +27,7 @@ ERROR: zlib-failed n string ;
     ] if zlib-failed ;
 
 : zlib-error ( n -- )
-    dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
+    dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
 
 : compressed-size ( byte-array -- n )
     length 1001/1000 * ceiling 12 + ;
@@ -35,7 +35,7 @@ ERROR: zlib-failed n string ;
 : compress ( byte-array -- compressed )
     [
         [ compressed-size <byte-array> dup length <ulong> ] keep [
-            dup length zlib.ffi:compress zlib-error
+            dup length compression.zlib.ffi:compress zlib-error
         ] 3keep drop *ulong head
     ] keep length <compressed> ;
 
@@ -44,5 +44,5 @@ ERROR: zlib-failed n string ;
         length>> [ <byte-array> ] keep <ulong> 2dup
     ] [
         data>> dup length
-        zlib.ffi:uncompress zlib-error
+        compression.zlib.ffi:uncompress zlib-error
     ] bi *ulong head ;

basis/http/client/client-docs.factor

@@ -56,8 +56,7 @@ HELP: http-request
 
 HELP: with-http-request
 { $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
-{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
+{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ;
-{ $errors "Throws an error if the HTTP request fails." } ;
 
 ARTICLE: "http.client.get" "GET requests with the HTTP client"
 "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"

basis/http/client/client.factor

@@ -141,12 +141,15 @@ ERROR: download-failed response ;
 : check-response ( response -- response )
     dup code>> success? [ download-failed ] unless ;
 
+: check-response-with-body ( response body -- response body )
+    [ >>body check-response ] keep ;
+
 : with-http-request ( request quot -- response )
-    [ (with-http-request) check-response ] with-destructors ; inline
+    [ (with-http-request) ] with-destructors ; inline
 
 : http-request ( request -- response data )
     [ [ % ] with-http-request ] B{ } make
-    over content-charset>> decode ;
+    over content-charset>> decode check-response-with-body ;
 
 : <get-request> ( url -- request )
     "GET" <client-request> ;

basis/http/http-docs.factor

@@ -113,6 +113,12 @@ HELP: set-header
 { $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
 { $side-effects "request/response" } ;
 
+HELP: set-basic-auth
+{ $values { "request" request } { "username" string } { "password" string } }
+{ $description "Sets the " { $snippet "Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." }
+{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
+{ $side-effects "request" } ;
+
 ARTICLE: "http.cookies" "HTTP cookies"
 "Every " { $link request } " and " { $link response } " instance can contain cookies."
 $nl

basis/http/http-tests.factor

@@ -359,3 +359,8 @@ SYMBOL: a
 ! Test cloning
 [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
 [ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
+
+! Test basic auth
+[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
+
+

basis/http/http.factor

@@ -7,7 +7,8 @@ calendar.format present urls fry
 io io.encodings io.encodings.iana io.encodings.binary
 io.encodings.8-bit io.crlf
 unicode.case unicode.categories
-http.parsers ;
+http.parsers
+base64 ;
 IN: http
 
 : (read-header) ( -- alist )
@@ -142,6 +143,9 @@ cookies ;
 : set-header ( request/response value key -- request/response )
     pick header>> set-at ;
 
+: set-basic-auth ( request username password -- request )
+    ":" glue >base64 "Basic " prepend "Authorization" set-header ;
+    
 : <request> ( -- request )
     request new
         "1.1" >>version
@@ -156,6 +160,7 @@ cookies ;
 : header ( request/response key -- value )
     swap header>> at ;
 
+
 TUPLE: response
 version
 code

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
+R16G16B16 R32G32B32 ;
 
 TUPLE: image dim component-order byte-order bitmap ;
 
@@ -11,22 +13,32 @@ TUPLE: image dim component-order byte-order bitmap ;
 
 GENERIC: load-image* ( path tuple -- image )
 
+: add-dummy-alpha ( seq -- seq' )
+    3 <sliced-groups>
+    [ 255 suffix ] map concat ;
+
 : normalize-component-order ( image -- image )
     dup component-order>>
     {
         { RGBA [ ] }
+        { R32G32B32 [
+            [
+                dup length 4 / <direct-uint-array>
+                [ bits>float 255.0 * >integer ] map
+                >byte-array add-dummy-alpha
+            ] change-bitmap
+        ] }
         { BGRA [
             [
                 4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
             ] change-bitmap
         ] }
-        { RGB [
+        { RGB [ [ add-dummy-alpha ] change-bitmap ] }
-            [ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
-        ] }
         { BGR [
             [
-                3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
+                3 <sliced-groups>
-                [ 255 suffix ] map concat
+                [ [ [ 0 3 ] dip <slice> reverse-here ] each ]
+                [ add-dummy-alpha ] bi
             ] change-bitmap
         ] }
     } case
@@ -37,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 ;

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 ;

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
+samples-per-pixel new-subfile-type orientation software
-unhandled-ifd-entry ;
+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 ;
 
@@ -242,14 +245,22 @@ ERROR: bad-small-ifd-type n ;
         { 277 [ samples-per-pixel ] }
         { 278 [ rows-per-strip ] }
         { 279 [ strip-byte-counts ] }
-        { 282 [ x-resolution ] }
+        { 282 [ first x-resolution ] }
-        { 283 [ y-resolution ] }
+        { 283 [ first 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 )
@@ -276,9 +287,11 @@ ERROR: unhandled-compression compression ;
 ERROR: unknown-component-order ifd ;
 
 : ifd-component-order ( ifd -- byte-order )
-    bits-per-sample find-tag sum {
+    bits-per-sample find-tag {
-        { 32 [ RGBA ] }
+        { { 32 32 32 } [ R32G32B32 ] }
-        { 24 [ RGB ] }
+        { { 16 16 16 } [ R16G16B16 ] }
+        { { 8 8 8 8 } [ RGBA ] }
+        { { 8 8 8 } [ RGB ] }
         [ unknown-component-order ]
     } case ;
 

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
 
 <PRIVATE
@@ -26,13 +27,17 @@ IN: tools.hexdump
 : write-hex-line ( bytes lineno -- )
     write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
 
+: hexdump-bytes ( bytes -- )
+    [ length write-header ]
+    [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
+
 PRIVATE>
 
 GENERIC: hexdump. ( byte-array -- )
 
-M: byte-array hexdump.
+M: byte-array hexdump. hexdump-bytes ;
-    [ length write-header ]
+
-    [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
+M: byte-vector hexdump. hexdump-bytes ;
 
 : hexdump ( byte-array -- str )
     [ hexdump. ] with-string-writer ;

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\""

extra/twitter/twitter.factor

@@ -0,0 +1,100 @@
+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 twitter-source ;
+
+twitter-source [ "factor" ] initialize
+
+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 ;
+
+: <twitter-user> ( assoc -- user )
+    {
+        "id"
+        "name"
+        "screen_name"
+        "description"
+        "location"
+        "profile_image_url"
+        "url"
+        "protected"
+        "followers_count"
+    } twitter-user keys-boa ;
+
+: <twitter-status> ( assoc -- tweet )
+    clone "user" over [ <twitter-user> ] 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> [ <twitter-status> ] map ;
+
+: json>twitter-status ( json-object -- tweet )
+    json> <twitter-status> ;
+
+: set-twitter-credentials ( username password -- )
+    [ twitter-username set ] [ twitter-password set ] bi* ; 
+
+: set-request-twitter-auth ( request -- request )
+    twitter-username twitter-password [ get ] bi@ set-basic-auth ;
+
+: update-post-data ( update -- assoc )
+    "status" associate
+    [ twitter-source get "source" ] dip [ set-at ] keep ;
+
+: (tweet) ( string -- json )
+    update-post-data "https://twitter.com/statuses/update.json" <post-request>
+        set-request-twitter-auth 
+    http-request nip ;
+
+: tweet* ( string -- tweet )
+    (tweet) json>twitter-status ;
+
+: tweet ( string -- ) (tweet) drop ;
+
+: public-timeline ( -- tweets )
+    "https://twitter.com/statuses/public_timeline.json" <get-request>
+        set-request-twitter-auth
+    http-request nip json>twitter-statuses ;
+
+: friends-timeline ( -- tweets )
+    "https://twitter.com/statuses/friends_timeline.json" <get-request>
+        set-request-twitter-auth
+    http-request nip json>twitter-statuses ;
+
+: user-timeline ( username -- tweets )
+    "https://twitter.com/statuses/user_timeline/" ".json" surround <get-request>
+        set-request-twitter-auth
+    http-request nip json>twitter-statuses ;