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)])
#`(begin
;(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")
@ -79,36 +81,16 @@
(map loop (cdr (vector->list (struct->vector 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
;;
(check-equal? (ellipse 40 40 'outline 'black)
(test (ellipse 40 40 'outline 'black)
=>
(circle 20 'outline 'black))
(check-equal? (ellipse 60 60 'solid 'red)
(test (ellipse 60 60 'solid 'red)
=>
(circle 30 'solid 'red))
@ -195,31 +177,36 @@
;; polygon equality
;;
(check-equal? (polygon (list (make-posn 0 0)
(test (polygon (list (make-posn 0 0)
(make-posn 10 10)
(make-posn 10 0))
"solid" "plum")
=>
(polygon (list (make-posn 10 10)
(make-posn 10 0)
(make-posn 0 0))
"solid" "plum"))
(check-equal? (polygon (list (make-posn 0 0)
(test (polygon (list (make-posn 0 0)
(make-posn 0 10)
(make-posn 10 10)
(make-posn 10 0))
"solid" "plum")
=>
(rectangle 10 10 "solid" "plum"))
;; 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))
=>
#f)
;; 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))
(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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -692,21 +679,17 @@
=>
#t)
(test (round-numbers
(normalize-shape
(image-shape
(rotate
(test (equal~? (rotate
90
(overlay/xy (rectangle 20 100 'solid 'purple)
20 0
(ellipse 40 40 'solid 'orange))))))
=>
(round-numbers
(normalize-shape
(image-shape
(ellipse 40 40 'solid 'orange)))
(overlay/xy (rectangle 100 20 'solid 'purple)
0 -40
(ellipse 40 40 'solid 'orange))))))
(ellipse 40 40 'solid 'orange))
.1)
=>
#t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@ -856,68 +839,86 @@
=>
(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"))))
(check-equal? (round-numbers (line -30 20 "red"))
(test (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"))
=>
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"))
=>
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"))
=>
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"))
=>
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"))
=>
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"))
=>
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"))
=>
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"))
=>
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"))
=>
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"))
=>
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)
(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"))
=>
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"))
=>
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"))
=>
200)
(let* ([txt (text "H" 24 'black)]
[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))
(let* ([txt (text "H" 24 'black)]
[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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -959,13 +960,19 @@
;; bitmap tests
;;
(check-equal? (clamp-1 0 3 5) 3)
(check-equal? (clamp-1 0 0 5) 0)
(check-equal? (clamp-1 0 -2 5) 0)
(check-equal? (clamp-1 0 4 5) 4)
(check-equal? (clamp-1 0 7 5) 4)
(test (clamp-1 0 3 5)
=> 3)
(test (clamp-1 0 0 5)
=> 0)
(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)))
@ -984,38 +991,48 @@
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)))
(check-equal? (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)))
(check-equal? (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)))
(check-equal? (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)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 1 19) (list->bytes '( 0 0 255 0)))
(test (bmbytes-ref/safe checker3x3 3 3 0 0) => (list->bytes '(255 0 0 255)))
(test (bmbytes-ref/safe checker3x3 3 3 1 1) => (list->bytes '(255 0 0 255)))
(test (bmbytes-ref/safe checker3x3 3 3 2 2) => (list->bytes '(255 0 0 255)))
(test (bmbytes-ref/safe checker3x3 3 3 1 2) => (list->bytes '(255 0 255 0)))
(test (bmbytes-ref/safe checker3x3 3 3 0 3) => (list->bytes '( 0 0 0 255)))
(test (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 255 0)))
(test (bmbytes-ref/safe checker3x3 3 3 1 19) => (list->bytes '( 0 0 255 0)))
(check-equal? (bytes->list (interpolate checker2x2 2 2 1 0))
#;
(test (bytes->list (interpolate checker2x2 2 2 1 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))
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 1))
#;
(test (bytes->list (interpolate checker3x3 3 3 0 1))
=>
'(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))
(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))
(check-equal? (image-width (bitmap icons/stop-16x16.png))
(test (image-width (bitmap icons/stop-16x16.png))
=>
16)
(check-equal? (image-height (bitmap icons/stop-16x16.png))
(test (image-height (bitmap icons/stop-16x16.png))
=>
16)
(check-equal? (let ()
(test (let ()
(define bmp (make-object bitmap% 4 4))
(define mask (make-object bitmap% 4 4))
(define bdc (make-object bitmap-dc% bmp))
@ -1028,14 +1045,16 @@
(send bdc set-bitmap #f)
(let-values ([(bytes w h) (bitmap->bytes bmp mask)])
bytes))
=>
(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" #"\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
(check-equal? (begin (scale 2 (make-object bitmap% 10 10))
(test (begin (scale 2 (make-object bitmap% 10 10))
(void))
=>
(void))
@ -1125,9 +1144,10 @@
(overlay (crop 4 4 16 16 (circle 8 'solid 'black))
(rectangle 40 40 'solid 'orange)))
(check-equal? (place-image (circle 4 'solid 'black)
(test (place-image (circle 4 'solid 'black)
-4 0
(rectangle 40 40 'solid 'orange))
=>
(overlay (crop 4 0 4 8 (circle 4 'solid 'black))
(rectangle 40 40 'solid 'orange)))

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

@ -144,22 +144,12 @@ has been moved out).
;; a polygon is:
;;
;; - (make-polygon (listof vector) mode color)
(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)))
(define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes)
;; a line-segment is
;;
;; - (make-line-segment point point color)
(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)))
(define-struct/reg-mk line-segment (start end color) #:transparent #:omit-define-syntaxes)
;; 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)
(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-normalized? set-normalized get-normalized-shape)
(define skip-image-equality-fast-path (make-parameter #f))
(define image%
(class* snip% (equal<%>)
(init-field shape bb normalized?)
(define/public (equal-to? that eq-recur)
(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%)
(same-bb? bb (send that get-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?
text->font
compare-all-rotations
render-image
skip-image-equality-fast-path
scale-np-atomic)
;; method names