bitmap loading is cleaner

db4
Doug Coleman 2009-03-02 19:38:28 -06:00
parent 3dda2c2a25
commit 1a8b97e4d9
4 changed files with 35 additions and 36 deletions

View File

@ -1,5 +1,5 @@
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
: test-bitmap24 ( -- path )
@ -17,7 +17,7 @@ IN: images.bitmap.tests
[ t ]
[
test-bitmap24
[ binary file-contents ] [ load-bitmap ] bi
[ binary file-contents ] [ load-image ] bi
"test-bitmap24" unique-file
[ 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 ;
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.
! Handles row-reversed bitmaps (their height is negative)
TUPLE: bitmap 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
buffer ;
ERROR: bitmap-magic magic ;
M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ;
<PRIVATE
: array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ;
@ -37,16 +42,11 @@ ERROR: bmp-not-supported n ;
{ 1 [ bmp-not-supported ] }
} 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> ;
: read4 ( -- n ) 4 read le> ;
: 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 >>reserved
read4 >>offset ;
@ -79,17 +79,13 @@ M: bitmap-magic summary
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index ;
: load-bitmap-data ( path -- bitmap )
binary [
bitmap new
parse-file-header parse-bitmap-header parse-bitmap
: load-bitmap-data ( path bitmap -- bitmap )
[ binary ] dip '[
_ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
: process-bitmap-data ( bitmap -- bitmap )
dup raw-bitmap>buffer >>buffer ;
: load-bitmap ( path -- bitmap )
load-bitmap-data process-bitmap-data ;
dup raw-bitmap>buffer >>bitmap ;
ERROR: unknown-component-order bitmap ;
@ -101,15 +97,16 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
: >image ( bitmap -- bitmap-image )
{
[ [ width>> ] [ height>> ] bi 2array ]
[ bitmap>component-order ]
[ buffer>> ]
} cleave bitmap-image boa ;
: fill-image-slots ( bitmap -- bitmap )
dup {
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ bitmap>component-order >>component-order ]
[ bitmap>> >>bitmap ]
} cleave ;
M: bitmap-image load-image* ( path bitmap -- bitmap-image )
drop load-bitmap >image ;
M: bitmap-image load-image* ( path bitmap -- bitmap )
load-bitmap-data process-bitmap-data
fill-image-slots ;
M: bitmap-image normalize-scan-line-order
dup dim>> '[
@ -118,12 +115,12 @@ M: bitmap-image normalize-scan-line-order
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
bitmap new
bitmap-image new
2over * _ * >>size-image
swap >>height
swap >>width
swap array-copy [ >>buffer ] [ >>color-index ] bi
_ >>bit-count >image
swap array-copy [ >>bitmap ] [ >>color-index ] bi
_ >>bit-count fill-image-slots
] ;
: bgr>bitmap ( array height width -- bitmap )
@ -135,11 +132,13 @@ MACRO: (nbits>bitmap) ( bits -- )
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
PRIVATE>
: save-bitmap ( bitmap path -- )
binary [
B{ CHAR: B CHAR: M } write
[
buffer>> length 14 + 40 + write4
color-index>> length 14 + 40 + write4
0 write4
54 write4
40 write4

View File

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

View File

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