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

use clipping in the recent commit to actually test bounding boxes

Browse Source
This commit is contained in:
Robby Findler 2013-03-06 07:44:27 -06:00
parent 1bd11a0b77
commit e6dc9c28b4
2 changed files with 37 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/redex/tests/bitmap-test-util.rkt
View File

@ -115,7 +115,8 @@
[old (make-object bitmap-dc% old-bitmap)] [old (make-object bitmap-dc% old-bitmap)]
[diff (make-object bitmap-dc% diff-bitmap)] [diff (make-object bitmap-dc% diff-bitmap)]
[new-c (make-object color%)] [new-c (make-object color%)]
[old-c (make-object color%)]) [old-c (make-object color%)]
[number-of-different-pixels 0])
(let loop ([x 0]) (let loop ([x 0])
(unless (= x w) (unless (= x w)
(let loop ([y 0]) (let loop ([y 0])
@ -134,6 +135,7 @@
(send diff set-pixel x y new-c)] (send diff set-pixel x y new-c)]
[else [else
(send new-c set 255 0 0) (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)])] (send diff set-pixel x y new-c)])]
[else [else
(send new-c set 255 0 0) (send new-c set 255 0 0)
@ -143,7 +145,7 @@
(send diff set-bitmap #f) (send diff set-bitmap #f)
(send old set-bitmap #f) (send old set-bitmap #f)
(send new set-bitmap #f) (send new set-bitmap #f)
diff-bitmap)) (values diff-bitmap number-of-different-pixels)))
(define test-result-single-panel #f) (define test-result-single-panel #f)
(define (get-test-result-single-panel) (define (get-test-result-single-panel)
@ -180,12 +182,14 @@
(define (make-failed-panel line-number filename old-bitmap new-bitmap) (define (make-failed-panel line-number filename old-bitmap new-bitmap)
(define diff-bitmap 'unk) (define diff-bitmap 'unk)
(define number-of-different-pixels #f)
(define f (new vertical-panel% [parent (get-test-result-single-panel)])) (define f (new vertical-panel% [parent (get-test-result-single-panel)]))
(define msg (new message% [label (format "line ~a" line-number)] [parent f])) (define msg (new message% [label (format "line ~a" line-number)] [parent f]))
(define hp (new horizontal-panel% [parent f])) (define hp (new horizontal-panel% [parent f]))
(define vp1 (new vertical-panel% [parent hp])) (define vp1 (new vertical-panel% [parent hp]))
(define vp2 (new vertical-panel% [parent hp])) (define vp2 (new vertical-panel% [parent hp]))
(define computing-label "Computing diff ...") (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 computing-msg (new message% [label computing-label] [parent f]))
(define chk (new check-box% (define chk (new check-box%
[label "Show diff"] [label "Show diff"]
@ -204,11 +208,12 @@
(send computing-msg set-label computing-label) (send computing-msg set-label computing-label)
(thread (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 (queue-callback
(λ () (λ ()
(send computing-msg set-label "") (send computing-msg set-label "")
(send chk enable #t) (send chk enable #t)
(send differences-msg set-label (format "~a pixels different" number-of-different-pixels))
(update-check)))))] (update-check)))))]
[else [else
(update-check)]))])) (update-check)]))]))
@ -220,10 +225,14 @@
(λ (x y) (λ (x y)
(send new-bitmap save-file filename 'png))])) (send new-bitmap save-file filename 'png))]))
(define left-label (new message% [parent vp1] [label "Old"])) (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% (define left-hand (new message%
[parent vp1] [parent vp1]
[label old-bitmap])) [label old-bitmap]))
(define right-label (new message% [parent vp2] [label "New"])) (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% (define right-hand (new message%
[parent vp2] [parent vp2]
[label new-bitmap])) [label new-bitmap]))

41
collects/redex/tests/bitmap-test.rkt
View File

@ -171,23 +171,30 @@
;; in horizontal mode: ;; in horizontal mode:
(btest (vl-append (btest (vl-append
(parameterize ([metafunction-pict-style 'left-right]) (clip
(render-metafunction Name)) (parameterize ([metafunction-pict-style 'left-right])
(parameterize ([metafunction-pict-style 'left-right/beside-side-conditions]) (render-metafunction Name)))
(render-metafunction Name)) (clip
(parameterize ([metafunction-pict-style 'left-right/vertical-side-conditions]) (parameterize ([metafunction-pict-style 'left-right/beside-side-conditions])
(render-metafunction Name)) (render-metafunction Name)))
(parameterize ([metafunction-pict-style 'left-right/compact-side-conditions]) (clip
(render-metafunction Name)) (parameterize ([metafunction-pict-style 'left-right/vertical-side-conditions])
(parameterize ([metafunction-pict-style 'left-right/compact-side-conditions] (render-metafunction Name)))
[linebreaks '(#t #f)]) (clip
(render-metafunction Name)) (parameterize ([metafunction-pict-style 'left-right/compact-side-conditions])
(parameterize ([metafunction-pict-style 'left-right/compact-side-conditions] (render-metafunction Name)))
[linebreaks '(#f #t)]) (clip
(render-metafunction Name)) (parameterize ([metafunction-pict-style 'left-right/compact-side-conditions]
(parameterize ([metafunction-pict-style 'left-right/beside-side-conditions] [linebreaks '(#t #f)])
[linebreaks '(#t #f)]) (render-metafunction Name)))
(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") "metafunction-Name-horizontal.png")
;; makes sure that there is no overlap inside or across metafunction calls ;; makes sure that there is no overlap inside or across metafunction calls