bitmap loading is cleaner
parent
3dda2c2a25
commit
1a8b97e4d9
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue