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