From 4425dd894d2a0a1f4c0b838ad14dad163fe0b215 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 31 Jul 2010 08:36:41 -0600 Subject: [PATCH] BMP support --- collects/racket/draw/bitmap.rkt | 12 +- collects/racket/draw/bmp.rkt | 277 ++++++++++++++++++++++++++++++++ 2 files changed, 286 insertions(+), 3 deletions(-) create mode 100644 collects/racket/draw/bmp.rkt diff --git a/collects/racket/draw/bitmap.rkt b/collects/racket/draw/bitmap.rkt index a7c9b41e61..90edc5e3b1 100644 --- a/collects/racket/draw/bitmap.rkt +++ b/collects/racket/draw/bitmap.rkt @@ -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 diff --git a/collects/racket/draw/bmp.rkt b/collects/racket/draw/bmp.rkt new file mode 100644 index 0000000000..fcebcc2dd1 --- /dev/null +++ b/collects/racket/draw/bmp.rkt @@ -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)))))))))))