basis/images/bitmap/loading/loading.factor

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