steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

support loading bitmaps that have extra padding bytes on each line, like reference.bmp

db4
Doug Coleman 2009-03-15 15:08:55 -05:00
parent 2698c30a30
commit 3a0b0aff79
1 changed files with 22 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
basis/images/bitmap/bitmap.factor
View File

@ -3,7 +3,7 @@
USING: accessors alien alien.c-types arrays byte-arrays columns USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary io.files combinators fry grouping io io.binary io.encodings.binary io.files
kernel macros math math.bitwise math.functions namespaces sequences kernel macros math math.bitwise math.functions namespaces sequences
strings images endian summary ; strings images endian summary locals ;
IN: images.bitmap IN: images.bitmap
: assert-sequence= ( a b -- ) : assert-sequence= ( a b -- )
@ -78,9 +78,28 @@ ERROR: bmp-not-supported n ;
[ height>> abs * ] [ height>> abs * ]
} cleave ; } cleave ;
: image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
loading-bitmap width>> :> width
loading-bitmap height>> abs :> height
loading-bitmap color-index>> length :> color-index-length
height 3 * :> height*3
color-index-length width height*3 * - height*3 /i :> misaligned
misaligned 0 > [
loading-bitmap [
loading-bitmap width>> misaligned + 3 * <sliced-groups>
[ 3 misaligned * head* ] map concat
] change-color-index
] [
loading-bitmap
] if ;
: parse-bitmap ( loading-bitmap -- loading-bitmap ) : parse-bitmap ( loading-bitmap -- loading-bitmap )
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
fixup-color-index ;
: load-bitmap-data ( path loading-bitmap -- loading-bitmap ) : load-bitmap-data ( path loading-bitmap -- loading-bitmap )
[ binary ] dip '[ [ binary ] dip '[
@ -102,6 +121,7 @@ ERROR: unknown-component-order bitmap ;
{ {
[ raw-bitmap>seq >>bitmap ] [ raw-bitmap>seq >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ height>> 0 < [ t >>upside-down? ] when ]
[ bitmap>component-order >>component-order ] [ bitmap>component-order >>component-order ]
} cleave ; } cleave ;