From cdec85dc8f35ba2040db6c3488bc8206dbda7641 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 14:48:28 -0500 Subject: [PATCH] write out bitmaps from arbitrary image tuples --- basis/images/bitmap/bitmap.factor | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index cf16df7d82..64de5a734f 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -130,28 +130,30 @@ MACRO: (nbits>bitmap) ( bits -- ) PRIVATE> -: save-bitmap ( bitmap path -- ) +: bitmap>color-index ( bitmap-array -- byte-array ) + 4 [ 3 head-slice reverse ] map B{ } join ; inline + +: save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write [ - color-index>> length 14 + 40 + write4 + bitmap>> bitmap>color-index length 14 + 40 + write4 0 write4 54 write4 40 write4 ] [ { - [ width>> write4 ] - [ height>> write4 ] - [ planes>> 1 or write2 ] - [ bit-count>> 24 or write2 ] - [ compression>> 0 or write4 ] - [ size-image>> write4 ] - [ x-pels>> 0 or write4 ] - [ y-pels>> 0 or write4 ] - [ color-used>> 0 or write4 ] - [ color-important>> 0 or write4 ] - [ rgb-quads>> write ] - [ color-index>> write ] + [ dim>> first2 [ write4 ] bi@ ] + [ drop 1 write2 ] + [ drop 24 write2 ] + [ drop 0 write4 ] + [ bitmap>> bitmap>color-index length write4 ] + [ drop 0 write4 ] + [ drop 0 write4 ] + [ drop 0 write4 ] + [ drop 0 write4 ] + ! rgb-quads + [ bitmap>> bitmap>color-index write ] } cleave ] bi ] with-file-writer ;