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

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

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 <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 [
-            [
+            [ normalize-floats add-dummy-alpha ] change-bitmap
-                dup length 4 / <direct-uint-array>
+        ] }
-                [ bits>float 255.0 * >integer ] map
+        { R16G16B16A16 [
-                >byte-array add-dummy-alpha
+            [ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap
-            ] change-bitmap
         ] }
         { R16G16B16 [
             [
-                dup length 2 / <direct-ushort-array>
+                byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha
-                [ -8 shift ] map
-                >byte-array 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
         ] }

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

basis/math/bitwise/bitwise.factor

@@ -102,3 +102,7 @@ PRIVATE>
 
 : signed-be> ( bytes -- x )
     <reversed> signed-le> ;
+
+: >signed ( x n -- y )
+    2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
+

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

basis/random/random-tests.factor

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

basis/random/random.factor

@@ -52,8 +52,10 @@ PRIVATE>
         [ length random-integer ] keep nth
     ] if-empty ;
 
-: randomize ( seq -- seq' )
+: randomize ( seq -- seq )
-    dup length 1 (a,b] [ dup random pick exchange ] each ;
+    dup length [ dup 1 > ]
+    [ [ random ] [ 1- ] bi [ pick exchange ] keep ]
+    [ ] while drop ;
 
 : delete-random ( seq -- elt )
     [ length random-integer ] keep [ nth ] 2keep delete-nth ;

extra/twitter/twitter.factor

@@ -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 -- )
+<PRIVATE
-    [ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
 
 : <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 -- )
+PRIVATE>
-    [ twitter-username set ] [ twitter-password set ] bi* ; 
 
-: set-request-twitter-auth ( request -- request )
+! Updates
-    twitter-username twitter-password [ get ] bi@ set-basic-auth ;
+<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>
+    update-post-data "update" twitter-url
-        set-request-twitter-auth 
+    <post-request> twitter-request ;
-    http-request nip ;
+
+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>
+    "public_timeline" timeline ;
-        set-request-twitter-auth
-    http-request nip json>twitter-statuses ;
 
 : friends-timeline ( -- tweets )
-    "https://twitter.com/statuses/friends_timeline.json" <get-request>
+    "friends_timeline" timeline ;
-        set-request-twitter-auth
-    http-request nip json>twitter-statuses ;
 
 : user-timeline ( username -- tweets )
-    "https://twitter.com/statuses/user_timeline/" ".json" surround <get-request>
+    "user_timeline/" prepend timeline ;
-        set-request-twitter-auth
-    http-request nip json>twitter-statuses ;