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