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.c-types alien.data arrays byte-arrays
   4 combinators compression.run-length fry grouping images
   5 images.loader images.normalization io io.binary
   6 io.encodings.latin1 io.encodings.string io.streams.throwing
   7 kernel math math.bitwise sequences specialized-arrays summary ;
   8 QUALIFIED-WITH: bitstreams b
   9 SPECIALIZED-ARRAYS: uint ushort ;
  10 IN: images.bitmap
  11
  12 ! http://www.fileformat.info/format/bmp/egff.htm
  13 ! http://www.digicamsoft.com/bmp/bmp.html
  14
  15 SINGLETON: bmp-image
  16 "bmp" bmp-image ?register-image-class
  17
  18 : write2 ( n -- ) 2 >le write ;
  19 : write4 ( n -- ) 4 >le write ;
  20
  21 ERROR: unknown-component-order bitmap ;
  22 ERROR: unknown-bitmap-header n ;
  23
  24 : read2 ( -- n ) 2 read le> ;
  25 : read4 ( -- n ) 4 read le> ;
  26
  27 TUPLE: loading-bitmap
  28     file-header header
  29     color-palette color-index bitfields ;
  30
  31 TUPLE: file-header
  32     { magic initial: "BM" }
  33     { size }
  34     { reserved1 initial: 0 }
  35     { reserved2 initial: 0 }
  36     { offset }
  37     { header-length } ;
  38
  39 TUPLE: v3-header
  40     { width initial: 0 }
  41     { height initial: 0 }
  42     { planes initial: 0 }
  43     { bit-count initial: 0 }
  44     { compression initial: 0 }
  45     { image-size initial: 0 }
  46     { x-resolution initial: 0 }
  47     { y-resolution initial: 0 }
  48     { colors-used initial: 0 }
  49     { colors-important initial: 0 } ;
  50
  51 TUPLE: v4-header < v3-header
  52     { red-mask initial: 0 }
  53     { green-mask initial: 0 }
  54     { blue-mask initial: 0 }
  55     { alpha-mask initial: 0 }
  56     { cs-type initial: 0 }
  57     { end-points initial: 0 }
  58     { gamma-red initial: 0 }
  59     { gamma-green initial: 0 }
  60     { gamma-blue initial: 0 } ;
  61
  62 TUPLE: v5-header < v4-header
  63     { intent initial: 0 }
  64     { profile-data initial: 0 }
  65     { profile-size initial: 0 }
  66     { reserved3 initial: 0 } ;
  67
  68 TUPLE: os2v1-header
  69     { width initial: 0 }
  70     { height initial: 0 }
  71     { planes initial: 0 }
  72     { bit-count initial: 0 } ;
  73
  74 TUPLE: os2v2-header < os2v1-header
  75     { compression initial: 0 }
  76     { image-size initial: 0 }
  77     { x-resolution initial: 0 }
  78     { y-resolution initial: 0 }
  79     { colors-used initial: 0 }
  80     { colors-important initial: 0 }
  81     { units initial: 0 }
  82     { reserved initial: 0 }
  83     { recording initial: 0 }
  84     { rendering initial: 0 }
  85     { size1 initial: 0 }
  86     { size2 initial: 0 }
  87     { color-encoding initial: 0 }
  88     { identifier initial: 0 } ;
  89
  90 UNION: v-header v3-header v4-header v5-header ;
  91 UNION: os2-header os2v1-header os2v2-header ;
  92
  93 : parse-file-header ( -- file-header )
  94     \ file-header new
  95         2 read latin1 decode >>magic
  96         read4 >>size
  97         read2 >>reserved1
  98         read2 >>reserved2
  99         read4 >>offset
 100         read4 >>header-length ;
 101
 102 : read-v3-header-data ( header -- header )
 103     read4 >>width
 104     read4 32 >signed >>height
 105     read2 >>planes
 106     read2 >>bit-count
 107     read4 >>compression
 108     read4 >>image-size
 109     read4 >>x-resolution
 110     read4 >>y-resolution
 111     read4 >>colors-used
 112     read4 >>colors-important ;
 113
 114 : read-v3-header ( -- header )
 115     \ v3-header new
 116         read-v3-header-data ;
 117
 118 : read-v4-header-data ( header -- header )
 119     read4 >>red-mask
 120     read4 >>green-mask
 121     read4 >>blue-mask
 122     read4 >>alpha-mask
 123     read4 >>cs-type
 124     read4 read4 read4 3array >>end-points
 125     read4 >>gamma-red
 126     read4 >>gamma-green
 127     read4 >>gamma-blue ;
 128
 129 : read-v4-header ( -- v4-header )
 130     \ v4-header new
 131         read-v3-header-data
 132         read-v4-header-data ;
 133
 134 : read-v5-header-data ( v5-header -- v5-header )
 135     read4 >>intent
 136     read4 >>profile-data
 137     read4 >>profile-size
 138     read4 >>reserved3 ;
 139
 140 : read-v5-header ( -- loading-bitmap )
 141     \ v5-header new
 142         read-v3-header-data
 143         read-v4-header-data
 144         read-v5-header-data ;
 145
 146 : read-os2v1-header ( -- os2v1-header )
 147     \ os2v1-header new
 148         read2 >>width
 149         read2 16 >signed >>height
 150         read2 >>planes
 151         read2 >>bit-count ;
 152
 153 : read-os2v2-header-data ( os2v2-header -- os2v2-header )
 154     read4 >>width
 155     read4 32 >signed >>height
 156     read2 >>planes
 157     read2 >>bit-count
 158     read4 >>compression
 159     read4 >>image-size
 160     read4 >>x-resolution
 161     read4 >>y-resolution
 162     read4 >>colors-used
 163     read4 >>colors-important
 164     read2 >>units
 165     read2 >>reserved
 166     read2 >>recording
 167     read2 >>rendering
 168     read4 >>size1
 169     read4 >>size2
 170     read4 >>color-encoding
 171     read4 >>identifier ;
 172
 173 : read-os2v2-header ( -- os2v2-header )
 174     \ os2v2-header new
 175         read-os2v2-header-data ;
 176
 177 : parse-header ( n -- header )
 178     {
 179         { 12 [ read-os2v1-header ] }
 180         { 64 [ read-os2v2-header ] }
 181         { 40 [ read-v3-header ] }
 182         { 108 [ read-v4-header ] }
 183         { 124 [ read-v5-header ] }
 184         [ unknown-bitmap-header ]
 185     } case ;
 186
 187 : color-index-length ( header -- n )
 188     {
 189         [ width>> ]
 190         [ planes>> * ]
 191         [ bit-count>> * 31 + 32 /i 4 * ]
 192         [ height>> abs * ]
 193     } cleave ;
 194
 195 : color-palette-length ( loading-bitmap -- n )
 196     file-header>>
 197     [ offset>> 14 - ] [ header-length>> ] bi - ;
 198
 199 : parse-color-palette ( loading-bitmap -- loading-bitmap )
 200     dup color-palette-length read >>color-palette ;
 201
 202 GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
 203
 204 : parse-color-data ( loading-bitmap -- loading-bitmap )
 205     dup header>> parse-color-data* ;
 206
 207 M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
 208     color-index-length read >>color-index ;
 209
 210 M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
 211     dup image-size>> [ 0 ] unless* dup 0 >
 212     [ nip ] [ drop color-index-length ] if read >>color-index ;
 213
 214 : alpha-used? ( loading-bitmap -- ? )
 215     color-index>> 4 <groups> [ fourth 0 = ] all? not ;
 216
 217 GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
 218
 219 : bitmap>component-order ( loading-bitmap -- object )
 220     dup header>> bitmap>component-order* ;
 221
 222 : simple-bitmap>component-order ( loading-bitamp -- object )
 223     header>> bit-count>> {
 224         { 32 [ BGRX ] }
 225         { 24 [ BGR ] }
 226         { 16 [ BGR ] }
 227         { 8 [ BGR ] }
 228         { 4 [ BGR ] }
 229         { 1 [ BGR ] }
 230         [ unknown-component-order ]
 231     } case ;
 232
 233 : advanced-bitmap>component-order ( loading-bitmap -- object )
 234     [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
 235         { { 32 t } [ drop BGRA ] }
 236         { { 32 f } [ drop BGRX ] }
 237         [ drop simple-bitmap>component-order ]
 238     } case ;
 239
 240 : color-lookup3 ( loading-bitmap -- seq )
 241     [ color-index>> >array ]
 242     [ color-palette>> 3 <groups> ] bi
 243     '[ _ nth ] map concat ;
 244
 245 : color-lookup4 ( loading-bitmap -- seq )
 246     [ color-index>> >array ]
 247     [ color-palette>> 4 <groups> [ 3 head-slice ] map ] bi
 248     '[ _ nth ] map concat ;
 249
 250 ! os2v1 is 3bytes each, all others are 3 + 1 unused
 251 : color-lookup ( loading-bitmap -- seq )
 252     dup file-header>> header-length>> {
 253         { 12 [ color-lookup3 ] }
 254         { 64 [ color-lookup4 ] }
 255         { 40 [ color-lookup4 ] }
 256         { 108 [ color-lookup4 ] }
 257         { 124 [ color-lookup4 ] }
 258     } case ;
 259
 260 M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
 261 M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
 262 M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
 263 M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
 264 M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
 265
 266 : uncompress-bitfield ( seq masks -- bytes' )
 267     '[
 268         _ [
 269             [ bitand ] [ bit-count ] [ log2 ] tri - shift
 270         ] with map
 271     ] { } map-as B{ } concat-as ;
 272
 273 ERROR: bmp-not-supported n ;
 274
 275 : bitmap>bytes ( loading-bitmap -- byte-array )
 276     dup header>> bit-count>>
 277     {
 278         { 32 [ color-index>> ] }
 279         { 24 [ color-index>> ] }
 280         { 16 [
 281             [
 282                 ! ushort cast-array
 283                 2 group [ le> ] map
 284                 ! 5 6 5
 285                 ! { 0xf800 0x7e0 0x1f } uncompress-bitfield
 286                 ! 5 5 5
 287                 { 0x7c00 0x3e0 0x1f } uncompress-bitfield
 288             ] change-color-index
 289             color-index>>
 290         ] }
 291         { 8 [ color-lookup ] }
 292         { 4 [ [ 4 b:byte-array-n>sequence ] change-color-index color-lookup ] }
 293         { 1 [ [ 1 b:byte-array-n>sequence ] change-color-index color-lookup ] }
 294         [ bmp-not-supported ]
 295     } case >byte-array ;
 296
 297 : set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
 298     dup header>> bit-count>> {
 299         { 16 [ dup color-palette>> 4 group [ le> ] map ] }
 300         { 32 [ { 0xff0000 0xff00 0xff } ] }
 301     } case reverse >>bitfields ;
 302
 303 ERROR: unsupported-bitfield-widths n ;
 304
 305 M: unsupported-bitfield-widths summary
 306     drop "Bitmaps only support bitfield compression in 16/32bit images" ;
 307
 308 : uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
 309     set-bitfield-widths
 310     dup header>> bit-count>> {
 311         { 16 [
 312             dup bitfields>> '[
 313                 ushort cast-array _ uncompress-bitfield
 314             ] change-color-index
 315         ] }
 316         { 32 [ ] }
 317         [ unsupported-bitfield-widths ]
 318     } case ;
 319
 320 ERROR: unsupported-bitmap-compression compression ;
 321
 322 GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
 323
 324 : uncompress-bitmap ( loading-bitmap -- loading-bitmap )
 325     dup header>> uncompress-bitmap* ;
 326
 327 M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
 328     drop ;
 329
 330 : do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
 331     dupd '[
 332         _ header>> [ width>> ] [ height>> ] bi
 333         _ execute
 334     ] change-color-index ; inline
 335
 336 M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
 337     compression>> {
 338         { f [ ] }
 339         { 0 [ ] }
 340         { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
 341         { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
 342         { 3 [ uncompress-bitfield-widths ] }
 343         { 4 [ "jpeg" unsupported-bitmap-compression ] }
 344         { 5 [ "png" unsupported-bitmap-compression ] }
 345     } case ;
 346
 347 ERROR: unsupported-bitmap-file magic ;
 348
 349 : load-bitmap ( stream -- loading-bitmap )
 350     [
 351         [
 352             \ loading-bitmap new
 353             parse-file-header [ >>file-header ] [ ] bi magic>> {
 354                 { "BM" [
 355                     dup file-header>> header-length>> parse-header >>header
 356                     parse-color-palette
 357                     parse-color-data
 358                 ] }
 359                 ! { "BA" [ parse-os2-bitmap-array ] }
 360                 ! { "CI" [ parse-os2-color-icon ] }
 361                 ! { "CP" [ parse-os2-color-pointer ] }
 362                 ! { "IC" [ parse-os2-icon ] }
 363                 ! { "PT" [ parse-os2-pointer ] }
 364                 [ unsupported-bitmap-file ]
 365             } case
 366         ] throw-on-eof
 367     ] with-input-stream ;
 368
 369 : loading-bitmap>bytes ( loading-bitmap -- byte-array )
 370     uncompress-bitmap bitmap>bytes ;
 371
 372 M: bmp-image stream>image* ( stream bmp-image -- bitmap )
 373     drop load-bitmap
 374     [ image new ] dip
 375     {
 376         [ loading-bitmap>bytes >>bitmap ]
 377         [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
 378         [ header>> height>> 0 < not >>upside-down? ]
 379         [ bitmap>component-order >>component-order ubyte-components >>component-type ]
 380     } cleave ;
 381
 382 : output-width-and-height ( image -- )
 383     [ dim>> first write4 ]
 384     [
 385         [ dim>> second ] [ upside-down?>> ] bi
 386         [ neg ] unless write4
 387     ] bi ;
 388
 389 : output-bmp ( image -- )
 390     B{ CHAR: B CHAR: M } write
 391     [
 392         bitmap>> length 14 + 40 + write4
 393         0 write4
 394         54 write4
 395         40 write4
 396     ] [
 397         {
 398             [ output-width-and-height ]
 399
 400             ! planes
 401             [ drop 1 write2 ]
 402
 403             ! bit-count
 404             [ drop 24 write2 ]
 405
 406             ! compression
 407             [ drop 0 write4 ]
 408
 409             ! image-size
 410             [ bitmap>> length write4 ]
 411
 412             ! x-pels
 413             [ drop 0 write4 ]
 414
 415             ! y-pels
 416             [ drop 0 write4 ]
 417
 418             ! color-used
 419             [ drop 0 write4 ]
 420
 421             ! color-important
 422             [ drop 0 write4 ]
 423
 424             ! color-palette
 425             [ bitmap>> write ]
 426         } cleave
 427     ] bi ;
 428
 429 M: bmp-image image>stream
 430     2drop BGR reorder-components output-bmp ;