Merge branch 'master' of git://factorcode.org/git/factor
commit
7f130be10f
|
@ -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 <int> *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
|
||||
|
||||
|
|
|
@ -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 <sliced-groups>
|
||||
[ 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 / <direct-uint-array>
|
||||
[ 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 / <direct-ushort-array>
|
||||
[ -8 shift ] map
|
||||
>byte-array add-dummy-alpha
|
||||
byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha
|
||||
] change-bitmap
|
||||
] }
|
||||
{ BGRA [
|
||||
[
|
||||
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
4 <sliced-groups> dup [ 3 head-slice reverse-here ] each
|
||||
] change-bitmap
|
||||
] }
|
||||
{ RGB [ [ add-dummy-alpha ] change-bitmap ] }
|
||||
{ BGR [
|
||||
[
|
||||
3 <sliced-groups>
|
||||
[ [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
||||
[ [ 3 head-slice reverse-here ] each ]
|
||||
[ add-dummy-alpha ] bi
|
||||
] change-bitmap
|
||||
] }
|
||||
|
|
|
@ -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 specialized-arrays.float ;
|
||||
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,13 +334,36 @@ 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 ] }
|
||||
[ 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 <sliced-groups>
|
||||
[
|
||||
dup fourth dup 0 = [
|
||||
2drop
|
||||
] [
|
||||
[ 3 head-slice ] dip '[ _ / ] change-each
|
||||
] if
|
||||
] each
|
||||
] change-bitmap
|
||||
] }
|
||||
{ extra-samples-unspecified-alpha-data [
|
||||
] }
|
||||
[ bad-extra-samples ]
|
||||
} case ;
|
||||
|
||||
: ifd>image ( ifd -- image )
|
||||
{
|
||||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
|
@ -329,6 +384,8 @@ ERROR: unknown-component-order ifd ;
|
|||
uncompress-strips
|
||||
strips>bitmap
|
||||
fix-bitmap-endianness
|
||||
strips-predictor
|
||||
dup extra-samples tag? [ handle-alpha-data ] when
|
||||
drop
|
||||
] each
|
||||
] with-endianness
|
||||
|
|
|
@ -102,3 +102,7 @@ PRIVATE>
|
|||
|
||||
: signed-be> ( bytes -- x )
|
||||
<reversed> signed-le> ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
|
|
|
@ -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 } ;
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: random sequences tools.test kernel math math.functions
|
||||
sets ;
|
||||
sets grouping random.private ;
|
||||
IN: random.tests
|
||||
|
||||
[ 4 ] [ 4 random-bytes length ] unit-test
|
||||
|
@ -17,3 +17,9 @@ IN: random.tests
|
|||
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
|
||||
|
||||
[ f ] [ 0 random ] unit-test
|
||||
|
||||
[ { } ] [ { } randomize ] unit-test
|
||||
[ { 1 } ] [ { 1 } randomize ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
|
||||
|
|
|
@ -52,8 +52,10 @@ PRIVATE>
|
|||
[ length random-integer ] keep nth
|
||||
] if-empty ;
|
||||
|
||||
: randomize ( seq -- seq' )
|
||||
dup length 1 (a,b] [ dup random pick 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 ;
|
||||
|
|
|
@ -1,12 +1,40 @@
|
|||
! 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* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Utilities
|
||||
MACRO: keys-boa ( keys class -- )
|
||||
[ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
|
||||
|
||||
! Twitter requests
|
||||
|
||||
: twitter-url ( string -- url )
|
||||
"https://twitter.com/statuses/" ".json" surround ;
|
||||
|
||||
: set-request-twitter-auth ( request -- request )
|
||||
twitter-username get twitter-password get set-basic-auth ;
|
||||
|
||||
: twitter-request ( request -- data )
|
||||
set-request-twitter-auth
|
||||
http-request nip ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Data types
|
||||
|
||||
TUPLE: twitter-status
|
||||
created-at
|
||||
id
|
||||
|
@ -28,8 +56,7 @@ TUPLE: twitter-user
|
|||
protected?
|
||||
followers-count ;
|
||||
|
||||
MACRO: keys-boa ( keys class -- )
|
||||
[ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
|
||||
<PRIVATE
|
||||
|
||||
: <twitter-user> ( assoc -- user )
|
||||
{
|
||||
|
@ -64,37 +91,42 @@ MACRO: keys-boa ( keys class -- )
|
|||
: json>twitter-status ( json-object -- tweet )
|
||||
json> <twitter-status> ;
|
||||
|
||||
: 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
|
||||
<PRIVATE
|
||||
|
||||
: update-post-data ( update -- assoc )
|
||||
"status" associate
|
||||
[ twitter-source get "source" ] dip [ set-at ] keep ;
|
||||
[
|
||||
"status" set
|
||||
twitter-source get "source" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: (tweet) ( string -- json )
|
||||
update-post-data "https://twitter.com/statuses/update.json" <post-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip ;
|
||||
update-post-data "update" twitter-url
|
||||
<post-request> twitter-request ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: tweet* ( string -- tweet )
|
||||
(tweet) json>twitter-status ;
|
||||
|
||||
: tweet ( string -- ) (tweet) drop ;
|
||||
|
||||
! Timelines
|
||||
<PRIVATE
|
||||
|
||||
: timeline ( url -- tweets )
|
||||
twitter-url <get-request>
|
||||
twitter-request json>twitter-statuses ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: public-timeline ( -- tweets )
|
||||
"https://twitter.com/statuses/public_timeline.json" <get-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json>twitter-statuses ;
|
||||
"public_timeline" timeline ;
|
||||
|
||||
: friends-timeline ( -- tweets )
|
||||
"https://twitter.com/statuses/friends_timeline.json" <get-request>
|
||||
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 <get-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json>twitter-statuses ;
|
||||
"user_timeline/" prepend timeline ;
|
||||
|
|
Loading…
Reference in New Issue