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)




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

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

(define a1 (image->alpha star1))
(define w1 (image-width star1))
(define h1 (image-height star1))
(define a2 (image->alpha star2))
(define w2 (image-width star2))
(define h2 (image-height 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)

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

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