278 lines
11 KiB
Racket
278 lines
11 KiB
Racket
#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)))))))))))
|