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 buffer ;
  19
  20 : array-copy ( bitmap array -- bitmap array' )
  21     over size-image>> abs memory>byte-array ;
  22
  23 : 8bit>buffer ( bitmap -- array )
  24     [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
  25     [ color-index>> >array ] bi [ swap nth ] with map concat ;
  26
  27 ERROR: bmp-not-supported n ;
  28
  29 : raw-bitmap>buffer ( bitmap -- array )
  30     dup bit-count>>
  31     {
  32         { 32 [ color-index>> ] }
  33         { 24 [ color-index>> ] }
  34         { 16 [ bmp-not-supported ] }
  35         { 8 [ 8bit>buffer ] }
  36         { 4 [ bmp-not-supported ] }
  37         { 2 [ bmp-not-supported ] }
  38         { 1 [ bmp-not-supported ] }
  39     } case >byte-array ;
  40
  41 ERROR: bitmap-magic ;
  42
  43 M: bitmap-magic summary
  44     drop "First two bytes of bitmap stream must be 'BM'" ;
  45
  46 : read2 ( -- n ) 2 read le> ;
  47 : read4 ( -- n ) 4 read le> ;
  48
  49 : parse-file-header ( bitmap -- bitmap )
  50     2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
  51     read4 >>size
  52     read4 >>reserved
  53     read4 >>offset ;
  54
  55 : parse-bitmap-header ( bitmap -- bitmap )
  56     read4 >>header-length
  57     read4 >>width
  58     read4 >>height
  59     read2 >>planes
  60     read2 >>bit-count
  61     read4 >>compression
  62     read4 >>size-image
  63     read4 >>x-pels
  64     read4 >>y-pels
  65     read4 >>color-used
  66     read4 >>color-important ;
  67
  68 : rgb-quads-length ( bitmap -- n )
  69     [ offset>> 14 - ] [ header-length>> ] bi - ;
  70
  71 : color-index-length ( bitmap -- n )
  72     {
  73         [ width>> ]
  74         [ planes>> * ]
  75         [ bit-count>> * 31 + 32 /i 4 * ]
  76         [ height>> abs * ]
  77     } cleave ;
  78
  79 : parse-bitmap ( bitmap -- bitmap )
  80     dup rgb-quads-length read >>rgb-quads
  81     dup color-index-length read >>color-index ;
  82
  83 : load-bitmap-data ( path -- bitmap )
  84     binary [
  85         bitmap new
  86         parse-file-header parse-bitmap-header parse-bitmap
  87     ] with-file-reader ;
  88
  89 : process-bitmap-data ( bitmap -- bitmap )
  90     dup raw-bitmap>buffer >>buffer ;
  91
  92 : load-bitmap ( path -- bitmap )
  93     load-bitmap-data process-bitmap-data ;
  94
  95 ERROR: unknown-component-order bitmap ;
  96
  97 : bitmap>component-order ( bitmap -- object )
  98     bit-count>> {
  99         { 32 [ BGRA ] }
 100         { 24 [ BGR ] }
 101         { 8 [ BGR ] }
 102         [ unknown-component-order ]
 103     } case ;
 104
 105 M: bitmap >image ( bitmap -- bitmap-image )
 106     {
 107         [ [ width>> ] [ height>> ] bi 2array ]
 108         [ bitmap>component-order ]
 109         [ buffer>> ]
 110     } cleave bitmap-image new-image ;
 111
 112 M: bitmap-image load-image* ( path bitmap -- bitmap-image )
 113     drop load-bitmap >image ;
 114
 115 MACRO: (nbits>bitmap) ( bits -- )
 116     [ -3 shift ] keep '[
 117         bitmap new
 118             2over * _ * >>size-image
 119             swap >>height
 120             swap >>width
 121             swap array-copy [ >>buffer ] [ >>color-index ] bi
 122             _ >>bit-count >image
 123     ] ;
 124
 125 : bgr>bitmap ( array height width -- bitmap )
 126     24 (nbits>bitmap) ;
 127
 128 : bgra>bitmap ( array height width -- bitmap )
 129     32 (nbits>bitmap) ;
 130
 131 : write2 ( n -- ) 2 >le write ;
 132 : write4 ( n -- ) 4 >le write ;
 133
 134 : save-bitmap ( bitmap path -- )
 135     binary [
 136         B{ CHAR: B CHAR: M } write
 137         [
 138             buffer>> length 14 + 40 + write4
 139             0 write4
 140             54 write4
 141             40 write4
 142         ] [
 143             {
 144                 [ width>> write4 ]
 145                 [ height>> write4 ]
 146                 [ planes>> 1 or write2 ]
 147                 [ bit-count>> 24 or write2 ]
 148                 [ compression>> 0 or write4 ]
 149                 [ size-image>> write4 ]
 150                 [ x-pels>> 0 or write4 ]
 151                 [ y-pels>> 0 or write4 ]
 152                 [ color-used>> 0 or write4 ]
 153                 [ color-important>> 0 or write4 ]
 154                 [ rgb-quads>> write ]
 155                 [ color-index>> write ]
 156             } cleave
 157         ] bi
 158     ] with-file-writer ;