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

db4
Daniel Ehrenberg 2009-03-02 23:31:49 -06:00
commit 064bb01cf5
5 changed files with 45 additions and 38 deletions

View File

@ -1,5 +1,5 @@
USING: images.bitmap images.viewer io.encodings.binary USING: images.bitmap images.viewer io.encodings.binary
io.files io.files.unique kernel tools.test ; io.files io.files.unique kernel tools.test images.loader ;
IN: images.bitmap.tests IN: images.bitmap.tests
: test-bitmap24 ( -- path ) : test-bitmap24 ( -- path )
@ -17,7 +17,7 @@ IN: images.bitmap.tests
[ t ] [ t ]
[ [
test-bitmap24 test-bitmap24
[ binary file-contents ] [ load-bitmap ] bi [ binary file-contents ] [ load-image ] bi
"test-bitmap24" unique-file "test-bitmap24" unique-file
[ save-bitmap ] [ binary file-contents ] bi = [ save-bitmap ] [ binary file-contents ] bi =

View File

@ -6,15 +6,20 @@ kernel macros math math.bitwise math.functions namespaces sequences
strings images endian summary ; strings images endian summary ;
IN: images.bitmap IN: images.bitmap
TUPLE: bitmap-image < image ; TUPLE: bitmap-image < image
magic size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index ;
! Currently can only handle 24/32bit bitmaps. ! Currently can only handle 24/32bit bitmaps.
! Handles row-reversed bitmaps (their height is negative) ! Handles row-reversed bitmaps (their height is negative)
TUPLE: bitmap magic size reserved offset header-length width ERROR: bitmap-magic magic ;
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index M: bitmap-magic summary
buffer ; drop "First two bytes of bitmap stream must be 'BM'" ;
<PRIVATE
: array-copy ( bitmap array -- bitmap array' ) : array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ; over size-image>> abs memory>byte-array ;
@ -37,16 +42,11 @@ ERROR: bmp-not-supported n ;
{ 1 [ bmp-not-supported ] } { 1 [ bmp-not-supported ] }
} case >byte-array ; } case >byte-array ;
ERROR: bitmap-magic ;
M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ;
: read2 ( -- n ) 2 read le> ; : read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ; : read4 ( -- n ) 4 read le> ;
: parse-file-header ( bitmap -- bitmap ) : parse-file-header ( bitmap -- bitmap )
2 read >string dup "BM" = [ bitmap-magic ] unless >>magic 2 read dup "BM" sequence= [ bitmap-magic ] unless >>magic
read4 >>size read4 >>size
read4 >>reserved read4 >>reserved
read4 >>offset ; read4 >>offset ;
@ -79,17 +79,13 @@ M: bitmap-magic summary
dup rgb-quads-length read >>rgb-quads dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index ; dup color-index-length read >>color-index ;
: load-bitmap-data ( path -- bitmap ) : load-bitmap-data ( path bitmap -- bitmap )
binary [ [ binary ] dip '[
bitmap new _ parse-file-header parse-bitmap-header parse-bitmap
parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ; ] with-file-reader ;
: process-bitmap-data ( bitmap -- bitmap ) : process-bitmap-data ( bitmap -- bitmap )
dup raw-bitmap>buffer >>buffer ; dup raw-bitmap>buffer >>bitmap ;
: load-bitmap ( path -- bitmap )
load-bitmap-data process-bitmap-data ;
ERROR: unknown-component-order bitmap ; ERROR: unknown-component-order bitmap ;
@ -101,15 +97,16 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ] [ unknown-component-order ]
} case ; } case ;
: >image ( bitmap -- bitmap-image ) : fill-image-slots ( bitmap -- bitmap )
{ dup {
[ [ width>> ] [ height>> ] bi 2array ] [ [ width>> ] [ height>> ] bi 2array >>dim ]
[ bitmap>component-order ] [ bitmap>component-order >>component-order ]
[ buffer>> ] [ bitmap>> >>bitmap ]
} cleave bitmap-image boa ; } cleave ;
M: bitmap-image load-image* ( path bitmap -- bitmap-image ) M: bitmap-image load-image* ( path bitmap -- bitmap )
drop load-bitmap >image ; load-bitmap-data process-bitmap-data
fill-image-slots ;
M: bitmap-image normalize-scan-line-order M: bitmap-image normalize-scan-line-order
dup dim>> '[ dup dim>> '[
@ -118,12 +115,12 @@ M: bitmap-image normalize-scan-line-order
MACRO: (nbits>bitmap) ( bits -- ) MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[ [ -3 shift ] keep '[
bitmap new bitmap-image new
2over * _ * >>size-image 2over * _ * >>size-image
swap >>height swap >>height
swap >>width swap >>width
swap array-copy [ >>buffer ] [ >>color-index ] bi swap array-copy [ >>bitmap ] [ >>color-index ] bi
_ >>bit-count >image _ >>bit-count fill-image-slots
] ; ] ;
: bgr>bitmap ( array height width -- bitmap ) : bgr>bitmap ( array height width -- bitmap )
@ -135,11 +132,13 @@ MACRO: (nbits>bitmap) ( bits -- )
: write2 ( n -- ) 2 >le write ; : write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ; : write4 ( n -- ) 4 >le write ;
PRIVATE>
: save-bitmap ( bitmap path -- ) : save-bitmap ( bitmap path -- )
binary [ binary [
B{ CHAR: B CHAR: M } write B{ CHAR: B CHAR: M } write
[ [
buffer>> length 14 + 40 + write4 color-index>> length 14 + 40 + write4
0 write4 0 write4
54 write4 54 write4
40 write4 40 write4

View File

@ -68,7 +68,7 @@ GENERIC: load-image* ( path tuple -- image )
[ [
3 <sliced-groups> 3 <sliced-groups>
[ [ 3 head-slice reverse-here ] each ] [ [ 3 head-slice reverse-here ] each ]
[ add-dummy-alpha ] bi [ [ 255 suffix ] map ] bi concat
] change-bitmap ] change-bitmap
] } ] }
} case } case
@ -81,4 +81,4 @@ M: image normalize-scan-line-order ;
: normalize-image ( image -- image ) : normalize-image ( image -- image )
[ >byte-array ] change-bitmap [ >byte-array ] change-bitmap
normalize-component-order normalize-component-order
normalize-scan-line-order ; normalize-scan-line-order ;

