private/bmp.rkt
#lang racket/base

;;;
;;; This is a simple bitmap implementation.
;;;
;;; Unfortunately the Racket monochrome bitmap doesn't
;;; quite support everything we need, so here is a
;;; minimalistic version.
;;;

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

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

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

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