;; 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))