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 : 8bit>buffer ( bitmap -- array )
  25     [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
  26     [ color-index>> >array ] bi [ swap nth ] with map concat ;
  27
  28 ERROR: bmp-not-supported n ;
  29
  30 : raw-bitmap>buffer ( bitmap -- array )
  31     dup bit-count>>
  32     {
  33         { 32 [ color-index>> ] }
  34         { 24 [ color-index>> ] }
  35         { 16 [ bmp-not-supported ] }
  36         { 8 [ 8bit>buffer ] }
  37         { 4 [ bmp-not-supported ] }
  38         { 2 [ bmp-not-supported ] }
  39         { 1 [ bmp-not-supported ] }
  40     } case >byte-array ;
  41
  42 ERROR: bitmap-magic ;
  43
  44 M: bitmap-magic summary
  45     drop "First two bytes of bitmap stream must be 'BM'" ;
  46
  47 : read2 ( -- n ) 2 read le> ;
  48 : read4 ( -- n ) 4 read le> ;
  49
  50 : parse-file-header ( bitmap -- bitmap )
  51     2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
  52     read4 >>size
  53     read4 >>reserved
  54     read4 >>offset ;
  55
  56 : parse-bitmap-header ( bitmap -- bitmap )
  57     read4 >>header-length
  58     read4 >>width
  59     read4 >>height
  60     read2 >>planes
  61     read2 >>bit-count
  62     read4 >>compression
  63     read4 >>size-image
  64     read4 >>x-pels
  65     read4 >>y-pels
  66     read4 >>color-used
  67     read4 >>color-important ;
  68
  69 : rgb-quads-length ( bitmap -- n )
  70     [ offset>> 14 - ] [ header-length>> ] bi - ;
  71
  72 : color-index-length ( bitmap -- n )
  73     {
  74         [ width>> ]
  75         [ planes>> * ]
  76         [ bit-count>> * 31 + 32 /i 4 * ]
  77         [ height>> abs * ]
  78     } cleave ;
  79
  80 : parse-bitmap ( bitmap -- bitmap )
  81     dup rgb-quads-length read >>rgb-quads
  82     dup color-index-length read >>color-index ;
  83
  84 : load-bitmap-data ( path -- bitmap )
  85     binary [
  86         bitmap new
  87         parse-file-header parse-bitmap-header parse-bitmap
  88     ] with-file-reader ;
  89
  90 : alpha-channel-zero? ( bitmap -- ? )
  91     buffer>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
  92
  93 : process-bitmap-data ( bitmap -- bitmap )
  94     dup raw-bitmap>buffer >>buffer
  95     dup alpha-channel-zero? >>alpha-channel-zero? ;
  96
  97 : load-bitmap ( path -- bitmap )
  98     load-bitmap-data process-bitmap-data ;
  99
 100 : bitmap>image ( bitmap -- bitmap-image )
 101     { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave
 102     bitmap-image new-image ;
 103
 104 M: bitmap-image load-image* ( path bitmap -- bitmap-image )
 105     drop load-bitmap
 106     bitmap>image ;
 107
 108 MACRO: (nbits>bitmap) ( bits -- )
 109     [ -3 shift ] keep '[
 110         bitmap new
 111             2over * _ * >>size-image
 112             swap >>height
 113             swap >>width
 114             swap array-copy [ >>buffer ] [ >>color-index ] bi
 115             _ >>bit-count bitmap>image
 116     ] ;
 117
 118 : bgr>bitmap ( array height width -- bitmap )
 119     24 (nbits>bitmap) ;
 120
 121 : bgra>bitmap ( array height width -- bitmap )
 122     32 (nbits>bitmap) ;
 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 ;