Unbelievably primitive image detection for 2htdp/image

collision-detection.rkt

#lang racket

(require 2htdp/image
         (only-in mred make-bitmap bitmap-dc%)
         (only-in 2htdp/private/image-more render-image)
         rackunit)

(define star1 (star-polygon 40 5 2 "solid" "seagreen"))
(define star2 (rotate 20 (star-polygon 40 5 2 "solid" "seagreen")))

;; return the alpha map of the image.
;; image -> bytes
(define (image->alpha image)
  (define w (image-width image))
  (define h (image-height image))
  (define bm (make-bitmap w h))
  (define bdc (make-object bitmap-dc% bm))
  (render-image image bdc 0 0)
  ;; very unpacked, for the moment:
  (define alpha-bytes 
    (make-bytes (* 4 w h)))
  (send bdc get-argb-pixels 0 0 w h alpha-bytes #t)
  alpha-bytes)


(define (image->mask image)
  (define w (image-width image))
  (define h (image-height image))
  (define bm (make-bitmap w h))
  (define bdc (make-object bitmap-dc% bm))
  (render-image image bdc 0 0)
  ;; very unpacked, for the moment:
  (for/vector ((y (in-range h)))
    (define alpha-bytes 
      (make-bytes (* 4 w)))
    (send bdc get-argb-pixels 0 y w 1 alpha-bytes #t)
    (for/sum ((x (in-range w)))
      (if (zero? (bytes-ref alpha-bytes (* 4 x)))
          0
          (arithmetic-shift 1 x)))))
        

;; return the alpha channel component of a given pixel
;; bytes number number number -> number
(define (alpha-ref alpha x y width height)
  (cond [(< x 0) 0]
        [(<= width x) 0]
        [(< y 0) 0]
        [(<= height y) 0]
        [else
         (bytes-ref alpha (* 4 (+ x (* y width))))]))

(define (mask-ref mask x y)
  (cond [(< y 0) 0]
        [(<= (vector-length mask) y) 0]
        [else
         (bitwise-and 1 (arithmetic-shift (vector-ref mask y) (- x)))]))

;; first try: brute force (a.k.a. reference implementation)
;; this procedure just scans the totality of image 1, looking for
;; places where its alpha channel is nonzero, and so is the 
;; corresponding pixel in the second image's alpha channel.
;; dx refers to the second image's UL corner w.r.t. the first
;; image's UL corner, and so forth.
;; bytes number number bytes number number number number -> boolean
(define (collision? alpha1 w1 h1 alpha2 w2 h2 dx dy)
  (for*/or ([y h1] [x w1])
    (and (not (= (alpha-ref alpha1 x y w1 h1) 0))
         (not (= (alpha-ref alpha2 (- x dx) (- y dy) w2 h2) 0)))))

;; collision detection based on masks
(define (collision2? mask1 mask2 dx dy)
  (let ((h1 (vector-length mask1))
        (h2 (vector-length mask2)))
    (for/or ((y (in-range (max 0 (- dy)) (min (- h1 dy) h2))))
      (not (zero? (bitwise-and (vector-ref mask1 (+ y dy))
                               (arithmetic-shift (vector-ref mask2 y) dx)))))))
           

(define a1 (image->alpha star1))
(define w1 (image-width star1))
(define h1 (image-height star1))
(define m1 (image->mask star1))
(define a2 (image->alpha star2))
(define w2 (image-width star2))
(define h2 (image-height star2))
(define m2 (image->mask star2))
  

(check-equal? (alpha-ref a1 0 0 w1 h1) 0)
(check-equal? (alpha-ref a1 (floor (/ w1 2)) (floor (/ h1 2)) w1 h1) 255)
(check-equal? (alpha-ref a1 -4 0 w1 h1) 0)

(check-equal? (mask-ref m1 0 0) 0)
(check-equal? (mask-ref m1 (floor (/ w1 2)) (floor (/ h1 2))) 1)
(check-equal? (mask-ref m1 -4 0) 0)

;; no overlap:
(place-image star2
             40 84          
             (place-image star1 30 30 (empty-scene 100 100)))
;; should be false
(check-false (collision? a1 w1 h1 a2 w2 h2 10 54))
(check-false (collision2? m1 m2 10 54))

;; overlap:
(place-image star2
             32 79          
             (place-image star1 30 30 (empty-scene 100 100)))
;; should be true:
(check-true (collision? a1 w1 h1 a2 w2 h2 2 49))
(check-true (collision2? m1 m2 2 49))