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

added fast path for image equality that covers the case where the images have the same structure (roughly)

Browse Source 
svn: r17560
This commit is contained in:
Robby Findler 2010-01-08 02:25:11 +00:00
parent db44bb9e7a
commit 179f3615e2
2 changed files with 213 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -37,7 +37,9 @@
(with-syntax ([check-equal? (datum->syntax #'here 'check-equal? stx)]) (with-syntax ([check-equal? (datum->syntax #'here 'check-equal? stx)])
#`(begin #`(begin
;(printf "running line ~a\n" #,(syntax-line stx)) ;(printf "running line ~a\n" #,(syntax-line stx))
#,(quasisyntax/loc stx (check-equal? a b))))])) #,(quasisyntax/loc stx (check-equal? a b))
(parameterize ([skip-image-equality-fast-path #t])
#,(quasisyntax/loc stx (check-equal? a b)))))]))
;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab") ;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab")
@ -79,36 +81,16 @@
(map loop (cdr (vector->list (struct->vector x))))))] (map loop (cdr (vector->list (struct->vector x))))))]
[else x]))) [else x])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; compare-all-rotations
;;
(check-equal? (compare-all-rotations '() '() equal?)
#t)
(check-equal? (compare-all-rotations '(1) '(1) equal?)
#t)
(check-equal? (compare-all-rotations '(1) '(2) equal?)
#f)
(check-equal? (compare-all-rotations '(1 2 3) '(1 2 3) equal?)
#t)
(check-equal? (compare-all-rotations '(1 2 3) '(2 3 1) equal?)
#t)
(check-equal? (compare-all-rotations '(1 2 3) '(3 1 2) equal?)
#t)
(check-equal? (compare-all-rotations '(1 2 3 4) '(4 1 2 3) equal?)
#t)
(check-equal? (compare-all-rotations '(1 2 3 5) '(4 1 2 3) equal?)
#f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; circle vs ellipse ;; circle vs ellipse
;; ;;
(check-equal? (ellipse 40 40 'outline 'black) (test (ellipse 40 40 'outline 'black)
=>
(circle 20 'outline 'black)) (circle 20 'outline 'black))
(check-equal? (ellipse 60 60 'solid 'red) (test (ellipse 60 60 'solid 'red)
=>
(circle 30 'solid 'red)) (circle 30 'solid 'red))
@ -195,31 +177,36 @@
;; polygon equality ;; polygon equality
;; ;;
(check-equal? (polygon (list (make-posn 0 0) (test (polygon (list (make-posn 0 0)
(make-posn 10 10) (make-posn 10 10)
(make-posn 10 0)) (make-posn 10 0))
"solid" "plum") "solid" "plum")
=>
(polygon (list (make-posn 10 10) (polygon (list (make-posn 10 10)
(make-posn 10 0) (make-posn 10 0)
(make-posn 0 0)) (make-posn 0 0))
"solid" "plum")) "solid" "plum"))
(check-equal? (polygon (list (make-posn 0 0) (test (polygon (list (make-posn 0 0)
(make-posn 0 10) (make-posn 0 10)
(make-posn 10 10) (make-posn 10 10)
(make-posn 10 0)) (make-posn 10 0))
"solid" "plum") "solid" "plum")
=>
(rectangle 10 10 "solid" "plum")) (rectangle 10 10 "solid" "plum"))
;; make sure equality isn't equating everything ;; make sure equality isn't equating everything
(check-equal? (equal? (rectangle 10 10 'solid 'blue) (test (equal? (rectangle 10 10 'solid 'blue)
(rectangle 10 10 'solid 'red)) (rectangle 10 10 'solid 'red))
=>
#f) #f)
;; make sure 'white and black match up with color structs ;; make sure 'white and black match up with color structs
(check-equal? (rectangle 10 10 'solid (make-color 255 255 255)) (test (rectangle 10 10 'solid (make-color 255 255 255))
=>
(rectangle 10 10 'solid 'white)) (rectangle 10 10 'solid 'white))
(check-equal? (rectangle 10 10 'solid (make-color 0 0 0)) (test (rectangle 10 10 'solid (make-color 0 0 0))
=>
(rectangle 10 10 'solid 'black)) (rectangle 10 10 'solid 'black))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -692,21 +679,17 @@
=> =>
#t) #t)
(test (round-numbers (test (equal~? (rotate
(normalize-shape
(image-shape
(rotate
90 90
(overlay/xy (rectangle 20 100 'solid 'purple) (overlay/xy (rectangle 20 100 'solid 'purple)
20 0 20 0
(ellipse 40 40 'solid 'orange)))))) (ellipse 40 40 'solid 'orange)))
=>
(round-numbers
(normalize-shape
(image-shape
(overlay/xy (rectangle 100 20 'solid 'purple) (overlay/xy (rectangle 100 20 'solid 'purple)
0 -40 0 -40
(ellipse 40 40 'solid 'orange)))))) (ellipse 40 40 'solid 'orange))
.1)
=>
#t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -856,68 +839,86 @@
=> =>
(round-numbers (line 20 -10 'black))) (round-numbers (line 20 -10 'black)))
(check-equal? (round-numbers (line 20 30 "red")) (test (round-numbers (line 20 30 "red"))
=>
(round-numbers (rotate 180 (line 20 30 "red")))) (round-numbers (rotate 180 (line 20 30 "red"))))
(check-equal? (round-numbers (line -30 20 "red")) (test (round-numbers (line -30 20 "red"))
=>
(round-numbers (line 30 -20 "red"))) (round-numbers (line 30 -20 "red")))
(check-equal? (image-width (add-line (rectangle 100 200 'solid 'black) (test (image-width (add-line (rectangle 100 200 'solid 'black)
10 10 90 190 "red")) 10 10 90 190 "red"))
=>
100) 100)
(check-equal? (image-height (add-line (rectangle 100 200 'solid 'black) (test (image-height (add-line (rectangle 100 200 'solid 'black)
10 10 90 190 "red")) 10 10 90 190 "red"))
=>
200) 200)
(check-equal? (image-width (add-line (rectangle 100 200 'solid 'black) (test (image-width (add-line (rectangle 100 200 'solid 'black)
10 10 200 200 "red")) 10 10 200 200 "red"))
=>
200) 200)
(check-equal? (image-height (add-line (rectangle 100 200 'solid 'black) (test (image-height (add-line (rectangle 100 200 'solid 'black)
10 10 200 200 "red")) 10 10 200 200 "red"))
=>
200) 200)
(check-equal? (image-width (add-line (rectangle 100 200 'solid 'black) (test (image-width (add-line (rectangle 100 200 'solid 'black)
10 10 300 300 "red")) 10 10 300 300 "red"))
=>
300) 300)
(check-equal? (image-height (add-line (rectangle 100 200 'solid 'black) (test (image-height (add-line (rectangle 100 200 'solid 'black)
10 10 300 300 "red")) 10 10 300 300 "red"))
=>
300) 300)
(check-equal? (image-width (add-line (rectangle 100 200 'solid 'black) (test (image-width (add-line (rectangle 100 200 'solid 'black)
-10 10 100 200 "red")) -10 10 100 200 "red"))
=>
110) 110)
(check-equal? (image-height (add-line (rectangle 100 200 'solid 'black) (test (image-height (add-line (rectangle 100 200 'solid 'black)
-10 10 100 200 "red")) -10 10 100 200 "red"))
=>
200) 200)
(check-equal? (image-width (add-line (rectangle 100 200 'solid 'black) (test (image-width (add-line (rectangle 100 200 'solid 'black)
10 -10 100 200 "red")) 10 -10 100 200 "red"))
=>
100) 100)
(check-equal? (image-height (add-line (rectangle 100 200 'solid 'black) (test (image-height (add-line (rectangle 100 200 'solid 'black)
10 -10 100 200 "red")) 10 -10 100 200 "red"))
=>
210) 210)
(check-equal? (image-width (add-line (rectangle 100 200 'solid 'black) (test (image-width (add-line (rectangle 100 200 'solid 'black)
100 200 10 -10 "red")) 100 200 10 -10 "red"))
=>
100) 100)
(check-equal? (image-height (add-line (rectangle 100 200 'solid 'black) (test (image-height (add-line (rectangle 100 200 'solid 'black)
100 200 10 -10 "red")) 100 200 10 -10 "red"))
=>
210) 210)
(check-equal? (image-width (add-line (rectangle 100 200 'solid 'black) (test (image-width (add-line (rectangle 100 200 'solid 'black)
100 200 -10 10 "red")) 100 200 -10 10 "red"))
=>
110) 110)
(check-equal? (image-height (add-line (rectangle 100 200 'solid 'black) (test (image-height (add-line (rectangle 100 200 'solid 'black)
100 200 -10 10 "red")) 100 200 -10 10 "red"))
=>
200) 200)
(let* ([txt (text "H" 24 'black)] (let* ([txt (text "H" 24 'black)]
[bl (image-baseline txt)]) [bl (image-baseline txt)])
(check-equal? (image-baseline (add-line txt 0 0 100 100 'red)) (test (image-baseline (add-line txt 0 0 100 100 'red))
=>
bl)) bl))
(let* ([txt (text "H" 24 'black)] (let* ([txt (text "H" 24 'black)]
[bl (image-baseline txt)]) [bl (image-baseline txt)])
(check-equal? (image-baseline (add-line txt 0 -10 100 100 'red)) (test (image-baseline (add-line txt 0 -10 100 100 'red))
=>
(+ bl 10))) (+ bl 10)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -959,13 +960,19 @@
;; bitmap tests ;; bitmap tests
;; ;;
(check-equal? (clamp-1 0 3 5) 3) (test (clamp-1 0 3 5)
(check-equal? (clamp-1 0 0 5) 0) => 3)
(check-equal? (clamp-1 0 -2 5) 0) (test (clamp-1 0 0 5)
(check-equal? (clamp-1 0 4 5) 4) => 0)
(check-equal? (clamp-1 0 7 5) 4) (test (clamp-1 0 -2 5)
=> 0)
(test (clamp-1 0 4 5)
=> 4)
(test (clamp-1 0 7 5)
=> 4)
(check-equal? (build-bytes 5 sqr) (list->bytes '(0 1 4 9 16))) (test (build-bytes 5 sqr)
=> (list->bytes '(0 1 4 9 16)))
(define onePixel (list->bytes '(255 0 0 255))) (define onePixel (list->bytes '(255 0 0 255)))
@ -984,38 +991,48 @@
255 0 0 255 255 0 255 0 255 0 0 255 ))) 255 0 0 255 255 0 255 0 255 0 0 255 )))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 0 0) (list->bytes '(255 0 0 255))) (test (bmbytes-ref/safe checker3x3 3 3 0 0) => (list->bytes '(255 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 1 1) (list->bytes '(255 0 0 255))) (test (bmbytes-ref/safe checker3x3 3 3 1 1) => (list->bytes '(255 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 2 2) (list->bytes '(255 0 0 255))) (test (bmbytes-ref/safe checker3x3 3 3 2 2) => (list->bytes '(255 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 1 2) (list->bytes '(255 0 255 0))) (test (bmbytes-ref/safe checker3x3 3 3 1 2) => (list->bytes '(255 0 255 0)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 0 3) (list->bytes '( 0 0 0 255))) (test (bmbytes-ref/safe checker3x3 3 3 0 3) => (list->bytes '( 0 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 -1 -1) (list->bytes '( 0 0 0 255))) (test (bmbytes-ref/safe checker3x3 3 3 -1 -1) => (list->bytes '( 0 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 -1 1) (list->bytes '( 0 0 255 0))) (test (bmbytes-ref/safe checker3x3 3 3 -1 1) => (list->bytes '( 0 0 255 0)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 1 19) (list->bytes '( 0 0 255 0))) (test (bmbytes-ref/safe checker3x3 3 3 1 19) => (list->bytes '( 0 0 255 0)))
#;
(test (bytes->list (interpolate checker2x2 2 2 1 0))
(check-equal? (bytes->list (interpolate checker2x2 2 2 1 0)) =>
'(255 0 255 0)) '(255 0 255 0))
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 0)) #;
(test (bytes->list (interpolate checker3x3 3 3 0 0))
=>
'(255 0 0 255)) '(255 0 0 255))
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 1)) #;
(test (bytes->list (interpolate checker3x3 3 3 0 1))
=>
'(255 0 255 0)) '(255 0 255 0))
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 2)) #;
(test (bytes->list (interpolate checker3x3 3 3 0 2))
=>
'(255 0 0 255)) '(255 0 0 255))
(check-equal? (bytes->list (interpolate checker3x3 3 3 0.5 0)) #;
(test (bytes->list (interpolate checker3x3 3 3 0.5 0))
=>
'(255 0 128 128)) '(255 0 128 128))
(check-equal? (image-width (bitmap icons/stop-16x16.png)) (test (image-width (bitmap icons/stop-16x16.png))
=>
16) 16)
(check-equal? (image-height (bitmap icons/stop-16x16.png)) (test (image-height (bitmap icons/stop-16x16.png))
=>
16) 16)
(check-equal? (let () (test (let ()
(define bmp (make-object bitmap% 4 4)) (define bmp (make-object bitmap% 4 4))
(define mask (make-object bitmap% 4 4)) (define mask (make-object bitmap% 4 4))
(define bdc (make-object bitmap-dc% bmp)) (define bdc (make-object bitmap-dc% bmp))
@ -1028,14 +1045,16 @@
(send bdc set-bitmap #f) (send bdc set-bitmap #f)
(let-values ([(bytes w h) (bitmap->bytes bmp mask)]) (let-values ([(bytes w h) (bitmap->bytes bmp mask)])
bytes)) bytes))
=>
(bytes-append #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" (bytes-append #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0"
#"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0"
#"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0"
#"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0")) #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0"))
;; ensure no error ;; ensure no error
(check-equal? (begin (scale 2 (make-object bitmap% 10 10)) (test (begin (scale 2 (make-object bitmap% 10 10))
(void)) (void))
=>
(void)) (void))
@ -1125,9 +1144,10 @@
(overlay (crop 4 4 16 16 (circle 8 'solid 'black)) (overlay (crop 4 4 16 16 (circle 8 'solid 'black))
(rectangle 40 40 'solid 'orange))) (rectangle 40 40 'solid 'orange)))
(check-equal? (place-image (circle 4 'solid 'black) (test (place-image (circle 4 'solid 'black)
-4 0 -4 0
(rectangle 40 40 'solid 'orange)) (rectangle 40 40 'solid 'orange))
=>
(overlay (crop 4 0 4 8 (circle 4 'solid 'black)) (overlay (crop 4 0 4 8 (circle 4 'solid 'black))
(rectangle 40 40 'solid 'orange))) (rectangle 40 40 'solid 'orange)))

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

@ -144,22 +144,12 @@ has been moved out).
;; a polygon is: ;; a polygon is:
;; ;;
;; - (make-polygon (listof vector) mode color) ;; - (make-polygon (listof vector) mode color)
(define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes (define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes)
#:property prop:equal+hash
(list (λ (a b rec) (polygon-equal? a b rec)) (λ (x y) 42) (λ (x y) 3)))
;; a line-segment is ;; a line-segment is
;; ;;
;; - (make-line-segment point point color) ;; - (make-line-segment point point color)
(define-struct/reg-mk line-segment (start end color) #:transparent #:omit-define-syntaxes (define-struct/reg-mk line-segment (start end color) #:transparent #:omit-define-syntaxes)
#:property prop:equal+hash
(list (λ (a b rec) (and (or (and (rec (line-segment-start a) (line-segment-start b))
(rec (line-segment-end a) (line-segment-end b)))
(and (rec (line-segment-start a) (line-segment-end b))
(rec (line-segment-end a) (line-segment-start b))))
(rec (line-segment-color a) (line-segment-color b))))
(λ (x y) 42)
(λ (x y) 3)))
;; a curve-segment is ;; a curve-segment is
;; ;;
@ -184,43 +174,6 @@ has been moved out).
;; a mode is either 'solid or 'outline (indicating a pen width for outline mode) ;; a mode is either 'solid or 'outline (indicating a pen width for outline mode)
(define (polygon-equal? p1 p2 eq-recur)
(and (eq-recur (polygon-mode p1) (polygon-mode p2))
(eq-recur (polygon-color p1) (polygon-color p2))
(let ([p1-points (polygon-points p1)]
[p2-points (polygon-points p2)])
(or (and (null? p1-points)
(null? p2-points))
(and (not (or (null? p1-points)
(null? p2-points)))
(or (compare-all-rotations p1-points p2-points eq-recur)
(compare-all-rotations p1-points (reverse p2-points) eq-recur)))))))
;; returns #t when there is some rotation of l1 that is equal to l2
(define (compare-all-rotations l1 l2 compare)
(cond
[(and (null? l1) (null? l2)) #t]
[else
(let ([v1 (list->vector l1)]
[v2 (list->vector l2)])
(and (= (vector-length v1)
(vector-length v2))
(let o-loop ([init 0])
(cond
[(= init (vector-length v1)) #f]
[else
(or (let i-loop ([i 0])
(cond
[(= i (vector-length v2))
#t]
[else
(let ([j (modulo (+ init i) (vector-length v1))])
(and (compare (vector-ref v1 j)
(vector-ref v2 i))
(i-loop (+ i 1))))]))
(o-loop (+ init 1)))]))))]))
; ;
; ;
@ -242,11 +195,15 @@ has been moved out).
get-shape set-shape get-bb get-shape set-shape get-bb
get-normalized? set-normalized get-normalized-shape) get-normalized? set-normalized get-normalized-shape)
(define skip-image-equality-fast-path (make-parameter #f))
(define image% (define image%
(class* snip% (equal<%>) (class* snip% (equal<%>)
(init-field shape bb normalized?) (init-field shape bb normalized?)
(define/public (equal-to? that eq-recur) (define/public (equal-to? that eq-recur)
(or (eq? this that) (or (eq? this that)
(and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective
(equal? (get-normalized-shape) (send that get-normalized-shape)))
(and (is-a? that image%) (and (is-a? that image%)
(same-bb? bb (send that get-bb)) (same-bb? bb (send that get-bb))
(let* ([w (round (inexact->exact (bb-right bb)))] (let* ([w (round (inexact->exact (bb-right bb)))]
@ -863,9 +820,10 @@ the mask bitmap and the original bitmap are all together in a single bytes!
image? image?
text->font text->font
compare-all-rotations
render-image render-image
skip-image-equality-fast-path
scale-np-atomic) scale-np-atomic)
;; method names ;; method names