View File

@ -5,7 +5,8 @@ strings kernel math io.mmap io.mmap.uchar accessors syntax
combinators math.ranges unicode.categories byte-arrays combinators math.ranges unicode.categories byte-arrays
io.encodings.string io.encodings.utf16 assocs math.parser io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays ; splitting io.encodings.ascii arrays io.files.info unicode.case
io.directories.search ;
IN: id3 IN: id3
<PRIVATE <PRIVATE
@ -179,7 +180,7 @@ PRIVATE>
: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline : id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline
: file-id3-tags ( path -- id3v2-info/f ) : (file-id3-tags) ( path -- id3v2-info/f )
[ [
{ {
{ [ dup id3v2? ] [ read-v2-tag-data ] } { [ dup id3v2? ] [ read-v2-tag-data ] }
@ -187,3 +188,10 @@ PRIVATE>
[ drop f ] [ drop f ]
} cond } cond
] with-mapped-uchar-file ; ] with-mapped-uchar-file ;
: file-id3-tags ( path -- id3v2-info/f )
dup file-info size>> 0 <= [ drop f ] [ (file-id3-tags) ] if ;
: parse-id3s ( path -- seq )
[ >lower ".mp3" tail? ] find-all-files
[ dup file-id3-tags ] { } map>assoc ;

View File

@ -10,7 +10,7 @@ TUPLE: image-gadget < gadget { image image } ;
M: image-gadget pref-dim* M: image-gadget pref-dim*
image>> dim>> ; image>> dim>> ;
: draw-image ( tiff -- ) : draw-image ( image -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
[ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ] [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
[ bitmap>> ] bi glDrawPixels ; [ bitmap>> ] bi glDrawPixels ;