BMP support

This commit is contained in:
Matthew Flatt 2010-07-31 08:36:41 -06:00
parent 8c1cd0b730
commit 4425dd894d
2 changed files with 286 additions and 3 deletions

View File

@ -9,6 +9,7 @@
"jpeg.ss"
"xbm.ss"
"xpm.ss"
"bmp.ss"
"gif.rkt"
"local.ss"
"color.ss")
@ -306,9 +307,6 @@
[b&w? #f])
(install-bytes-rows s w h rows b&w? alpha? pre? #f)
(values s b&w?)))]
[(bmp bmp/mask bmp/alpha)
(let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 10 10)])
(values s #f))]
[(xbm xbm/alpha)
(let-values ([(w h rows) (read-xbm in)])
(if rows
@ -324,6 +322,14 @@
(install-bytes-rows s w h rows #f alpha? #t #f)
(values s #f))
(values #f #f)))]
[(bmp bmp/alpha)
(let-values ([(w h rows) (read-bmp in)])
(if rows
(let ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)]
[alpha? #t])
(install-bytes-rows s w h rows #f alpha? #t #f)
(values s #f))
(values #f #f)))]
[else (values #f #f)])))
;; s : Cairo bitmap surface

View File

@ -0,0 +1,277 @@
#lang racket/base
(require racket/port)
(provide read-bmp)
(define BI_RGB 0)
(define BI_RLE8 1)
(define BI_RLE4 2)
(define (read-byte* in)
(let ([c (read-byte in)])
(if (eof-object? c)
(error 'read-bmp "unexpected end of BMP stream: ~e" in)
c)))
(define (int4 in)
(+ (read-byte* in)
(arithmetic-shift (read-byte* in) 8)
(arithmetic-shift (read-byte* in) 16)
(arithmetic-shift (read-byte* in) 24)))
(define (int2 in)
(+ (read-byte* in)
(arithmetic-shift (read-byte* in) 8)))
(define (make-rle8-port in)
(make-input-port/read-to-peek
(object-name in)
(let ([remaining 0]
[value 0]
[absolute 0]
[abs-skip? #f])
(lambda (bstr)
(cond
[(positive? absolute)
(let ([v (read-byte* in)])
(set! absolute (sub1 absolute))
(when (zero? absolute)
(when abs-skip?
(read-byte* in)))
(bytes-set! bstr 0 v)
1)]
[(zero? remaining)
(let ([r (read-byte in)])
(if (eof-object? r)
r
(if (zero? r)
;; special:
(let ([c (read-byte* in)])
(case c
[(0) 0] ; end-of-line
[(1) 0] ; end-of-bitmap
[(2) (error 'read-bmp
"RLE8 cursor command not supported in stream: ~e"
in)]
[else
(set! absolute c)
(set! abs-skip? (odd? c))
0]))
;; normal encoding:
(let ([v (read-byte* in)])
(set! remaining (sub1 r))
(set! value v)
(bytes-set! bstr 0 v)
1))))]
[else
(set! remaining (sub1 remaining))
(bytes-set! bstr 0 value)
1])))
#f
void))
(define (make-rle4-port in)
(make-input-port/read-to-peek
(object-name in)
(let ([remaining 0]
[value 0]
[absolute 0]
[abs-skip? #f]
[nibble #f]) ; leftover half-byte to be delivered
(lambda (bstr)
(let ([nibbles
(cond
[(positive? absolute)
(let ([v (read-byte* in)])
(set! absolute (- absolute 2))
(when (absolute . < . 1)
(when abs-skip?
(read-byte* in)))
(bytes-set! bstr 0 v)
(if (absolute . < . 0)
1
2))]
[(zero? remaining)
(let ([r (read-byte in)])
(if (eof-object? r)
r
(if (zero? r)
;; special:
(let ([c (read-byte* in)])
(case c
[(0) 0] ; end-of-line
[(1) 0] ; end-of-bitmap
[(2) (error 'read-bmp
"RLE8 cursor command not supported in stream: ~e"
in)]
[else
(set! absolute c)
(set! abs-skip? (positive? (bitwise-and c 3)))
0]))
;; normal encoding:
(let ([v (read-byte* in)])
(set! remaining r)
(set! value v)
0))))]
[(= remaining 1)
(bytes-set! bstr 0 value)
1]
[else
(set! remaining (- remaining 2))
(bytes-set! bstr 0 value)
2])])
(cond
[(eof-object? nibbles)
(if nibble
(begin
(bytes-set! bstr 0 (arithmetic-shift nibble 4))
(set! nibble #f)
1)
nibbles)]
[(zero? nibbles)
0]
[(and (not nibble) (= 2 nibbles))
1]
[(and (not nibble) (= 1 nibbles))
(set! nibble (bitwise-and (bytes-ref bstr 0) #xF0))
0]
[(and nibble (= 1 nibbles))
(bytes-set! bstr 0 (bitwise-ior nibble
(arithmetic-shift (bytes-ref bstr 0) -4)))
(set! nibble #f)
1]
[else ;; (and nibble (= 2 nibbles))
(let ([old nibble])
(set! nibble (arithmetic-shift (bitwise-and (bytes-ref bstr 0) #xF) 4))
(bytes-set! bstr 0 (bitwise-ior old
(arithmetic-shift (bytes-ref bstr 0) -4)))
1)]))))
#f
void))
(define (read-bmp in)
(unless (and (= (read-byte* in) (char->integer #\B))
(= (read-byte* in) (char->integer #\M)))
(error 'read-bmp "not a BMP stream: ~e" in))
(let ([file-size (int4 in)]
[reserved1 (int2 in)]
[reserved2 (int2 in)]
[offset (int4 in)])
;; Start DIB header
(let ([header-size (int4 in)])
(unless (or (= header-size 40)
(= header-size 12))
(error 'read-bmp "expected a 12- or 40-byte DIB header, got ~a in stream: ~e" header-size in))
(let-values ([(width height bits-per-pixel compression color-count padded-rgb?)
(case header-size
[(40)
(let ([width (int4 in)]
[height (int4 in)]
[planes (int2 in)]
[bits-per-pixel (int2 in)]
[compression (int4 in)]
[image-size (int4 in)]
[hres (int4 in)]
[vres (int4 in)]
[color-count (int4 in)]
[colors-used (int4 in)])
(unless (or (= compression BI_RGB)
(= compression BI_RLE4)
(= compression BI_RLE8))
(error 'read-bmp "unsupported compression type ~a in stream: ~e" compression in))
(values width height bits-per-pixel compression color-count #t))]
[(12)
(let ([width (int2 in)]
[height (int2 in)]
[planes (int2 in)]
[bits-per-pixel (int2 in)])
(values width height bits-per-pixel BI_RGB 0 #f))])])
(let* ([color-count (if (zero? color-count)
(arithmetic-shift 1 bits-per-pixel)
color-count)]
[colors
(if (bits-per-pixel . >= . 16)
#f
(let ([vec (make-vector color-count #"\0\0\0\xFF")])
(for ([i (in-range color-count)])
(let ([b (read-byte* in)]
[g (read-byte* in)]
[r (read-byte* in)])
(when padded-rgb? (read-byte* in))
(vector-set! vec i (bytes r g b 255))))
vec))]
[current-pos (+ 14
header-size
(if colors (* color-count (if padded-rgb? 4 3)) 0))])
;; Image data:
(read-bytes (- offset current-pos) in)
(let ([in (cond
[(= compression BI_RLE4) (make-rle4-port in)]
[(= compression BI_RLE8) (make-rle8-port in)]
[else in])])
(values
width
height
(list->vector
(reverse
(for/list ([j (in-range height)])
(let* ([row (make-bytes (* 4 width) 255)]
[install-color!
(lambda (i c)
(if (c . < . color-count)
(let ([col (vector-ref colors c)])
(bytes-set! row (* i 4) (bytes-ref col 0))
(bytes-set! row (+ 1 (* i 4)) (bytes-ref col 1))
(bytes-set! row (+ 2 (* i 4)) (bytes-ref col 2)))
(error 'read-bmp "bad color table index ~a in stream: ~e" c in)))])
(case bits-per-pixel
[(32)
(for ([i (in-range width)])
(let ([b (read-byte* in)]
[g (read-byte* in)]
[r (read-byte* in)])
(read-byte* in) ; discard
(bytes-set! row (* i 4) r)
(bytes-set! row (+ 1 (* i 4)) g)
(bytes-set! row (+ 2 (* i 4)) b)))]
[(24)
(for ([i (in-range width)])
(let ([b (read-byte* in)]
[g (read-byte* in)]
[r (read-byte* in)])
(bytes-set! row (* i 4) r)
(bytes-set! row (+ 1 (* i 4)) g)
(bytes-set! row (+ 2 (* i 4)) b)))]
[(16)
(for ([i (in-range width)])
(let ([col (bitwise-ior (read-byte* in)
(arithmetic-shift (read-byte* in) 8))])
(bytes-set! row (* i 4) (arithmetic-shift (bitwise-and col #x7C00) -7))
(bytes-set! row (+ 1 (* i 4)) (arithmetic-shift (bitwise-and col #x3E0) -2))
(bytes-set! row (+ 2 (* i 4)) (arithmetic-shift (bitwise-and col #x1F) 3))))]
[(8)
(for ([i (in-range width)])
(install-color! i (read-byte* in)))]
[(4)
(for/fold ([b 0]) ([i (in-range width)])
(let ([b (if (zero? (bitwise-and i 1))
(read-byte* in)
(arithmetic-shift b 4))])
(install-color! i (arithmetic-shift (bitwise-and b #xF0) -4))
b))]
[(1)
(for/fold ([b 0]) ([i (in-range width)])
(let ([b (if (zero? (bitwise-and i 7))
(read-byte* in)
(arithmetic-shift b 1))])
(install-color! i (arithmetic-shift (bitwise-and b #x80) -7))
b))]
[else
(error 'read-bmp "unsupported bits-per-pixel count ~a in stream: ~e"
bits-per-pixel in)])
;; skip padding, if any:
(when (= compression BI_RGB)
(let ([n (modulo (ceiling (/ (* width bits-per-pixel) 8)) 4)])
(unless (zero? n)
(read-bytes (- 4 n) in))))
row)))))))))))