From 7734042b5880e80e7d1aca0edb814aafa43aa8b9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 14:57:10 -0500 Subject: [PATCH 1/6] use initial values in constructors when approriate --- basis/constructors/constructors-tests.factor | 16 ++++++++++++++-- basis/constructors/constructors.factor | 19 +++++++++---------- 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index af1a879ee3..271e173718 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -20,7 +20,6 @@ SYMBOL: AAPL } 1&& ] unit-test - TUPLE: ct1 a ; TUPLE: ct2 < ct1 b ; TUPLE: ct3 < ct2 c ; @@ -41,7 +40,20 @@ CONSTRUCTOR: ct4 ( a b c d -- obj ) initialize-ct3 [ 1 + ] change-a ; -[ 1 ] [ 0 a>> ] unit-test +[ 1001 ] [ 1000 a>> ] unit-test [ 2 ] [ 0 0 a>> ] unit-test [ 2 ] [ 0 0 0 a>> ] unit-test [ 3 ] [ 0 0 0 0 a>> ] unit-test + + +TUPLE: rofl a b c ; +CONSTRUCTOR: rofl ( b c a -- obj ) ; + +[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 ] unit-test + + +TUPLE: default { a integer initial: 0 } ; + +CONSTRUCTOR: default ( -- obj ) ; + +[ 0 ] [ a>> ] unit-test diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index b08ac0cda3..c2a7d828c9 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: slots kernel sequences fry accessors parser lexer words -effects.parser macros generalizations locals classes.tuple -vocabs generic.standard ; +USING: accessors assocs classes.tuple effects.parser fry +generalizations generic.standard kernel lexer locals macros +parser sequences slots vocabs words ; IN: constructors ! An experiment @@ -26,14 +26,13 @@ IN: constructors [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ; MACRO:: slots>constructor ( class slots -- quot ) - slots class - all-slots [ name>> ] map - [ '[ _ = ] find drop ] with map - [ [ ] count ] [ ] [ length ] tri + class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params + slots length + params length '[ - _ narray _ - [ swap over [ nth ] [ drop ] if ] with map - _ firstn class boa + _ narray slots swap zip + params swap assoc-union + values _ firstn class boa ] ; :: define-constructor ( constructor-word class effect def -- ) From 580ff7fd324d8fe1ffed2cadc2ede25549b50952 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 15:06:33 -0500 Subject: [PATCH 2/6] fix loading of bitmaps when computed size is 0 --- basis/images/bitmap/bitmap.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 151c12132b..2ee7c2514c 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -212,11 +212,11 @@ ERROR: unknown-bitmap-header n ; : parse-bitmap ( loading-bitmap -- loading-bitmap ) dup color-palette-length read >>color-palette - dup size-image>> [ + dup size-image>> dup 0 > [ read >>color-index ] [ - dup color-index-length read >>color-index - ] if* ; + drop dup color-index-length read >>color-index + ] if ; ERROR: unsupported-bitmap-file magic ; From 3c8ce48e3c3ebbbc418cd3d415fb83ea608ed8b7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 15:09:25 -0500 Subject: [PATCH 3/6] don't normalize images in processing.rotation. this means there are some padding bytes to deal with --- extra/images/processing/rotation/rotation-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor index 493f09b145..9d9e72a205 100755 --- a/extra/images/processing/rotation/rotation-tests.factor +++ b/extra/images/processing/rotation/rotation-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Kobi Lurie, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors fry images.loader images.normalization +USING: accessors fry images.loader images.processing.rotation kernel literals math sequences tools.test images.processing.rotation.private ; IN: images.processing.rotation.tests @@ -24,13 +24,13 @@ IN: images.processing.rotation.tests CONSTANT: pasted-image $[ "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" - load-image normalize-image clone-image + load-image clone-image ] CONSTANT: pasted-image90 $[ "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" - load-image normalize-image clone-image + load-image clone-image ] CONSTANT: lake-image @@ -55,7 +55,7 @@ CONSTANT: lake-image "vocab:images/processing/rotation/test-bitmaps/small.bmp" load-image 90 rotate "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp" - load-image normalize-image = + load-image = ] unit-test [ t ] [ From a0b01a51b784b85b8553fd169c59d13c0d71ea11 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 15:30:17 -0500 Subject: [PATCH 4/6] create initializers vocab when constructors is used. this should really go in bootstrap instead --- basis/constructors/constructors.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index c2a7d828c9..e6982e3d98 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -50,3 +50,5 @@ SYNTAX: CONSTRUCTOR: complete-effect parse-definition define-constructor ; + +"initializers" create-vocab drop From a3f0c6c057b6a579f9c316a013f248e1cf25865c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 16:09:38 -0500 Subject: [PATCH 5/6] use singletons instead of subclassing the image class --- basis/images/bitmap/bitmap.factor | 12 +++++------- basis/images/images.factor | 9 +-------- basis/images/jpeg/jpeg.factor | 16 ++++++++-------- basis/images/loader/loader.factor | 4 +++- basis/images/png/png.factor | 13 +++++++------ basis/images/tiff/tiff.factor | 16 ++-------------- 6 files changed, 26 insertions(+), 44 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 2ee7c2514c..4f2ad720b6 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -15,7 +15,8 @@ IN: images.bitmap : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; -TUPLE: bitmap-image < image ; +SINGLETON: bitmap-image +"bmp" bitmap-image register-image-class TUPLE: loading-bitmap magic size reserved1 reserved2 offset header-length width @@ -247,7 +248,9 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: loading-bitmap>image ( image loading-bitmap -- bitmap-image ) +M: bitmap-image load-image* ( path bitmap-image -- bitmap ) + drop load-bitmap + [ image new ] dip { [ loading-bitmap>bytes >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] @@ -256,11 +259,6 @@ ERROR: unknown-component-order bitmap ; [ bitmap>component-order >>component-order ] } cleave ; -M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - swap load-bitmap loading-bitmap>image ; - -"bmp" bitmap-image register-image-class - PRIVATE> : bitmap>color-index ( bitmap -- byte-array ) diff --git a/basis/images/images.factor b/basis/images/images.factor index 62c4f7e2ed..4c76b85459 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ; -GENERIC: load-image* ( path tuple -- image ) - -: make-image ( bitmap -- image ) - ! bitmap is a sequence of sequences of pixels which are RGBA - - over [ first length ] [ length ] bi 2array >>dim - RGBA >>component-order - swap concat concat B{ } like >>bitmap ; +GENERIC: load-image* ( path class -- image ) ( -- jpeg-image ) jpeg-image get ; +: jpeg> ( -- jpeg-image ) loading-jpeg get ; : apply-diff ( dc color -- dc' ) [ diff>> + dup ] [ (>>diff) ] bi ; @@ -291,9 +293,9 @@ PRIVATE> binary [ parse-marker { SOI } assert= parse-headers - contents + contents ] with-file-reader - dup jpeg-image [ + dup loading-jpeg [ baseline-parse baseline-decompress jpeg> bitmap>> 3 [ color-transform ] change-each @@ -302,5 +304,3 @@ PRIVATE> M: jpeg-image load-image* ( path jpeg-image -- bitmap ) drop load-jpeg ; - -{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 19f2fd12c8..51d4e0fadf 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -7,16 +7,18 @@ IN: images.loader ERROR: unknown-image-extension extension ; lower types get ?at [ unknown-image-extension ] unless ; + PRIVATE> : register-image-class ( extension class -- ) swap types get set-at ; : load-image ( path -- image ) - dup image-class new load-image* ; + dup image-class load-image* ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index b8a9a1d569..fd5e36e212 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -7,12 +7,15 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays images.loader ; IN: images.png -TUPLE: png-image < image chunks +SINGLETON: png-image +"png" png-image register-image-class + +TUPLE: loading-png < image chunks width height bit-depth color-type compression-method filter-method interlace-method uncompressed ; -CONSTRUCTOR: png-image ( -- image ) -V{ } clone >>chunks ; +CONSTRUCTOR: loading-png ( -- image ) + V{ } clone >>chunks ; TUPLE: png-chunk length type data ; @@ -105,7 +108,7 @@ ERROR: unimplemented-color-type image ; : load-png ( path -- image ) binary stream-throws [ - + read-png-header read-png-chunks parse-ihdr-chunk @@ -115,5 +118,3 @@ ERROR: unimplemented-color-type image ; M: png-image load-image* drop load-png ; - -"png" png-image register-image-class diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c98f737b11..6b2de12d51 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -9,7 +9,7 @@ strings math.vectors specialized-arrays.float locals images.loader ; IN: images.tiff -TUPLE: tiff-image < image ; +SINGLETON: tiff-image TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; @@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ; [ unknown-component-order ] } case ; -: normalize-alpha-data ( seq -- byte-array ) - B{ } like dup - byte-array>float-array - 4 - [ - dup fourth dup 0 = [ - 2drop - ] [ - [ 3 head-slice ] dip '[ _ / ] change-each - ] if - ] each ; - : handle-alpha-data ( ifd -- ifd ) dup extra-samples find-tag { { extra-samples-associated-alpha-data [ ] } @@ -508,7 +496,7 @@ ERROR: unknown-component-order ifd ; [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order f ] [ bitmap>> ] - } cleave tiff-image boa ; + } cleave image boa ; : tiff>image ( image -- image ) ifds>> [ ifd>image ] map first ; From 60a0170e380ff2b5226a67ef23b3805ea731690a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Jun 2009 16:17:26 -0500 Subject: [PATCH 6/6] renamd parsed-tiff to loading-tiff --- basis/images/tiff/tiff.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 6b2de12d51..876076e9fe 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -11,8 +11,8 @@ IN: images.tiff SINGLETON: tiff-image -TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; -CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; +TUPLE: loading-tiff endianness the-answer ifd-offset ifds ; +CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next processed-tags strips bitmap ; @@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ; [ nip unhandled-ifd-entry swap ] } case ; -: process-ifds ( parsed-tiff -- parsed-tiff ) +: process-ifds ( loading-tiff -- loading-tiff ) [ [ dup ifd-entries>> @@ -501,12 +501,12 @@ ERROR: unknown-component-order ifd ; : tiff>image ( image -- image ) ifds>> [ ifd>image ] map first ; -: with-tiff-endianness ( parsed-tiff quot -- ) +: with-tiff-endianness ( loading-tiff quot -- ) [ dup endianness>> ] dip with-endianness ; inline -: load-tiff-ifds ( path -- parsed-tiff ) +: load-tiff-ifds ( path -- loading-tiff ) binary [ - + read-header [ dup ifd-offset>> read-ifds process-ifds @@ -538,10 +538,10 @@ ERROR: unknown-component-order ifd ; drop "no planar configuration" throw ] if ; -: process-tif-ifds ( parsed-tiff -- ) +: process-tif-ifds ( loading-tiff -- ) ifds>> [ process-ifd ] each ; -: load-tiff ( path -- parsed-tiff ) +: load-tiff ( path -- loading-tiff ) [ load-tiff-ifds dup ] keep binary [ [ process-tif-ifds ] with-tiff-endianness