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