From a0491606bc308a7e122589075e61c2b6829ace2b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Feb 2009 14:04:54 -0600 Subject: [PATCH 1/7] 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 2/7] 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 3/7] 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 4/7] 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 From cddb1f6133867dadc103c48a72143929db111c4c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 15 Feb 2009 04:07:05 -0600 Subject: [PATCH 5/7] Fix spelling --- basis/compiler/cfg/builder/builder.factor | 2 +- basis/farkup/farkup.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 9ffe4a6aa0..4b521725fe 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -55,7 +55,7 @@ GENERIC: emit-node ( node -- next ) : begin-word ( -- ) #! 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. ##prologue ##branch diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index a5951a5080..eea30a3040 100755 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -85,10 +85,10 @@ image-link = "[[image:" link-content "|" link-content "]]" simple-link = "[[" link-content "]]" => [[ 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 ]] -link = image-link | labelled-link | simple-link +link = image-link | labeled-link | simple-link escaped-char = "\" . => [[ second 1string ]] From 3df54221518a53938d6ae09bbf312f677364b4a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 15 Feb 2009 09:13:53 -0600 Subject: [PATCH 6/7] add support for parsing all baseline tiff tags, fix loading a tiff that used to work --- basis/images/tiff/tiff.factor | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c3505ebec4..2d477508d3 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -117,10 +117,13 @@ 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 software -date-time photoshop exif-ifd sub-ifd inter-color-profile +samples-per-pixel new-subfile-type subfile-type orientation +software date-time photoshop exif-ifd sub-ifd inter-color-profile xmp iptc fill-order document-name page-number page-name -x-position y-position +x-position y-position host-computer copyright artist +min-sample-value max-sample-value make model cell-width cell-length +gray-response-unit gray-response-curve color-map threshholding +image-description free-offsets free-byte-counts unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; @@ -242,36 +245,53 @@ ERROR: bad-small-ifd-type n ; : process-ifd-entry ( ifd-entry -- value class ) [ ifd-entry-value ] [ tag>> ] bi { { 254 [ new-subfile-type ] } + { 255 [ subfile-type ] } { 256 [ image-width ] } { 257 [ image-length ] } { 258 [ bits-per-sample ] } { 259 [ lookup-compression compression ] } { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 263 [ threshholding ] } + { 264 [ cell-width ] } + { 265 [ cell-length ] } { 266 [ fill-order ] } { 269 [ ascii decode document-name ] } + { 270 [ ascii decode image-description ] } + { 271 [ ascii decode make ] } + { 272 [ ascii decode model ] } { 273 [ strip-offsets ] } { 274 [ orientation ] } { 277 [ samples-per-pixel ] } { 278 [ rows-per-strip ] } { 279 [ strip-byte-counts ] } + { 280 [ min-sample-value ] } + { 281 [ max-sample-value ] } { 282 [ first x-resolution ] } { 283 [ first y-resolution ] } { 284 [ planar-configuration ] } { 285 [ page-name ] } { 286 [ x-position ] } { 287 [ y-position ] } + { 288 [ free-offsets ] } + { 289 [ free-byte-counts ] } + { 290 [ gray-response-unit ] } + { 291 [ gray-response-curve ] } { 296 [ lookup-resolution-unit resolution-unit ] } { 297 [ page-number ] } { 305 [ ascii decode software ] } { 306 [ ascii decode date-time ] } + { 315 [ ascii decode artist ] } + { 316 [ ascii decode host-computer ] } { 317 [ lookup-predictor predictor ] } + { 320 [ color-map ] } { 330 [ sub-ifd ] } { 338 [ lookup-extra-samples extra-samples ] } { 339 [ lookup-sample-format sample-format ] } { 700 [ utf8 decode xmp ] } + { 33432 [ copyright ] } + { 33723 [ iptc ] } { 34377 [ photoshop ] } { 34665 [ exif-ifd ] } - { 33723 [ iptc ] } { 34675 [ inter-color-profile ] } [ nip unhandled-ifd-entry swap ] } case ; @@ -361,6 +381,8 @@ ERROR: unknown-component-order ifd ; ] } { extra-samples-unspecified-alpha-data [ ] } + { extra-samples-unassociated-alpha-data [ + ] } [ bad-extra-samples ] } case ; From 5ef7afcbb34f47c123763e1a4bc2f570a96b7213 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 15 Feb 2009 10:42:36 -0600 Subject: [PATCH 7/7] refactor tiff loading a bit, identify lots of ifd header tags --- basis/images/tiff/tiff.factor | 174 +++++++++++++++++++++++++++++----- 1 file changed, 152 insertions(+), 22 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 2d477508d3..02440deea5 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -24,7 +24,16 @@ SINGLETONS: photometric-interpretation photometric-interpretation-white-is-zero photometric-interpretation-black-is-zero photometric-interpretation-rgb -photometric-interpretation-palette-color ; +photometric-interpretation-palette-color +photometric-interpretation-transparency-mask +photometric-interpretation-separated +photometric-interpretation-ycbcr +photometric-interpretation-cielab +photometric-interpretation-icclab +photometric-interpretation-itulab +photometric-interpretation-logl +photometric-interpretation-logluv ; + ERROR: bad-photometric-interpretation n ; : lookup-photometric-interpretation ( n -- singleton ) { @@ -32,21 +41,73 @@ ERROR: bad-photometric-interpretation n ; { 1 [ photometric-interpretation-black-is-zero ] } { 2 [ photometric-interpretation-rgb ] } { 3 [ photometric-interpretation-palette-color ] } + { 4 [ photometric-interpretation-transparency-mask ] } + { 5 [ photometric-interpretation-separated ] } + { 6 [ photometric-interpretation-ycbcr ] } + { 8 [ photometric-interpretation-cielab ] } + { 9 [ photometric-interpretation-icclab ] } + { 10 [ photometric-interpretation-itulab ] } + { 32844 [ photometric-interpretation-logl ] } + { 32845 [ photometric-interpretation-logluv ] } [ bad-photometric-interpretation ] } case ; SINGLETONS: compression compression-none compression-CCITT-2 +compression-CCITT-3 +compression-CCITT-4 compression-lzw -compression-pack-bits ; +compression-jpeg-old +compression-jpeg-new +compression-adobe-deflate +compression-9 +compression-10 +compression-deflate +compression-next +compression-ccittrlew +compression-pack-bits +compression-thunderscan +compression-it8ctpad +compression-it8lw +compression-it8mp +compression-it8bl +compression-pixarfilm +compression-pixarlog +compression-dcs +compression-jbig +compression-sgilog +compression-sgilog24 +compression-jp2000 ; ERROR: bad-compression n ; : lookup-compression ( n -- compression ) { { 1 [ compression-none ] } { 2 [ compression-CCITT-2 ] } + { 3 [ compression-CCITT-3 ] } + { 4 [ compression-CCITT-4 ] } { 5 [ compression-lzw ] } + { 6 [ compression-jpeg-old ] } + { 7 [ compression-jpeg-new ] } + { 8 [ compression-adobe-deflate ] } + { 9 [ compression-9 ] } + { 10 [ compression-10 ] } + { 32766 [ compression-next ] } + { 32771 [ compression-ccittrlew ] } { 32773 [ compression-pack-bits ] } + { 32809 [ compression-thunderscan ] } + { 32895 [ compression-it8ctpad ] } + { 32896 [ compression-it8lw ] } + { 32897 [ compression-it8mp ] } + { 32898 [ compression-it8bl ] } + { 32908 [ compression-pixarfilm ] } + { 32909 [ compression-pixarlog ] } + { 32946 [ compression-deflate ] } + { 32947 [ compression-dcs ] } + { 34661 [ compression-jbig ] } + { 34676 [ compression-sgilog ] } + { 34677 [ compression-sgilog24 ] } + { 34712 [ compression-jp2000 ] } [ bad-compression ] } case ; @@ -86,6 +147,7 @@ ERROR: bad-planar-configuration n ; } case ; SINGLETONS: sample-format +sample-format-none sample-format-unsigned-integer sample-format-signed-integer sample-format-ieee-float @@ -94,6 +156,7 @@ ERROR: bad-sample-format n ; : lookup-sample-format ( sequence -- object ) [ { + { 0 [ sample-format-none ] } { 1 [ sample-format-unsigned-integer ] } { 2 [ sample-format-signed-integer ] } { 3 [ sample-format-ieee-float ] } @@ -123,9 +186,31 @@ xmp iptc fill-order document-name page-number page-name x-position y-position host-computer copyright artist min-sample-value max-sample-value make model cell-width cell-length gray-response-unit gray-response-curve color-map threshholding -image-description free-offsets free-byte-counts +image-description free-offsets free-byte-counts tile-width tile-length +matteing data-type image-depth tile-depth +ycbcr-subsampling gdal-metadata +tile-offsets tile-byte-counts jpeg-qtables jpeg-dctables jpeg-actables +ycbcr-positioning ycbcr-coefficients reference-black-white halftone-hints +jpeg-interchange-format +jpeg-interchange-format-length +jpeg-restart-interval jpeg-tables +t4-options clean-fax-data bad-fax-lines consecutive-bad-fax-lines +sto-nits print-image-matching-info unhandled-ifd-entry ; +SINGLETONS: jpeg-proc +jpeg-proc-baseline +jpeg-proc-lossless ; + +ERROR: bad-jpeg-proc n ; + +: lookup-jpeg-proc ( sequence -- object ) + { + { 1 [ jpeg-proc-baseline ] } + { 14 [ jpeg-proc-lossless ] } + [ bad-jpeg-proc ] + } case ; + ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) { @@ -149,12 +234,12 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> 4 read endian> ; -: read-ifds ( tiff -- tiff ) - dup ifd-offset>> seek-absolute seek-input +: read-ifds ( tiff offset -- tiff ) + seek-absolute seek-input 2 read endian> dup [ read-ifd ] replicate 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + [ push-ifd ] [ dup 0 = [ drop ] [ read-ifds ] if ] bi ; ERROR: no-tag class ; @@ -276,6 +361,7 @@ ERROR: bad-small-ifd-type n ; { 289 [ free-byte-counts ] } { 290 [ gray-response-unit ] } { 291 [ gray-response-curve ] } + { 292 [ t4-options ] } { 296 [ lookup-resolution-unit resolution-unit ] } { 297 [ page-number ] } { 305 [ ascii decode software ] } @@ -284,21 +370,52 @@ ERROR: bad-small-ifd-type n ; { 316 [ ascii decode host-computer ] } { 317 [ lookup-predictor predictor ] } { 320 [ color-map ] } + { 321 [ halftone-hints ] } + { 322 [ tile-width ] } + { 323 [ tile-length ] } + { 324 [ tile-offsets ] } + { 325 [ tile-byte-counts ] } + { 326 [ bad-fax-lines ] } + { 327 [ clean-fax-data ] } + { 328 [ consecutive-bad-fax-lines ] } { 330 [ sub-ifd ] } { 338 [ lookup-extra-samples extra-samples ] } { 339 [ lookup-sample-format sample-format ] } + { 347 [ jpeg-tables ] } + { 512 [ lookup-jpeg-proc jpeg-proc ] } + { 513 [ jpeg-interchange-format ] } + { 514 [ jpeg-interchange-format-length ] } + { 515 [ jpeg-restart-interval ] } + { 519 [ jpeg-qtables ] } + { 520 [ jpeg-dctables ] } + { 521 [ jpeg-actables ] } + { 529 [ ycbcr-coefficients ] } + { 530 [ ycbcr-subsampling ] } + { 531 [ ycbcr-positioning ] } + { 532 [ reference-black-white ] } { 700 [ utf8 decode xmp ] } + { 32995 [ matteing ] } + { 32996 [ data-type ] } + { 32997 [ image-depth ] } + { 32998 [ tile-depth ] } { 33432 [ copyright ] } { 33723 [ iptc ] } { 34377 [ photoshop ] } { 34665 [ exif-ifd ] } { 34675 [ inter-color-profile ] } + { 37439 [ sto-nits ] } + { 42112 [ gdal-metadata ] } + { 50341 [ print-image-matching-info ] } [ nip unhandled-ifd-entry swap ] } case ; -: process-ifd ( ifd -- ifd ) - dup ifd-entries>> - [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; +: process-ifds ( parsed-tiff -- parsed-tiff ) + [ + [ + dup ifd-entries>> + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags + ] map + ] change-ifds ; ERROR: unhandled-compression compression ; @@ -396,23 +513,36 @@ ERROR: unknown-component-order ifd ; : tiff>image ( image -- image ) ifds>> [ ifd>image ] map first ; -: load-tiff ( path -- parsed-tiff ) +: with-tiff-endianness ( parsed-tiff quot -- ) + [ dup endianness>> ] dip with-endianness ; inline + +: load-tiff-ifds ( path -- parsed-tiff ) binary [ - read-header dup endianness>> [ - read-ifds - dup ifds>> [ - process-ifd read-strips - uncompress-strips - strips>bitmap - fix-bitmap-endianness - strips-predictor - dup extra-samples tag? [ handle-alpha-data ] when - drop - ] each - ] with-endianness + read-header [ + dup ifd-offset>> read-ifds + process-ifds + ] with-tiff-endianness ] with-file-reader ; +: process-tif-ifds ( parsed-tiff -- parsed-tiff ) + dup ifds>> [ + read-strips + uncompress-strips + strips>bitmap + fix-bitmap-endianness + strips-predictor + dup extra-samples tag? [ handle-alpha-data ] when + drop + ] each ; + +: load-tiff ( path -- parsed-tiff ) + [ load-tiff-ifds ] [ + binary [ + [ process-tif-ifds ] with-tiff-endianness + ] with-file-reader + ] bi ; + ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) drop load-tiff tiff>image ;