switched to a bitmap-based image comparison

svn: r17466

collects/2htdp/private/image-more.ss

@@ -311,8 +311,8 @@
            [y2 (point-y (line-segment-end simple-shape))])
        (values (min x1 x2)
                (min y1 y2)
-               (max x1 x2)
+               (+ (max x1 x2) 1)
-               (max y1 y2)))]
+               (+ (max y1 y2) 1)))]
     [(polygon? simple-shape)
      (let ([points (polygon-points simple-shape)])
        (let* ([fx (point-x (car points))]
@@ -381,7 +381,7 @@
   (cond
     [(line-segment? simple-shape)
      (make-line-segment (rotate-point (line-segment-start simple-shape)
-                                       θ)
+                                      θ)
                         (rotate-point (line-segment-end simple-shape)
                                       θ)
                         (line-segment-color simple-shape))]
@@ -550,7 +550,6 @@
                      (+ x2 dx)
                      (+ dx (image-right image)))]
          [baseline (+ dy (image-baseline image))])
-    ;(printf "dx ~s orig-right ~s\n" dx (image-right image))
     (make-image (make-translate
                  dx dy
                  (make-overlay

collects/2htdp/tests/test-image.ss

@@ -9,7 +9,13 @@
          scheme/gui/base
          schemeunit)
 
-(define-syntax-rule (test a => b) (check-equal? a b))
+(require (for-syntax scheme/base))
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(test a => b)
+     #`(begin
+         ;(printf "running line ~a\n" #,(syntax-line stx))
+         (check-equal? a b))]))
 
 ;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab")
 
@@ -390,15 +396,15 @@
        #f))
 
 (test (above/align 'center
-                     (ellipse 50 100 'solid 'red)
+                   (ellipse 50 100 'solid 'red)
-                     (ellipse 100 50 'solid 'blue))
+                   (ellipse 100 50 'solid 'blue))
       
       =>
       (make-image
        (make-overlay
         (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))
         (make-translate 0 100 (image-shape (ellipse 100 50 'solid 'blue))))
-       (make-bb 100 150 100)
+       (make-bb 100 150 150)
        #f))
 
 (test (above/align 'right
@@ -814,7 +820,7 @@
 ;;
 
 (check-equal? (equal~? (rhombus 10 90 'solid 'black)
-                       (square 10 'solid 'black)
+                       (rotate 45 (square 10 'solid 'black))
                        0.01)
               #t)
 

collects/mrlib/image-core.ss

@@ -232,8 +232,38 @@ has been moved out).
   (class* snip% (equal<%>)
     (init-field shape bb normalized?)
     (define/public (equal-to? that eq-recur) 
+      (or (eq? this that)
+          (and (eq-recur bb (send that get-bb))
+               (let* ([w (ceiling (max (inexact->exact (bb-right bb))
+                                       (inexact->exact (bb-right (send that get-bb)))))]
+                      [h (ceiling (max (inexact->exact (bb-bottom bb))
+                                       (inexact->exact (bb-bottom (send that get-bb)))))]
+                      [bm1 (make-object bitmap% w h)]
+                      [bm2 (make-object bitmap% w h)]
+                      [bytes1 (make-bytes (* w h 4) 0)]
+                      [bytes2 (make-bytes (* w h 4) 0)]
+                      [bdc (make-object bitmap-dc%)])
+                 (send bdc set-smoothing 'aligned)
+                 (and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
+                      (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))
+      
+      #;
       (eq-recur (get-normalized-shape)
                 (send that get-normalized-shape)))
+    
+    (define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that)
+      (clear-bitmap/draw/bytes bm1 bdc bytes1 this color)
+      (clear-bitmap/draw/bytes bm2 bdc bytes2 that color)
+      (equal? bytes1 bytes2))
+    
+    (define/private (clear-bitmap/draw/bytes bm bdc bytes obj color)
+      (send bdc set-bitmap bm)
+      (send bdc set-pen "black" 1 'transparent)
+      (send bdc set-brush color 'solid)
+      (send bdc draw-rectangle 0 0 (send bm get-width) (send bm get-height))
+      (render-image this bdc 0 0)
+      (send bm get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes))
+    
     (define/public (equal-hash-code-of y) 42)
     (define/public (equal-secondary-hash-code-of y) 3)
 
@@ -288,10 +318,10 @@ has been moved out).
         (send dc set-smoothing smoothing)))
     (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
       (send (get-the-snip-class-list) add snip-class)
-      (let ([bottom (bb-bottom bb)])
+      (let ([bottom (round (bb-bottom bb))])
-        (set-box/f! w (bb-right bb))
+        (set-box/f! w (round (bb-right bb)))
         (set-box/f! h bottom)
-        (set-box/f! descent (- bottom (bb-baseline bb)))
+        (set-box/f! descent (- bottom (round (bb-baseline bb))))
         (set-box/f! space 0)
         (set-box/f! lspace 0)
         (set-box/f! rspace 0)))