diff --git a/collects/redex/tests/bitmap-test-util.rkt b/collects/redex/tests/bitmap-test-util.rkt index 4b6a9d7db5..1abbd89e8a 100644 --- a/collects/redex/tests/bitmap-test-util.rkt +++ b/collects/redex/tests/bitmap-test-util.rkt @@ -115,7 +115,8 @@ [old (make-object bitmap-dc% old-bitmap)] [diff (make-object bitmap-dc% diff-bitmap)] [new-c (make-object color%)] - [old-c (make-object color%)]) + [old-c (make-object color%)] + [number-of-different-pixels 0]) (let loop ([x 0]) (unless (= x w) (let loop ([y 0]) @@ -134,6 +135,7 @@ (send diff set-pixel x y new-c)] [else (send new-c set 255 0 0) + (set! number-of-different-pixels (+ number-of-different-pixels 1)) (send diff set-pixel x y new-c)])] [else (send new-c set 255 0 0) @@ -143,7 +145,7 @@ (send diff set-bitmap #f) (send old set-bitmap #f) (send new set-bitmap #f) - diff-bitmap)) + (values diff-bitmap number-of-different-pixels))) (define test-result-single-panel #f) (define (get-test-result-single-panel) @@ -180,12 +182,14 @@ (define (make-failed-panel line-number filename old-bitmap new-bitmap) (define diff-bitmap 'unk) + (define number-of-different-pixels #f) (define f (new vertical-panel% [parent (get-test-result-single-panel)])) (define msg (new message% [label (format "line ~a" line-number)] [parent f])) (define hp (new horizontal-panel% [parent f])) (define vp1 (new vertical-panel% [parent hp])) (define vp2 (new vertical-panel% [parent hp])) (define computing-label "Computing diff ...") + (define differences-msg (new message% [label ""] [auto-resize #t] [parent f])) (define computing-msg (new message% [label computing-label] [parent f])) (define chk (new check-box% [label "Show diff"] @@ -204,11 +208,12 @@ (send computing-msg set-label computing-label) (thread (λ () - (set! diff-bitmap (compute-diffs old-bitmap new-bitmap)) + (set!-values (diff-bitmap number-of-different-pixels) (compute-diffs old-bitmap new-bitmap)) (queue-callback (λ () (send computing-msg set-label "") (send chk enable #t) + (send differences-msg set-label (format "~a pixels different" number-of-different-pixels)) (update-check)))))] [else (update-check)]))])) @@ -220,10 +225,14 @@ (λ (x y) (send new-bitmap save-file filename 'png))])) (define left-label (new message% [parent vp1] [label "Old"])) + (define left-size (new message% [parent vp1] + [label (format "~ax~a" (send old-bitmap get-width) (send old-bitmap get-height))])) (define left-hand (new message% [parent vp1] [label old-bitmap])) (define right-label (new message% [parent vp2] [label "New"])) + (define right-size (new message% [parent vp2] + [label (format "~ax~a" (send new-bitmap get-width) (send new-bitmap get-height))])) (define right-hand (new message% [parent vp2] [label new-bitmap])) diff --git a/collects/redex/tests/bitmap-test.rkt b/collects/redex/tests/bitmap-test.rkt index fa14b866f3..3fa53cc5de 100644 --- a/collects/redex/tests/bitmap-test.rkt +++ b/collects/redex/tests/bitmap-test.rkt @@ -170,24 +170,31 @@ "metafunction-Name-vertical.png") ;; in horizontal mode: -(btest (vl-append - (parameterize ([metafunction-pict-style 'left-right]) - (render-metafunction Name)) - (parameterize ([metafunction-pict-style 'left-right/beside-side-conditions]) - (render-metafunction Name)) - (parameterize ([metafunction-pict-style 'left-right/vertical-side-conditions]) - (render-metafunction Name)) - (parameterize ([metafunction-pict-style 'left-right/compact-side-conditions]) - (render-metafunction Name)) - (parameterize ([metafunction-pict-style 'left-right/compact-side-conditions] - [linebreaks '(#t #f)]) - (render-metafunction Name)) - (parameterize ([metafunction-pict-style 'left-right/compact-side-conditions] - [linebreaks '(#f #t)]) - (render-metafunction Name)) - (parameterize ([metafunction-pict-style 'left-right/beside-side-conditions] - [linebreaks '(#t #f)]) - (render-metafunction Name))) +(btest (vl-append + (clip + (parameterize ([metafunction-pict-style 'left-right]) + (render-metafunction Name))) + (clip + (parameterize ([metafunction-pict-style 'left-right/beside-side-conditions]) + (render-metafunction Name))) + (clip + (parameterize ([metafunction-pict-style 'left-right/vertical-side-conditions]) + (render-metafunction Name))) + (clip + (parameterize ([metafunction-pict-style 'left-right/compact-side-conditions]) + (render-metafunction Name))) + (clip + (parameterize ([metafunction-pict-style 'left-right/compact-side-conditions] + [linebreaks '(#t #f)]) + (render-metafunction Name))) + (clip + (parameterize ([metafunction-pict-style 'left-right/compact-side-conditions] + [linebreaks '(#f #t)]) + (render-metafunction Name))) + (clip + (parameterize ([metafunction-pict-style 'left-right/beside-side-conditions] + [linebreaks '(#t #f)]) + (render-metafunction Name)))) "metafunction-Name-horizontal.png") ;; makes sure that there is no overlap inside or across metafunction calls