basis/images/bitmap/bitmap.factor

   1 ! Copyright (C) 2007, 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types arrays byte-arrays columns
   4 combinators fry grouping io io.binary io.encodings.binary io.files
   5 kernel macros math math.bitwise math.functions namespaces sequences
   6 strings images endian summary ;
   7 IN: images.bitmap
   8
   9 TUPLE: bitmap-image < image ;
  10
  11 ! Currently can only handle 24/32bit bitmaps.
  12 ! Handles row-reversed bitmaps (their height is negative)
  13
  14 TUPLE: bitmap magic size reserved offset header-length width
  15 height planes bit-count compression size-image
  16 x-pels y-pels color-used color-important rgb-quads color-index
  17 buffer ;
  18
  19 : array-copy ( bitmap array -- bitmap array' )
  20     over size-image>> abs memory>byte-array ;
  21
  22 : 8bit>buffer ( bitmap -- array )
  23     [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
  24     [ color-index>> >array ] bi [ swap nth ] with map concat ;
  25
  26 ERROR: bmp-not-supported n ;
  27
  28 : raw-bitmap>buffer ( bitmap -- array )
  29     dup bit-count>>
  30     {
  31         { 32 [ color-index>> ] }
  32         { 24 [ color-index>> ] }
  33         { 16 [ bmp-not-supported ] }
  34         { 8 [ 8bit>buffer ] }
  35         { 4 [ bmp-not-supported ] }
  36         { 2 [ bmp-not-supported ] }
  37         { 1 [ bmp-not-supported ] }
  38     } case >byte-array ;
  39
  40 ERROR: bitmap-magic ;
  41
  42 M: bitmap-magic summary
  43     drop "First two bytes of bitmap stream must be 'BM'" ;
  44
  45 : read2 ( -- n ) 2 read le> ;
  46 : read4 ( -- n ) 4 read le> ;
  47
  48 : parse-file-header ( bitmap -- bitmap )
  49     2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
  50     read4 >>size
  51     read4 >>reserved
  52     read4 >>offset ;
  53
  54 : parse-bitmap-header ( bitmap -- bitmap )
  55     read4 >>header-length
  56     read4 >>width
  57     read4 >>height
  58     read2 >>planes
  59     read2 >>bit-count
  60     read4 >>compression
  61     read4 >>size-image
  62     read4 >>x-pels
  63     read4 >>y-pels
  64     read4 >>color-used
  65     read4 >>color-important ;
  66
  67 : rgb-quads-length ( bitmap -- n )
  68     [ offset>> 14 - ] [ header-length>> ] bi - ;
  69
  70 : color-index-length ( bitmap -- n )
  71     {
  72         [ width>> ]
  73         [ planes>> * ]
  74         [ bit-count>> * 31 + 32 /i 4 * ]
  75         [ height>> abs * ]
  76     } cleave ;
  77
  78 : parse-bitmap ( bitmap -- bitmap )
  79     dup rgb-quads-length read >>rgb-quads
  80     dup color-index-length read >>color-index ;
  81
  82 : load-bitmap-data ( path -- bitmap )
  83     binary [
  84         bitmap new
  85         parse-file-header parse-bitmap-header parse-bitmap
  86     ] with-file-reader ;
  87
  88 : process-bitmap-data ( bitmap -- bitmap )
  89     dup raw-bitmap>buffer >>buffer ;
  90
  91 : load-bitmap ( path -- bitmap )
  92     load-bitmap-data process-bitmap-data ;
  93
  94 ERROR: unknown-component-order bitmap ;
  95
  96 : bitmap>component-order ( bitmap -- object )
  97     bit-count>> {
  98         { 32 [ BGRA ] }
  99         { 24 [ BGR ] }
 100         { 8 [ BGR ] }
 101         [ unknown-component-order ]
 102     } case ;
 103
 104 : >image ( bitmap -- bitmap-image )
 105     {
 106         [ [ width>> ] [ height>> ] bi 2array ]
 107         [ bitmap>component-order ]
 108         [ buffer>> ]
 109     } cleave bitmap-image boa ;
 110
 111 M: bitmap-image load-image* ( path bitmap -- bitmap-image )
 112     drop load-bitmap >image ;
 113
 114 M: bitmap-image normalize-scan-line-order
 115     dup dim>> '[
 116         _ first 4 * <sliced-groups> reverse concat
 117     ] change-bitmap ;
 118
 119 MACRO: (nbits>bitmap) ( bits -- )
 120     [ -3 shift ] keep '[
 121         bitmap new
 122             2over * _ * >>size-image
 123             swap >>height
 124             swap >>width
 125             swap array-copy [ >>buffer ] [ >>color-index ] bi
 126             _ >>bit-count >image
 127     ] ;
 128
 129 : bgr>bitmap ( array height width -- bitmap )
 130     24 (nbits>bitmap) ;
 131
 132 : bgra>bitmap ( array height width -- bitmap )
 133     32 (nbits>bitmap) ;
 134
 135 : write2 ( n -- ) 2 >le write ;
 136 : write4 ( n -- ) 4 >le write ;
 137
 138 : save-bitmap ( bitmap path -- )
 139     binary [
 140         B{ CHAR: B CHAR: M } write
 141         [
 142             buffer>> length 14 + 40 + write4
 143             0 write4
 144             54 write4
 145             40 write4
 146         ] [
 147             {
 148                 [ width>> write4 ]
 149                 [ height>> write4 ]
 150                 [ planes>> 1 or write2 ]
 151                 [ bit-count>> 24 or write2 ]
 152                 [ compression>> 0 or write4 ]
 153                 [ size-image>> write4 ]
 154                 [ x-pels>> 0 or write4 ]
 155                 [ y-pels>> 0 or write4 ]
 156                 [ color-used>> 0 or write4 ]
 157                 [ color-important>> 0 or write4 ]
 158                 [ rgb-quads>> write ]
 159                 [ color-index>> write ]
 160             } cleave
 161         ] bi
 162     ] with-file-writer ;