diff --git a/collects/redex/tests/bitmap-test-util.rkt b/collects/redex/tests/bitmap-test-util.rkt index 791346e8d8..6d6479760e 100644 --- a/collects/redex/tests/bitmap-test-util.rkt +++ b/collects/redex/tests/bitmap-test-util.rkt @@ -5,6 +5,7 @@ racket/gui/base (for-syntax racket/base) racket/class + racket/promise "../pict.rkt" "../reduction-semantics.rkt") @@ -35,24 +36,23 @@ (build-path bmps-dir raw-bitmap-filename)] [old-bitmap (if (file-exists? bitmap-filename) - (make-object bitmap% bitmap-filename) - (let* ([bm (make-object bitmap% 100 20)] + (read-bitmap bitmap-filename) + (let* ([bm (make-screen-bitmap 100 20)] [bdc (make-object bitmap-dc% bm)]) (send bdc clear) (send bdc draw-text "does not exist" 0 0) (send bdc set-bitmap #f) bm))] - [new-bitmap (make-object bitmap% + [new-bitmap (make-screen-bitmap (ceiling (inexact->exact (pict-width pict))) (ceiling (inexact->exact (pict-height pict))))] [bdc (make-object bitmap-dc% new-bitmap)]) (send bdc clear) (draw-pict pict bdc 0 0) (send bdc set-bitmap #f) - (let ([diff-bitmap (compute-diffs old-bitmap new-bitmap)]) - (when diff-bitmap - (let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)]) - (set! failed (append failed (list failed-panel)))))))) + (unless (bitmaps-same? old-bitmap new-bitmap) + (let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap)]) + (set! failed (append failed (list failed-panel))))))) (define (set-fonts/call thunk) (case (system-type) @@ -80,49 +80,57 @@ (unless (member face (get-face-list)) (error 'verify-face "unknown face: ~s" face)) face) - + +(define (bitmaps-same? old-bitmap new-bitmap) + (let ([w (send old-bitmap get-width)] + [h (send old-bitmap get-height)]) + (and (= w (send new-bitmap get-width)) + (= h (send new-bitmap get-height)) + (let ([bytes1 (make-bytes (* w h 4))] + [bytes2 (make-bytes (* w h 4))]) + (send old-bitmap get-argb-pixels 0 0 w h bytes1) + (send new-bitmap get-argb-pixels 0 0 w h bytes2) + (equal? bytes1 bytes2))))) + (define (compute-diffs old-bitmap new-bitmap) - (let* ([w (max (send old-bitmap get-width) - (send new-bitmap get-width))] - [h (max (send old-bitmap get-height) - (send new-bitmap get-height))] - [diff-bitmap (make-object bitmap% w h)] - [new (make-object bitmap-dc% new-bitmap)] - [old (make-object bitmap-dc% old-bitmap)] - [diff (make-object bitmap-dc% diff-bitmap)] - [new-c (make-object color%)] - [old-c (make-object color%)] - [any-different? #f]) - (let loop ([x 0]) - (unless (= x w) - (let loop ([y 0]) - (unless (= y h) - (cond - [(and (< x (send new-bitmap get-width)) - (< y (send new-bitmap get-height)) - (< x (send old-bitmap get-width)) - (< y (send old-bitmap get-height))) - (send new get-pixel x y new-c) - (send old get-pixel x y old-c) - (cond - [(and (= (send new-c red) (send old-c red)) - (= (send new-c green) (send old-c green)) - (= (send new-c blue) (send old-c blue))) - (send diff set-pixel x y new-c)] - [else - (set! any-different? #t) - (send new-c set 255 0 0) - (send diff set-pixel x y new-c)])] - [else - (set! any-different? #t) - (send new-c set 255 0 0) - (send diff set-pixel x y new-c)]) - (loop (+ y 1)))) - (loop (+ x 1)))) - (send diff set-bitmap #f) - (send old set-bitmap #f) - (send new set-bitmap #f) - (and any-different? diff-bitmap))) + (let* ([w (max (send old-bitmap get-width) + (send new-bitmap get-width))] + [h (max (send old-bitmap get-height) + (send new-bitmap get-height))] + [diff-bitmap (make-bitmap w h)] ;; this bitmap holds the diff only, that we compute via set-pixel, not drawing + [new (make-object bitmap-dc% new-bitmap)] + [old (make-object bitmap-dc% old-bitmap)] + [diff (make-object bitmap-dc% diff-bitmap)] + [new-c (make-object color%)] + [old-c (make-object color%)]) + (let loop ([x 0]) + (unless (= x w) + (let loop ([y 0]) + (unless (= y h) + (cond + [(and (< x (send new-bitmap get-width)) + (< y (send new-bitmap get-height)) + (< x (send old-bitmap get-width)) + (< y (send old-bitmap get-height))) + (send new get-pixel x y new-c) + (send old get-pixel x y old-c) + (cond + [(and (= (send new-c red) (send old-c red)) + (= (send new-c green) (send old-c green)) + (= (send new-c blue) (send old-c blue))) + (send diff set-pixel x y new-c)] + [else + (send new-c set 255 0 0) + (send diff set-pixel x y new-c)])] + [else + (send new-c set 255 0 0) + (send diff set-pixel x y new-c)]) + (loop (+ y 1)))) + (loop (+ x 1)))) + (send diff set-bitmap #f) + (send old set-bitmap #f) + (send new set-bitmap #f) + diff-bitmap)) (define test-result-single-panel #f) (define (get-test-result-single-panel) @@ -135,7 +143,7 @@ (define lined (new vertical-panel% [parent f] [style '(border)])) (define sp (new panel:single% [parent lined])) (define current-index 0) - (define hp (new horizontal-panel% [parent f])) + (define hp (new horizontal-panel% [parent f] [alignment '(center center)])) (define prev (new button% [label "Prev"] @@ -157,7 +165,8 @@ (send f show #t) sp)])) -(define (make-failed-panel line-number filename old-bitmap new-bitmap diff-bitmap) +(define (make-failed-panel line-number filename old-bitmap new-bitmap) + (define diff-bitmap (delay (compute-diffs old-bitmap new-bitmap))) (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])) @@ -170,7 +179,7 @@ (λ (_1 _2) (cond [(send chk get-value) - (send right-hand set-label diff-bitmap)] + (send right-hand set-label (force diff-bitmap))] [else (send right-hand set-label new-bitmap)]))])) (define btn (new button% @@ -182,11 +191,11 @@ (define left-label (new message% [parent vp1] [label "Old"])) (define left-hand (new message% [parent vp1] - [label diff-bitmap])) + [label old-bitmap])) (define right-label (new message% [parent vp2] [label "New"])) (define right-hand (new message% [parent vp2] - [label diff-bitmap])) + [label new-bitmap])) (send left-hand set-label old-bitmap) (send right-hand set-label new-bitmap) f) diff --git a/collects/redex/tests/bitmap-test.rkt b/collects/redex/tests/bitmap-test.rkt index 7c5639abd1..e9304108be 100644 --- a/collects/redex/tests/bitmap-test.rkt +++ b/collects/redex/tests/bitmap-test.rkt @@ -1,6 +1,7 @@ -#lang scheme +#lang racket (require "bitmap-test-util.rkt" - "../main.rkt") + "../main.rkt" + slideshow/pict) ;; tests: ;; - language, @@ -293,14 +294,6 @@ [(sum (s n_1) n_2 (s n_3)) (sum n_1 n_2 n_3)]) - (test (render-judgment-form sum) "judgment-form-not-rewritten.png") - - (test (with-compound-rewriter - 'sum - (λ (lws) (list "" (list-ref lws 2) " + " (list-ref lws 3) " = " (list-ref lws 4))) - (render-judgment-form sum)) - "judgment-form-rewritten.png") - (define-judgment-form nats #:mode (mfw I O) [(mfw n_1 n_2) @@ -309,16 +302,12 @@ (define-metafunction nats [(f n) n]) - (test (render-judgment-form mfw) "judgment-form-metafunction-where.png") - (define-judgment-form nats #:mode (nps I O) [(nps (name a (s n_1)) n_2) (nps z (name n_1 (s (s n_1)))) (where (name b n_2) z)]) - (test (render-judgment-form nps) "judgment-form-name-patterns.png") - (define-judgment-form nats #:mode (lt2 I) [(lt2 z)] @@ -330,7 +319,22 @@ (lt2 n) ... (sum z z z)]) - (test (render-judgment-form uses-ellipses) "judgment-form-ellipsis.png")) + (test (vc-append + 10 + (render-judgment-form sum) + + (with-compound-rewriter + 'sum + (λ (lws) (list "" (list-ref lws 2) " + " (list-ref lws 3) " = " (list-ref lws 4))) + (render-judgment-form sum)) + + (render-judgment-form mfw) + + (render-judgment-form nps) + + (render-judgment-form uses-ellipses)) + + "judgment-form-examples.png")) (let () (define-language STLC diff --git a/collects/redex/tests/bmps-macosx/extended-language.png b/collects/redex/tests/bmps-macosx/extended-language.png index ae36826276..bb250ed924 100644 Binary files a/collects/redex/tests/bmps-macosx/extended-language.png and b/collects/redex/tests/bmps-macosx/extended-language.png differ diff --git a/collects/redex/tests/bmps-macosx/extended-reduction-relation.png b/collects/redex/tests/bmps-macosx/extended-reduction-relation.png index 923834135a..8e90639641 100644 Binary files a/collects/redex/tests/bmps-macosx/extended-reduction-relation.png and b/collects/redex/tests/bmps-macosx/extended-reduction-relation.png differ diff --git a/collects/redex/tests/bmps-macosx/holes.png b/collects/redex/tests/bmps-macosx/holes.png index f1bc0b3c0e..a8ba8acb6b 100644 Binary files a/collects/redex/tests/bmps-macosx/holes.png and b/collects/redex/tests/bmps-macosx/holes.png differ diff --git a/collects/redex/tests/bmps-macosx/judgment-form-ellipsis.png b/collects/redex/tests/bmps-macosx/judgment-form-ellipsis.png deleted file mode 100644 index 5d14087950..0000000000 Binary files a/collects/redex/tests/bmps-macosx/judgment-form-ellipsis.png and /dev/null differ diff --git a/collects/redex/tests/bmps-macosx/judgment-form-examples.png b/collects/redex/tests/bmps-macosx/judgment-form-examples.png new file mode 100644 index 0000000000..5799374490 Binary files /dev/null and b/collects/redex/tests/bmps-macosx/judgment-form-examples.png differ diff --git a/collects/redex/tests/bmps-macosx/judgment-form-metafunction-where.png b/collects/redex/tests/bmps-macosx/judgment-form-metafunction-where.png deleted file mode 100644 index 85c4a46ce4..0000000000 Binary files a/collects/redex/tests/bmps-macosx/judgment-form-metafunction-where.png and /dev/null differ diff --git a/collects/redex/tests/bmps-macosx/judgment-form-name-patterns.png b/collects/redex/tests/bmps-macosx/judgment-form-name-patterns.png deleted file mode 100644 index c3141ea37a..0000000000 Binary files a/collects/redex/tests/bmps-macosx/judgment-form-name-patterns.png and /dev/null differ diff --git a/collects/redex/tests/bmps-macosx/judgment-form-not-rewritten.png b/collects/redex/tests/bmps-macosx/judgment-form-not-rewritten.png deleted file mode 100644 index 65ddce9c67..0000000000 Binary files a/collects/redex/tests/bmps-macosx/judgment-form-not-rewritten.png and /dev/null differ diff --git a/collects/redex/tests/bmps-macosx/judgment-form-rewritten.png b/collects/redex/tests/bmps-macosx/judgment-form-rewritten.png deleted file mode 100644 index b872e09522..0000000000 Binary files a/collects/redex/tests/bmps-macosx/judgment-form-rewritten.png and /dev/null differ diff --git a/collects/redex/tests/bmps-macosx/language-nox.png b/collects/redex/tests/bmps-macosx/language-nox.png index f33c1e4483..183da1e952 100644 Binary files a/collects/redex/tests/bmps-macosx/language-nox.png and b/collects/redex/tests/bmps-macosx/language-nox.png differ diff --git a/collects/redex/tests/bmps-macosx/language.png b/collects/redex/tests/bmps-macosx/language.png index de4143a1a0..feb2214103 100644 Binary files a/collects/redex/tests/bmps-macosx/language.png and b/collects/redex/tests/bmps-macosx/language.png differ diff --git a/collects/redex/tests/bmps-macosx/lw.png b/collects/redex/tests/bmps-macosx/lw.png index 3be7001fb6..10c43c88f8 100644 Binary files a/collects/redex/tests/bmps-macosx/lw.png and b/collects/redex/tests/bmps-macosx/lw.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png b/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png index ebcf7fc348..31c61a6a71 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png and b/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-Name.png b/collects/redex/tests/bmps-macosx/metafunction-Name.png index 787864e48e..d54f35ae93 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-Name.png and b/collects/redex/tests/bmps-macosx/metafunction-Name.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-T.png b/collects/redex/tests/bmps-macosx/metafunction-T.png index f5111bbc88..f3e5f2c345 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-T.png and b/collects/redex/tests/bmps-macosx/metafunction-T.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-TL.png b/collects/redex/tests/bmps-macosx/metafunction-TL.png index f8b6b13004..93259f0be6 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-TL.png and b/collects/redex/tests/bmps-macosx/metafunction-TL.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-judgment-holds.png b/collects/redex/tests/bmps-macosx/metafunction-judgment-holds.png index df49babea9..4ed57192e0 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-judgment-holds.png and b/collects/redex/tests/bmps-macosx/metafunction-judgment-holds.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png b/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png index 227cbbf264..4d18949b70 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png and b/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-subst.png b/collects/redex/tests/bmps-macosx/metafunction-subst.png index 055e608205..8cfddb4fcd 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-subst.png and b/collects/redex/tests/bmps-macosx/metafunction-subst.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction.png b/collects/redex/tests/bmps-macosx/metafunction.png index 4c9ef04b9e..8a6c54eeee 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction.png and b/collects/redex/tests/bmps-macosx/metafunction.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunctions-multiple.png b/collects/redex/tests/bmps-macosx/metafunctions-multiple.png index fded27706c..577cd5ea5a 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunctions-multiple.png and b/collects/redex/tests/bmps-macosx/metafunctions-multiple.png differ diff --git a/collects/redex/tests/bmps-macosx/mf-hidden.png b/collects/redex/tests/bmps-macosx/mf-hidden.png index fbeafba878..3369e5857c 100644 Binary files a/collects/redex/tests/bmps-macosx/mf-hidden.png and b/collects/redex/tests/bmps-macosx/mf-hidden.png differ diff --git a/collects/redex/tests/bmps-macosx/rdups-delimited.png b/collects/redex/tests/bmps-macosx/rdups-delimited.png index f3d2ee6050..9ad2fd2932 100644 Binary files a/collects/redex/tests/bmps-macosx/rdups-delimited.png and b/collects/redex/tests/bmps-macosx/rdups-delimited.png differ diff --git a/collects/redex/tests/bmps-macosx/rdups-undelimited.png b/collects/redex/tests/bmps-macosx/rdups-undelimited.png index 316ab511af..353d14dff3 100644 Binary files a/collects/redex/tests/bmps-macosx/rdups-undelimited.png and b/collects/redex/tests/bmps-macosx/rdups-undelimited.png differ diff --git a/collects/redex/tests/bmps-macosx/red-with-where-name.png b/collects/redex/tests/bmps-macosx/red-with-where-name.png index b5b3a0d3f5..df1bf32cf2 100644 Binary files a/collects/redex/tests/bmps-macosx/red-with-where-name.png and b/collects/redex/tests/bmps-macosx/red-with-where-name.png differ diff --git a/collects/redex/tests/bmps-macosx/red2.png b/collects/redex/tests/bmps-macosx/red2.png index 058ec78f92..459f59a650 100644 Binary files a/collects/redex/tests/bmps-macosx/red2.png and b/collects/redex/tests/bmps-macosx/red2.png differ diff --git a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png index 161da2d649..8939f396f1 100644 Binary files a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png and b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png differ diff --git a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png index 9a85048165..c842cb2b17 100644 Binary files a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png and b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png differ diff --git a/collects/redex/tests/bmps-macosx/reduction-relation.png b/collects/redex/tests/bmps-macosx/reduction-relation.png index 7ebadf8e80..7a5f8f49bf 100644 Binary files a/collects/redex/tests/bmps-macosx/reduction-relation.png and b/collects/redex/tests/bmps-macosx/reduction-relation.png differ diff --git a/collects/redex/tests/bmps-macosx/relation-with-name.png b/collects/redex/tests/bmps-macosx/relation-with-name.png index 5a8f1dd612..8095b150a8 100644 Binary files a/collects/redex/tests/bmps-macosx/relation-with-name.png and b/collects/redex/tests/bmps-macosx/relation-with-name.png differ diff --git a/collects/redex/tests/bmps-macosx/relation.png b/collects/redex/tests/bmps-macosx/relation.png index 5ad5b6abfa..d699b98437 100644 Binary files a/collects/redex/tests/bmps-macosx/relation.png and b/collects/redex/tests/bmps-macosx/relation.png differ diff --git a/collects/redex/tests/bmps-macosx/rr-hidden.png b/collects/redex/tests/bmps-macosx/rr-hidden.png index 923834135a..8e90639641 100644 Binary files a/collects/redex/tests/bmps-macosx/rr-hidden.png and b/collects/redex/tests/bmps-macosx/rr-hidden.png differ diff --git a/collects/redex/tests/bmps-macosx/stlc.png b/collects/redex/tests/bmps-macosx/stlc.png index 731d15600f..8bce9bfe1e 100644 Binary files a/collects/redex/tests/bmps-macosx/stlc.png and b/collects/redex/tests/bmps-macosx/stlc.png differ diff --git a/collects/redex/tests/bmps-macosx/superscripts.png b/collects/redex/tests/bmps-macosx/superscripts.png index 80e2a1e7f3..ab30c9a70f 100644 Binary files a/collects/redex/tests/bmps-macosx/superscripts.png and b/collects/redex/tests/bmps-macosx/superscripts.png differ diff --git a/collects/redex/tests/bmps-macosx/var-not-in-rebound.png b/collects/redex/tests/bmps-macosx/var-not-in-rebound.png index 747c16474b..6cc8e4bca2 100644 Binary files a/collects/redex/tests/bmps-macosx/var-not-in-rebound.png and b/collects/redex/tests/bmps-macosx/var-not-in-rebound.png differ diff --git a/collects/redex/tests/bmps-macosx/var-not-in.png b/collects/redex/tests/bmps-macosx/var-not-in.png index 609f28d993..d1ecd1f8e9 100644 Binary files a/collects/redex/tests/bmps-macosx/var-not-in.png and b/collects/redex/tests/bmps-macosx/var-not-in.png differ