#lang racket/base
(require racket/contract)
(provide
(struct-out bmp)
get-px
set-px!
clear-px!
set-rect!
clear-rect!
bmp-tile
bmp-map
(contract-out
[make-bmp (->* (exact-nonnegative-integer?
exact-nonnegative-integer?)
((or/c #f bytes?))
bmp?)]
[blit! (-> bmp? bmp?
exact-nonnegative-integer?
exact-nonnegative-integer?
void?)]))
(struct bmp
(width height stride bits))
(define (make-bmp width height [bits #f])
(let ([stride (quotient (+ width 7) 8)])
(bmp width height
stride
(if bits
(bytes-copy bits)
(make-bytes (* height stride))))))
(define (blit! bmp src x y)
(let ([in-bits (bmp-bits src)]
[out-bits (bmp-bits bmp)]
[off (remainder x 8)]
[w (add1 (- (quotient (+ x (bmp-width src)) 8)
(quotient x 8)))])
(for ([in (in-range 0 (bytes-length (bmp-bits src)) (bmp-stride src))]
[out (in-range (+ (* y (bmp-stride bmp))
(quotient x 8))
(bytes-length (bmp-bits bmp))
(bmp-stride bmp))])
(for ([inp (in-range in (+ in w))]
[outp (in-range out (+ out w))])
(let* ([b (bytes-ref out-bits outp)]
[b (if (= (- inp in) (bmp-stride src))
b
(bitwise-ior b (bitwise-and (arithmetic-shift (bytes-ref in-bits inp) off)
#xFF)))]
[b (if (= inp in)
b
(bitwise-ior b (bitwise-and (arithmetic-shift (bytes-ref in-bits (sub1 inp)) (- off 8))
#xFF)))])
(bytes-set! out-bits outp b))))))
(define (px-loc bmp x y)
(values (+ (* y (bmp-stride bmp))
(quotient x 8))
(arithmetic-shift 1 (remainder x 8))))
(define (get-px bmp x y)
(let-values ([(i b) (px-loc bmp x y)]
[(bits) (bmp-bits bmp)])
(not
(zero?
(bitwise-and (bytes-ref bits i) b)))))
(define (set-px! bmp x y)
(let-values ([(i b) (px-loc bmp x y)]
[(bits) (bmp-bits bmp)])
(bytes-set! bits i
(bitwise-ior (bytes-ref bits i) b))))
(define (clear-px! bmp x y)
(let-values ([(i b) (px-loc bmp x y)]
[(bits) (bmp-bits bmp)])
(bytes-set! bits i
(bitwise-and (bytes-ref bits i)
(bitwise-not b)))))
(define (set-rect! bmp x y w h)
(for* ([j (in-range y (+ y h))]
[i (in-range x (+ x w))])
(set-px! bmp j i)))
(define (clear-rect! bmp x y w h)
(for* ([j (in-range y (+ y h))]
[i (in-range x (+ x w))])
(clear-px! bmp j i)))
(define (bmp-tile bmp w h)
(let ([out (make-bmp w h)])
(for* ([j (in-range h)]
[i (in-range w)]
#:when (get-px bmp
(remainder i (bmp-width bmp))
(remainder j (bmp-height bmp))))
(set-px! out i j))
out))
(define (bmp-map op bmp . rest)
(make-bmp (bmp-width bmp)
(bmp-height bmp)
(list->bytes
(apply map op
(map
(lambda (src)
(bytes->list
(bmp-bits src)))
(cons bmp rest))))))