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

db4
Philipp Winkler 2009-06-04 16:39:35 -07:00
commit 12bb659251
9 changed files with 66 additions and 71 deletions

View File

@ -20,7 +20,6 @@ SYMBOL: AAPL
} 1&& } 1&&
] unit-test ] unit-test
TUPLE: ct1 a ; TUPLE: ct1 a ;
TUPLE: ct2 < ct1 b ; TUPLE: ct2 < ct1 b ;
TUPLE: ct3 < ct2 c ; TUPLE: ct3 < ct2 c ;
@ -41,7 +40,20 @@ CONSTRUCTOR: ct4 ( a b c d -- obj )
initialize-ct3 initialize-ct3
[ 1 + ] change-a ; [ 1 + ] change-a ;
[ 1 ] [ 0 <ct1> a>> ] unit-test [ 1001 ] [ 1000 <ct1> a>> ] unit-test
[ 2 ] [ 0 0 <ct2> a>> ] unit-test [ 2 ] [ 0 0 <ct2> a>> ] unit-test
[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test [ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test [ 3 ] [ 0 0 0 0 <ct4> 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 <rofl> ] unit-test
TUPLE: default { a integer initial: 0 } ;
CONSTRUCTOR: default ( -- obj ) ;
[ 0 ] [ <default> a>> ] unit-test

View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: slots kernel sequences fry accessors parser lexer words USING: accessors assocs classes.tuple effects.parser fry
effects.parser macros generalizations locals classes.tuple generalizations generic.standard kernel lexer locals macros
vocabs generic.standard ; parser sequences slots vocabs words ;
IN: constructors IN: constructors
! An experiment ! An experiment
@ -26,14 +26,13 @@ IN: constructors
[ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ; [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
MACRO:: slots>constructor ( class slots -- quot ) MACRO:: slots>constructor ( class slots -- quot )
slots class class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
all-slots [ name>> ] map slots length
[ '[ _ = ] find drop ] with map params length
[ [ ] count ] [ ] [ length ] tri
'[ '[
_ narray _ _ narray slots swap zip
[ swap over [ nth ] [ drop ] if ] with map params swap assoc-union
_ firstn class boa values _ firstn class boa
] ; ] ;
:: define-constructor ( constructor-word class effect def -- ) :: define-constructor ( constructor-word class effect def -- )
@ -51,3 +50,5 @@ SYNTAX: CONSTRUCTOR:
complete-effect complete-effect
parse-definition parse-definition
define-constructor ; define-constructor ;
"initializers" create-vocab drop

View File

@ -15,7 +15,8 @@ IN: images.bitmap
: write2 ( n -- ) 2 >le write ; : write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ; : write4 ( n -- ) 4 >le write ;
TUPLE: bitmap-image < image ; SINGLETON: bitmap-image
"bmp" bitmap-image register-image-class
TUPLE: loading-bitmap TUPLE: loading-bitmap
magic size reserved1 reserved2 offset header-length width magic size reserved1 reserved2 offset header-length width
@ -212,11 +213,11 @@ ERROR: unknown-bitmap-header n ;
: parse-bitmap ( loading-bitmap -- loading-bitmap ) : parse-bitmap ( loading-bitmap -- loading-bitmap )
dup color-palette-length read >>color-palette dup color-palette-length read >>color-palette
dup size-image>> [ dup size-image>> dup 0 > [
read >>color-index read >>color-index
] [ ] [
dup color-index-length read >>color-index drop dup color-index-length read >>color-index
] if* ; ] if ;
ERROR: unsupported-bitmap-file magic ; ERROR: unsupported-bitmap-file magic ;
@ -247,7 +248,9 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ] [ unknown-component-order ]
} case ; } 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 ] [ loading-bitmap>bytes >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
@ -256,11 +259,6 @@ ERROR: unknown-component-order bitmap ;
[ bitmap>component-order >>component-order ] [ bitmap>component-order >>component-order ]
} cleave ; } cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
swap load-bitmap loading-bitmap>image ;
"bmp" bitmap-image register-image-class
PRIVATE> PRIVATE>
: bitmap>color-index ( bitmap -- byte-array ) : bitmap>color-index ( bitmap -- byte-array )

