suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

switched to a bitmap-based image comparison

Browse Source 
svn: r17466
This commit is contained in:
Robby Findler 2010-01-02 22:32:44 +00:00
parent 9a11ad1d67
commit ca96ddd889
3 changed files with 47 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/2htdp/private/image-more.ss
View File

@ -311,8 +311,8 @@
[y2 (point-y (line-segment-end simple-shape))])
(values (min x1 x2)
(min y1 y2)
(max x1 x2)
(max y1 y2)))]
(+ (max x1 x2) 1)
(+ (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

16
collects/2htdp/tests/test-image.ss
View File

@ -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 100 50 'solid 'blue))
(ellipse 50 100 'solid 'red)
(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)

36
collects/mrlib/image-core.ss
View File

@ -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)])
(set-box/f! w (bb-right bb))
(let ([bottom (round (bb-bottom 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)))