Merge branch 'master' into new_ui

db4
Slava Pestov 2009-02-15 04:07:51 -06:00
commit 634435d816
6 changed files with 46 additions and 7 deletions

View File

@ -55,7 +55,7 @@ GENERIC: emit-node ( node -- next )
: begin-word ( -- ) : begin-word ( -- )
#! We store the basic block after the prologue as a loop #! We store the basic block after the prologue as a loop
#! labelled by the current word, so that self-recursive #! labeled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue. #! calls can skip an epilogue/prologue.
##prologue ##prologue
##branch ##branch

View File

@ -85,10 +85,10 @@ image-link = "[[image:" link-content "|" link-content "]]"
simple-link = "[[" link-content "]]" simple-link = "[[" link-content "]]"
=> [[ second >string dup simple-link-title link boa ]] => [[ second >string dup simple-link-title link boa ]]
labelled-link = "[[" link-content "|" link-content "]]" labeled-link = "[[" link-content "|" link-content "]]"
=> [[ [ second >string ] [ fourth >string ] bi link boa ]] => [[ [ second >string ] [ fourth >string ] bi link boa ]]
link = image-link | labelled-link | simple-link link = image-link | labeled-link | simple-link
escaped-char = "\" . escaped-char = "\" .
=> [[ second 1string ]] => [[ second 1string ]]

View File

@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences math.bitwise math.order math.parser pack prettyprint sequences
strings math.vectors ; strings math.vectors specialized-arrays.float ;
IN: images.tiff IN: images.tiff
TUPLE: tiff-image < image ; TUPLE: tiff-image < image ;
@ -343,6 +343,27 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ] [ unknown-component-order ]
} case ; } 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 ) : ifd>image ( ifd -- image )
{ {
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
@ -364,6 +385,7 @@ ERROR: unknown-component-order ifd ;
strips>bitmap strips>bitmap
fix-bitmap-endianness fix-bitmap-endianness
strips-predictor strips-predictor
dup extra-samples tag? [ handle-alpha-data ] when
drop drop
] each ] each
] with-endianness ] with-endianness

View File

@ -57,6 +57,13 @@ HELP: with-system-random
{ with-random with-secure-random with-system-random } related-words { 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 HELP: delete-random
{ $values { $values
{ "seq" sequence } { "seq" sequence }
@ -83,6 +90,8 @@ $nl
{ $subsection with-secure-random } { $subsection with-secure-random }
"Implementation:" "Implementation:"
{ $subsection "random-protocol" } { $subsection "random-protocol" }
"Randomizing a sequence:"
{ $subsection randomize }
"Deleting a random element from a sequence:" "Deleting a random element from a sequence:"
{ $subsection delete-random } ; { $subsection delete-random } ;

View File

@ -1,5 +1,5 @@
USING: random sequences tools.test kernel math math.functions USING: random sequences tools.test kernel math math.functions
sets ; sets grouping random.private ;
IN: random.tests IN: random.tests
[ 4 ] [ 4 random-bytes length ] unit-test [ 4 ] [ 4 random-bytes length ] unit-test
@ -17,3 +17,9 @@ IN: random.tests
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test [ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
[ f ] [ 0 random ] 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

View File

@ -52,8 +52,10 @@ PRIVATE>
[ length random-integer ] keep nth [ length random-integer ] keep nth
] if-empty ; ] 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 ) : delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ; [ length random-integer ] keep [ nth ] 2keep delete-nth ;