diff options
| -rw-r--r-- | write-bmp.scm | 92 |
1 files changed, 92 insertions, 0 deletions
diff --git a/write-bmp.scm b/write-bmp.scm new file mode 100644 index 0000000..233ef48 --- /dev/null +++ b/write-bmp.scm @@ -0,0 +1,92 @@ +;; Packing procedures which depend either on +;; (rnrs arithmetic bitwise (6)), in the case of R6RS, or +;; srfi-151, in the case of R7RS. + +(define (encode-u64 n) + (list (arithmetic-shift (bitwise-and n #x00000000000000ff) 0) + (arithmetic-shift (bitwise-and n #x000000000000ff00) -8) + (arithmetic-shift (bitwise-and n #x0000000000ff0000) -16) + (arithmetic-shift (bitwise-and n #x00000000ff000000) -24) + (arithmetic-shift (bitwise-and n #x000000ff00000000) -32) + (arithmetic-shift (bitwise-and n #x0000ff0000000000) -40) + (arithmetic-shift (bitwise-and n #x00ff000000000000) -48) + (arithmetic-shift (bitwise-and n #xff00000000000000) -56))) + +(define (encode-u32 n) + (list (arithmetic-shift (bitwise-and n #x000000ff) 0) + (arithmetic-shift (bitwise-and n #x0000ff00) -8) + (arithmetic-shift (bitwise-and n #x00ff0000) -16) + (arithmetic-shift (bitwise-and n #xff000000) -24))) + +(define (encode-u16 n) + (list (arithmetic-shift (bitwise-and n #x00ff) 0) + (arithmetic-shift (bitwise-and n #xff00) -8))) + +(define (encode-u8 n) (list (bitwise-and n #xff))) + + + +(define bmp-skeleton-size 48) + +;; Binary output, which I can't get uniform across standards. + +;; R7RS (Chicken). + +(define-record-type <bmp> + (bmp width height pixels) + bmp? + (width bmp-width) + (height bmp-height) + (pixels bmp-pixels)) + +(define (set-pixel! bmp x y r g b) + (let* ((index (+ x (* (bmp-width bmp) y))) + (pixel (make-vector 3))) + (vector-set! pixel 2 r) + (vector-set! pixel 1 g) + (vector-set! pixel 0 b) + (vector-set! (bmp-pixels bmp) index pixel))) + +(define (write-bytes bytes) (for-each write-byte bytes)) +(define (write-bmp dest bmp) + (with-output-to-file dest + (lambda () + (let* ((pixels (bmp-pixels bmp)) + (image-size (* 3 (vector-length pixels))) + (file-size (+ bmp-skeleton-size image-size))) + ;; File header. + (write-bytes '(66 77)) + (write-bytes (encode-u64 file-size)) + (write-bytes (encode-u32 #x36)) ;; Data start (constant). + + ;; Bitmap header. + (write-bytes (encode-u32 #x28)) ;; Header size (constant). + (write-bytes (encode-u32 (bmp-width bmp))) + (write-bytes (encode-u32 (bmp-height bmp))) + (write-bytes (encode-u16 1)) ;; nb plan (constant). + (write-bytes (encode-u16 24)) ;; bpp (constant). + (write-bytes (encode-u32 0)) ;; Uncompressed (constant). + (write-bytes (encode-u32 image-size)) + (write-bytes '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) ;; Padding. + + ;; Pixel data. + (let loop ((i 0)) + (unless (>= i (vector-length pixels)) + (write-byte (vector-ref (vector-ref pixels i) 0)) + (write-byte (vector-ref (vector-ref pixels i) 1)) + (write-byte (vector-ref (vector-ref pixels i) 2)) + (loop (+ i 1)))) + (write-bytes '(0 0 0)))))) ;; Padding. + +(define (make-bmp width height) + (bmp width height (make-vector (* width height) #(0 0 0)))) + +(let ((bmp (make-bmp 64 64))) + (let loop ((x 0)) + (when (< x 64) + (let inner ((y 0)) + (when (< y 64) + (set-pixel! bmp x y y x y) + (inner (+ y 1)))) + (loop (+ x 1)))) + (write-bmp "test.bmp" bmp)) |