From 3c00e7270604518fe27f4b998061b521c6edfe37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Feb 2009 18:06:55 -0600 Subject: [PATCH 01/10] 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 ; From 83834f802ae3fcf277c53746d2b4c487cd7dc21f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Feb 2009 20:20:22 -0600 Subject: [PATCH 02/10] Fixing twitter --- extra/twitter/twitter.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index d70828b310..48388de382 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -27,8 +27,7 @@ MACRO: keys-boa ( keys class -- ) : set-request-twitter-auth ( request -- request ) twitter-username get twitter-password get set-basic-auth ; -: twitter-request ( string quot -- data ) - [ twitter-url ] dip call +: twitter-request ( request -- data ) set-request-twitter-auth http-request nip ; inline @@ -101,10 +100,11 @@ PRIVATE> [ "status" set twitter-source get "source" set - ] make-assoc ; + ] H{ } make-assoc ; : (tweet) ( string -- json ) - update-post-data "update" [ ] twitter-request ; + update-post-data "update" twitter-url + twitter-request ; PRIVATE> @@ -117,7 +117,8 @@ PRIVATE> ] twitter-request json>twitter-statuses ; + twitter-url + twitter-request json>twitter-statuses ; PRIVATE> From b4e7592ba38d6c602b68f490a641c5d3cf6e0578 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 00:30:59 -0600 Subject: [PATCH 03/10] support predictors --- basis/images/images.factor | 28 ++++++++++++++----------- basis/images/tiff/tiff.factor | 39 +++++++++++++++++++++++++++++++++-- 2 files changed, 53 insertions(+), 14 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 32fbc54978..c2dc33608e 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -2,11 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors grouping sequences combinators math specialized-arrays.direct.uint byte-arrays -specialized-arrays.direct.ushort ; +specialized-arrays.direct.ushort specialized-arrays.uint +specialized-arrays.ushort specialized-arrays.float ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR -R16G16B16 R32G32B32 ; +R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; TUPLE: image dim component-order bitmap ; @@ -18,34 +19,37 @@ GENERIC: load-image* ( path tuple -- image ) 3 [ 255 suffix ] map concat ; +: normalize-floats ( byte-array -- byte-array ) + byte-array>float-array [ 255.0 * >integer ] B{ } map-as ; + : normalize-component-order ( image -- image ) dup component-order>> { { RGBA [ ] } + { R32G32B32A32 [ + [ normalize-floats ] change-bitmap + ] } { R32G32B32 [ - [ - dup length 4 / - [ bits>float 255.0 * >integer ] map - >byte-array add-dummy-alpha - ] change-bitmap + [ normalize-floats add-dummy-alpha ] change-bitmap + ] } + { R16G16B16A16 [ + [ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap ] } { R16G16B16 [ [ - dup length 2 / - [ -8 shift ] map - >byte-array add-dummy-alpha + byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha ] change-bitmap ] } { BGRA [ [ - 4 dup [ [ 0 3 ] dip reverse-here ] each + 4 dup [ 3 head-slice reverse-here ] each ] change-bitmap ] } { RGB [ [ add-dummy-alpha ] change-bitmap ] } { BGR [ [ 3 - [ [ [ 0 3 ] dip reverse-here ] each ] + [ [ 3 head-slice reverse-here ] each ] [ add-dummy-alpha ] bi ] change-bitmap ] } diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 056f91faaa..c91edbae39 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,7 @@ 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 ; +strings math.vectors ; IN: images.tiff TUPLE: tiff-image < image ; @@ -119,7 +119,9 @@ 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 software date-time photoshop exif-ifd sub-ifd inter-color-profile -xmp iptc unhandled-ifd-entry ; +xmp iptc fill-order document-name page-number page-name +x-position y-position +unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -159,6 +161,9 @@ ERROR: no-tag class ; : find-tag ( idf class -- tag ) swap processed-tags>> ?at [ no-tag ] unless ; +: tag? ( idf class -- tag ) + swap processed-tags>> key? ; + : read-strips ( ifd -- ifd ) dup [ strip-byte-counts find-tag ] @@ -242,6 +247,8 @@ ERROR: bad-small-ifd-type n ; { 258 [ bits-per-sample ] } { 259 [ lookup-compression compression ] } { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 266 [ fill-order ] } + { 269 [ ascii decode document-name ] } { 273 [ strip-offsets ] } { 274 [ orientation ] } { 277 [ samples-per-pixel ] } @@ -250,7 +257,11 @@ ERROR: bad-small-ifd-type n ; { 282 [ first x-resolution ] } { 283 [ first y-resolution ] } { 284 [ planar-configuration ] } + { 285 [ page-name ] } + { 286 [ x-position ] } + { 287 [ y-position ] } { 296 [ lookup-resolution-unit resolution-unit ] } + { 297 [ page-number ] } { 305 [ ascii decode software ] } { 306 [ ascii decode date-time ] } { 317 [ lookup-predictor predictor ] } @@ -286,6 +297,27 @@ ERROR: unhandled-compression compression ; : strips>bitmap ( ifd -- ifd ) dup strips>> concat >>bitmap ; +: (strips-predictor) ( ifd -- ifd ) + [ ] + [ image-width find-tag ] + [ samples-per-pixel find-tag ] tri + [ * ] keep + '[ + _ group [ _ group [ rest ] [ first ] bi + [ v+ ] accumulate swap suffix concat ] map + concat >byte-array + ] change-bitmap ; + +: strips-predictor ( ifd -- ifd ) + dup predictor tag? [ + dup predictor find-tag + { + { predictor-none [ ] } + { predictor-horizontal-differencing [ (strips-predictor) ] } + [ bad-predictor ] + } case + ] when ; + ERROR: unknown-component-order ifd ; : fix-bitmap-endianness ( ifd -- ifd ) @@ -302,7 +334,9 @@ ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { + { { 32 32 32 32 } [ R32G32B32A32 ] } { { 32 32 32 } [ R32G32B32 ] } + { { 16 16 16 16 } [ R16G16B16A16 ] } { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } @@ -329,6 +363,7 @@ ERROR: unknown-component-order ifd ; uncompress-strips strips>bitmap fix-bitmap-endianness + strips-predictor drop ] each ] with-endianness From b638a35fd719447ffceb9b020ec34d182012675d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 00:31:17 -0600 Subject: [PATCH 04/10] move >signed to math.bitwise --- basis/endian/endian.factor | 5 +---- basis/math/bitwise/bitwise.factor | 4 ++++ 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor index a453a71704..4928458543 100755 --- a/basis/endian/endian.factor +++ b/basis/endian/endian.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types namespaces io.binary fry -kernel math grouping sequences ; +kernel math grouping sequences math.bitwise ; IN: endian SINGLETONS: big-endian little-endian ; @@ -9,9 +9,6 @@ SINGLETONS: big-endian little-endian ; : compute-native-endianness ( -- class ) 1 *char 0 = big-endian little-endian ? ; -: >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; - SYMBOL: native-endianness native-endianness [ compute-native-endianness ] initialize diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index e60815bf60..339703c0a6 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -102,3 +102,7 @@ PRIVATE> : signed-be> ( bytes -- x ) signed-le> ; + +: >signed ( x n -- y ) + 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + From 0286c524e84bc58e2ca430933daf5c68ffd7b6a5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 13:14:00 -0600 Subject: [PATCH 05/10] randomize was broken -- elements could not exchange with themselves --- basis/random/random-tests.factor | 5 ++++- basis/random/random.factor | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index e686dd7301..63c2159ab6 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -1,5 +1,5 @@ USING: random sequences tools.test kernel math math.functions -sets ; +sets grouping ; IN: random.tests [ 4 ] [ 4 random-bytes length ] unit-test @@ -17,3 +17,6 @@ IN: random.tests [ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test [ f ] [ 0 random ] unit-test + +[ f ] +[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index 554ed5c96a..cb4a141a98 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -53,7 +53,7 @@ PRIVATE> ] if-empty ; : randomize ( seq -- seq' ) - dup length 1 (a,b] [ dup random pick exchange ] each ; + dup length 1+ 2 (a,b] [ [ random ] [ 1- ] bi pick exchange ] each ; : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From 1418a67cc63e94a72efd09d30a9acd6eb163467c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 13:28:41 -0600 Subject: [PATCH 06/10] unit test how many elements to swap with randomize, remove a usage of pick --- basis/random/random-tests.factor | 5 ++++- basis/random/random.factor | 6 +++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 63c2159ab6..160a4fced1 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -1,5 +1,5 @@ USING: random sequences tools.test kernel math math.functions -sets grouping ; +sets grouping random.private ; IN: random.tests [ 4 ] [ 4 random-bytes length ] unit-test @@ -20,3 +20,6 @@ IN: random.tests [ f ] [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test + +[ t ] +[ { 1 2 } [ length ] [ >randomize-range length ] bi - 1 = ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index cb4a141a98..5befee7339 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -43,6 +43,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; [ random-bytes >byte-array byte-array>bignum ] [ 3 shift 2^ ] bi / * >integer ; +: >randomize-range ( seq -- range ) + length 1+ 2 (a,b] ; inline + PRIVATE> : random-bits ( n -- r ) 2^ random-integer ; @@ -53,7 +56,8 @@ PRIVATE> ] if-empty ; : randomize ( seq -- seq' ) - dup length 1+ 2 (a,b] [ [ random ] [ 1- ] bi pick exchange ] each ; + [ ] [ >randomize-range ] [ ] tri + '[ [ random ] [ 1- ] bi _ exchange ] each ; : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From a0491606bc308a7e122589075e61c2b6829ace2b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 14:04:54 -0600 Subject: [PATCH 07/10] fix { } randomize, more unit tests --- basis/random/random-tests.factor | 6 ++++++ basis/random/random.factor | 4 ++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 160a4fced1..60cdee98ed 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -18,6 +18,12 @@ IN: random.tests [ f ] [ 0 random ] unit-test +[ 0 ] [ { } >randomize-range length ] unit-test +[ 0 ] [ { 1 } >randomize-range length ] unit-test + +[ { } ] [ { } randomize ] unit-test +[ { 1 } ] [ { 1 } randomize ] unit-test + [ f ] [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index 5befee7339..9564e0a268 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -43,8 +43,8 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; [ random-bytes >byte-array byte-array>bignum ] [ 3 shift 2^ ] bi / * >integer ; -: >randomize-range ( seq -- range ) - length 1+ 2 (a,b] ; inline +: >randomize-range ( seq -- range/iota ) + length dup 2 < [ drop 0 iota ] [ 1+ 2 (a,b] ] if ; PRIVATE> From 99122a8fb1bf352c739dbe6ed12f9e43a582405f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 14:25:48 -0600 Subject: [PATCH 08/10] use while to implement randomize (thanks joe!), document it --- basis/random/random-docs.factor | 9 +++++++++ basis/random/random-tests.factor | 6 ------ basis/random/random.factor | 10 ++++------ 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index 01b389c19c..c7600a731f 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -57,6 +57,13 @@ HELP: with-system-random { with-random with-secure-random with-system-random } related-words +HELP: randomize +{ $values + { "seq" sequence } + { "seq" sequence } +} +{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ; + HELP: delete-random { $values { "seq" sequence } @@ -83,6 +90,8 @@ $nl { $subsection with-secure-random } "Implementation:" { $subsection "random-protocol" } +"Randomizing a sequence:" +{ $subsection randomize } "Deleting a random element from a sequence:" { $subsection delete-random } ; diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 60cdee98ed..9607627b3d 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -18,14 +18,8 @@ IN: random.tests [ f ] [ 0 random ] unit-test -[ 0 ] [ { } >randomize-range length ] unit-test -[ 0 ] [ { 1 } >randomize-range length ] unit-test - [ { } ] [ { } randomize ] unit-test [ { 1 } ] [ { 1 } randomize ] unit-test [ f ] [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test - -[ t ] -[ { 1 2 } [ length ] [ >randomize-range length ] bi - 1 = ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index 9564e0a268..17bcc8f1b1 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -43,9 +43,6 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; [ random-bytes >byte-array byte-array>bignum ] [ 3 shift 2^ ] bi / * >integer ; -: >randomize-range ( seq -- range/iota ) - length dup 2 < [ drop 0 iota ] [ 1+ 2 (a,b] ] if ; - PRIVATE> : random-bits ( n -- r ) 2^ random-integer ; @@ -55,9 +52,10 @@ PRIVATE> [ length random-integer ] keep nth ] if-empty ; -: randomize ( seq -- seq' ) - [ ] [ >randomize-range ] [ ] tri - '[ [ random ] [ 1- ] bi _ exchange ] each ; +: randomize ( seq -- seq ) + dup length [ dup 1 > ] + [ [ random ] [ 1- ] bi [ pick exchange ] keep ] + [ ] while drop ; : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From 47a2f42c9f4da07bc16ba4adc37daeece7df89e7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 19:24:42 -0600 Subject: [PATCH 09/10] handle associated alpha data in tiffs --- basis/images/tiff/tiff.factor | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c91edbae39..29f36495f0 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,7 @@ 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 math.vectors ; +strings math.vectors specialized-arrays.float ; IN: images.tiff TUPLE: tiff-image < image ; @@ -343,6 +343,25 @@ ERROR: unknown-component-order ifd ; [ unknown-component-order ] } case ; +: handle-alpha-data ( ifd -- ifd ) + dup extra-samples find-tag { + { extra-samples-associated-alpha-data [ + [ + B{ } like dup + byte-array>float-array + 4 + [ + dup fourth dup 0 = [ + 2drop + ] [ + [ 3 head-slice ] dip '[ _ / ] change-each + ] if + ] each + ] change-bitmap + ] } + [ bad-extra-samples ] + } case ; + : ifd>image ( ifd -- image ) { [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] @@ -364,6 +383,7 @@ ERROR: unknown-component-order ifd ; strips>bitmap fix-bitmap-endianness strips-predictor + handle-alpha-data drop ] each ] with-endianness From 5741aa198e23a0976af2ff04c3c796029ed2f62c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 19:28:00 -0600 Subject: [PATCH 10/10] not all images have associated alpha data... oops --- basis/images/tiff/tiff.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 29f36495f0..c3505ebec4 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -359,6 +359,8 @@ ERROR: unknown-component-order ifd ; ] each ] change-bitmap ] } + { extra-samples-unspecified-alpha-data [ + ] } [ bad-extra-samples ] } case ; @@ -383,7 +385,7 @@ ERROR: unknown-component-order ifd ; strips>bitmap fix-bitmap-endianness strips-predictor - handle-alpha-data + dup extra-samples tag? [ handle-alpha-data ] when drop ] each ] with-endianness