View File

@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path tuple -- image ) GENERIC: load-image* ( path class -- image )
: make-image ( bitmap -- image )
! bitmap is a sequence of sequences of pixels which are RGBA
<image>
over [ first length ] [ length ] bi 2array >>dim
RGBA >>component-order
swap concat concat B{ } like >>bitmap ;
<PRIVATE <PRIVATE

View File

@ -7,11 +7,13 @@ io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep images.loader ; sequences sequences.deep images.loader ;
QUALIFIED-WITH: bitstreams bs
IN: images.jpeg IN: images.jpeg
QUALIFIED-WITH: bitstreams bs SINGLETON: jpeg-image
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
TUPLE: jpeg-image < image TUPLE: loading-jpeg < image
{ headers } { headers }
{ bitstream } { bitstream }
{ color-info initial: { f f f f } } { color-info initial: { f f f f } }
@ -21,7 +23,7 @@ TUPLE: jpeg-image < image
<PRIVATE <PRIVATE
CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ; CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ; APP JPG COM TEM RES ;
@ -63,7 +65,7 @@ TUPLE: jpeg-color-info
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ; CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
: jpeg> ( -- jpeg-image ) jpeg-image get ; : jpeg> ( -- jpeg-image ) loading-jpeg get ;
: apply-diff ( dc color -- dc' ) : apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ; [ diff>> + dup ] [ (>>diff) ] bi ;
@ -291,9 +293,9 @@ PRIVATE>
binary [ binary [
parse-marker { SOI } assert= parse-marker { SOI } assert=
parse-headers parse-headers
contents <jpeg-image> contents <loading-jpeg>
] with-file-reader ] with-file-reader
dup jpeg-image [ dup loading-jpeg [
baseline-parse baseline-parse
baseline-decompress baseline-decompress
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
@ -302,5 +304,3 @@ PRIVATE>
M: jpeg-image load-image* ( path jpeg-image -- bitmap ) M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ; drop load-jpeg ;
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each

View File

@ -7,16 +7,18 @@ IN: images.loader
ERROR: unknown-image-extension extension ; ERROR: unknown-image-extension extension ;
<PRIVATE <PRIVATE
SYMBOL: types SYMBOL: types
types [ H{ } clone ] initialize types [ H{ } clone ] initialize
: image-class ( path -- class ) : image-class ( path -- class )
file-extension >lower types get ?at file-extension >lower types get ?at
[ unknown-image-extension ] unless ; [ unknown-image-extension ] unless ;
PRIVATE> PRIVATE>
: register-image-class ( extension class -- ) : register-image-class ( extension class -- )
swap types get set-at ; swap types get set-at ;
: load-image ( path -- image ) : load-image ( path -- image )
dup image-class new load-image* ; dup image-class load-image* ;

View File

@ -7,11 +7,14 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays
images.loader ; images.loader ;
IN: images.png 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 width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ; filter-method interlace-method uncompressed ;
CONSTRUCTOR: png-image ( -- image ) CONSTRUCTOR: loading-png ( -- image )
V{ } clone >>chunks ; V{ } clone >>chunks ;
TUPLE: png-chunk length type data ; TUPLE: png-chunk length type data ;
@ -105,7 +108,7 @@ ERROR: unimplemented-color-type image ;
: load-png ( path -- image ) : load-png ( path -- image )
binary stream-throws <limited-file-reader> [ binary stream-throws <limited-file-reader> [
<png-image> <loading-png>
read-png-header read-png-header
read-png-chunks read-png-chunks
parse-ihdr-chunk parse-ihdr-chunk
@ -115,5 +118,3 @@ ERROR: unimplemented-color-type image ;
M: png-image load-image* M: png-image load-image*
drop load-png ; drop load-png ;
"png" png-image register-image-class

View File

@ -9,10 +9,10 @@ strings math.vectors specialized-arrays.float locals
images.loader ; images.loader ;
IN: images.tiff IN: images.tiff
TUPLE: tiff-image < image ; SINGLETON: tiff-image
TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next TUPLE: ifd count ifd-entries next
processed-tags strips bitmap ; processed-tags strips bitmap ;
@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ;
[ nip unhandled-ifd-entry swap ] [ nip unhandled-ifd-entry swap ]
} case ; } case ;
: process-ifds ( parsed-tiff -- parsed-tiff ) : process-ifds ( loading-tiff -- loading-tiff )
[ [
[ [
dup ifd-entries>> dup ifd-entries>>
@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ] [ unknown-component-order ]
} case ; } case ;
: normalize-alpha-data ( seq -- byte-array )
B{ } like dup
byte-array>float-array
4 <sliced-groups>
[
dup fourth dup 0 = [
2drop
] [
[ 3 head-slice ] dip '[ _ / ] change-each
] if
] each ;
: handle-alpha-data ( ifd -- ifd ) : handle-alpha-data ( ifd -- ifd )
dup extra-samples find-tag { dup extra-samples find-tag {
{ extra-samples-associated-alpha-data [ ] } { extra-samples-associated-alpha-data [ ] }
@ -508,17 +496,17 @@ ERROR: unknown-component-order ifd ;
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order f ] [ ifd-component-order f ]
[ bitmap>> ] [ bitmap>> ]
} cleave tiff-image boa ; } cleave image boa ;
: tiff>image ( image -- image ) : tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ; ifds>> [ ifd>image ] map first ;
: with-tiff-endianness ( parsed-tiff quot -- ) : with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline [ dup endianness>> ] dip with-endianness ; inline
: load-tiff-ifds ( path -- parsed-tiff ) : load-tiff-ifds ( path -- loading-tiff )
binary [ binary [
<parsed-tiff> <loading-tiff>
read-header [ read-header [
dup ifd-offset>> read-ifds dup ifd-offset>> read-ifds
process-ifds process-ifds
@ -550,10 +538,10 @@ ERROR: unknown-component-order ifd ;
drop "no planar configuration" throw drop "no planar configuration" throw
] if ; ] if ;
: process-tif-ifds ( parsed-tiff -- ) : process-tif-ifds ( loading-tiff -- )
ifds>> [ process-ifd ] each ; ifds>> [ process-ifd ] each ;
: load-tiff ( path -- parsed-tiff ) : load-tiff ( path -- loading-tiff )
[ load-tiff-ifds dup ] keep [ load-tiff-ifds dup ] keep
binary [ binary [
[ process-tif-ifds ] with-tiff-endianness [ process-tif-ifds ] with-tiff-endianness

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Kobi Lurie, Doug Coleman. ! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 images.processing.rotation kernel literals math sequences
tools.test images.processing.rotation.private ; tools.test images.processing.rotation.private ;
IN: images.processing.rotation.tests IN: images.processing.rotation.tests
@ -24,13 +24,13 @@ IN: images.processing.rotation.tests
CONSTANT: pasted-image CONSTANT: pasted-image
$[ $[
"vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
load-image normalize-image clone-image load-image clone-image
] ]
CONSTANT: pasted-image90 CONSTANT: pasted-image90
$[ $[
"vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
load-image normalize-image clone-image load-image clone-image
] ]
CONSTANT: lake-image CONSTANT: lake-image
@ -55,7 +55,7 @@ CONSTANT: lake-image
"vocab:images/processing/rotation/test-bitmaps/small.bmp" "vocab:images/processing/rotation/test-bitmaps/small.bmp"
load-image 90 rotate load-image 90 rotate
"vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp" "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
load-image normalize-image = load-image =
] unit-test ] unit-test
[ t ] [ [ t ] [