steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Daniel Ehrenberg 2009-02-13 15:10:41 -06:00
parent c6680eee60 55434492f9
commit e90ad88876
19 changed files with 234 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
basis/bitstreams/bitstreams-tests.factor
View File

@ -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
/*
[
] [
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
*/
[ 255 8 f ]
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test

35
basis/bitstreams/bitstreams.factor
View File

@ -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
[ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline
dup stream>> stream-read1 [
>>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 )
maybe-read-next-byte [
shift-one-bit
: next-bit ( bitstream -- n/f ? )
maybe-read-next-byte
dup end-of-stream?>> [
drop f
] [
[ 1- ] change-#bits maybe-read-next-byte drop
] bi ; inline
[ shift-one-bit ]
[ [ 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-bit ] replicate bits>integer ; inline
: read-bits ( width bitstream -- n width ? )
[
'[ _ read-bit drop ] replicate
[ f = ] trim-tail
[ bits>integer ] [ length ] bi
] 2keep drop over = ;
TUPLE: bitstream-writer < bitstream ;

20
basis/compression/lzw/lzw.factor
View File

@ -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 -- )

0
basis/zlib/authors.txt → basis/compression/zlib/authors.txt
View File

0
basis/zlib/ffi/authors.txt → basis/compression/zlib/ffi/authors.txt
View File

2
basis/zlib/ffi/ffi.factor → basis/compression/zlib/ffi/ffi.factor
View File

@ -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" ] }

4
basis/zlib/zlib-tests.factor → basis/compression/zlib/zlib-tests.factor
View File

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

12
basis/zlib/zlib.factor → basis/compression/zlib/zlib.factor
View File

@ -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
IN: zlib
QUALIFIED: compression.zlib.ffi
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 ;

3
basis/http/client/client-docs.factor
View File

@ -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." }
{ $errors "Throws an error if the HTTP request fails." } ;
{ $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" } "." } ;
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:"

7
basis/http/client/client.factor
View File

@ -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> ;

6
basis/http/http-docs.factor
View File

@ -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

5
basis/http/http-tests.factor
View File

@ -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

7
basis/http/http.factor
View File

@ -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

27
basis/images/images.factor
View File

@ -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 [
[ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
] }
{ RGB [ [ add-dummy-alpha ] change-bitmap ] }
{ BGR [
[
3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
[ 255 suffix ] map concat
3 <sliced-groups>
[ [ [ 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 ;

1
basis/images/loader/loader.factor
View File

@ -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 ;

31
basis/images/tiff/tiff.factor
View File

@ -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 ;
@ -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 ] }
{ 283 [ y-resolution ] }
{ 282 [ first x-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 {
{ 32 [ RGBA ] }
{ 24 [ RGB ] }
bits-per-sample find-tag {
{ { 32 32 32 } [ R32G32B32 ] }
{ { 16 16 16 } [ R16G16B16 ] }
{ { 8 8 8 8 } [ RGBA ] }
{ { 8 8 8 } [ RGB ] }
[ unknown-component-order ]
} case ;

13
basis/tools/hexdump/hexdump.factor
View File

@ -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.
[ length write-header ]
[ 16 <sliced-groups> [ 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 ;

2
core/classes/tuple/tuple-docs.factor
View File

@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
}
"An example of using a changer:"
{ $code
": positions"
": positions ( -- seq )"
" {"
" \"junior programmer\""
" \"senior programmer\""

100
extra/twitter/twitter.factor Normal file
View File

@ -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 ;