save a new set of unix bitmaps for the redex bitmap test

and (optimistically) turn the bitmap tests back in on in drdr

(also improve the GUI a little bit that shows the errors in
the test)

collects/meta/props

@@ -1231,8 +1231,8 @@ path/s is either such a string or a list of them.
 "collects/redex/private/size-snip.rkt" drdr:command-line (gracket-text "-t" *)
 "collects/redex/private/stepper.rkt" drdr:command-line (gracket-text "-t" *)
 "collects/redex/private/traces.rkt" drdr:command-line (gracket-text "-t" *)
-"collects/redex/scribblings/tut.scrbl" drdr:timeout 300
 "collects/redex/redex.scrbl" drdr:timeout 300
+"collects/redex/scribblings/tut.scrbl" drdr:timeout 300
 "collects/redex/tests/bitmap-test-util.rkt" drdr:command-line (gracket-text "-t" *)
 "collects/redex/tests/bitmap-test.rkt" drdr:command-line (mzc "-k" *)
 "collects/redex/tests/check-syntax-test.rkt" drdr:command-line (mzc *)
@@ -1245,7 +1245,7 @@ path/s is either such a string or a list of them.
 "collects/redex/tests/matcher-test.rkt" drdr:command-line (mzc *)
 "collects/redex/tests/pict-test.rkt" drdr:command-line (mzc *)
 "collects/redex/tests/rg-test.rkt" drdr:command-line (mzc *)
-"collects/redex/tests/run-tests.rkt" drdr:command-line (gracket-text * "--examples" "--no-bitmaps") drdr:timeout 360
+"collects/redex/tests/run-tests.rkt" drdr:command-line (racket * "--examples" "--no-bitmap-gui") drdr:timeout 360
 "collects/redex/tests/stepper-test.rkt" drdr:command-line (mzc *)
 "collects/redex/tests/term-test.rkt" drdr:command-line (mzc *)
 "collects/redex/tests/tl-test.rkt" drdr:command-line (mzc *)

collects/redex/tests/bitmap-test-util.rkt

@@ -9,17 +9,19 @@
          "../pict.rkt"
          "../reduction-semantics.rkt")
 
-(provide test done)
+(provide btest done show-bitmap-test-gui?)
+
+(define show-bitmap-test-gui? (make-parameter #t))
 
 (define tests 0)
-(define failed '())
+(define failed-tests 0)
+(define failed-panels '())
 (define (done)
-  (printf "~a tests" tests)
-  (if (null? failed)
-      (printf ", all passed\n")
-      (printf ", ~a failed\n" (length failed))))
+  (if (zero? failed-tests)
+      (printf "bitmap-test.rkt: ~a tests, all passed\n" tests)
+      (eprintf "bitmap-test.rkt: ~a tests, ~a failed\n" tests failed-tests)))
 
-(define-syntax (test stx)
+(define-syntax (btest stx)
   (syntax-case stx ()
     [(_ test-exp bitmap-filename)
      #`(test/proc
@@ -51,8 +53,10 @@
     (draw-pict pict bdc 0 0)
     (send bdc set-bitmap #f)
     (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)))))))
+      (set! failed-tests (+ failed-tests 1))
+      (when (show-bitmap-test-gui?)
+        (let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap)])
+          (set! failed-panels (append failed-panels (list failed-panel))))))))
 
 (define (set-fonts/call thunk)
   (case (system-type)
@@ -62,8 +66,8 @@
               (let loop ([s s])
                 (cond
                   [(pair? s) (cons (loop (car s)) (loop (cdr s)))]
-                  [(eq? s 'roman) (verify-face " DejaVu Serif")]
-                  [(eq? s 'swiss) (verify-face " DejaVu Sans")]
+                  [(eq? s 'roman) (verify-face "DejaVu Serif")]
+                  [(eq? s 'swiss) (verify-face "DejaVu Sans")]
                   [else s])))])
        (parameterize ([label-style (rewrite-style (label-style))]
                       [literal-style (rewrite-style (literal-style))]
@@ -150,38 +154,56 @@
               [parent hp]
               [callback
                (λ (x y)
-                 (set! current-index (modulo (- current-index 1) (length failed)))
+                 (set! current-index (modulo (- current-index 1) (length failed-panels)))
                  (update-gui))]))
        (define next (new button% 
                          [label "Next"] 
                          [parent hp]
                          [callback
                           (λ (x y)
-                            (set! current-index (modulo (+ current-index 1) (length failed)))
+                            (set! current-index (modulo (+ current-index 1) (length failed-panels)))
                             (update-gui))]))
        (define (update-gui) 
-         (send sp active-child (list-ref failed current-index)))
+         (send sp active-child (list-ref failed-panels current-index)))
        (set! test-result-single-panel sp)
        (send f show #t)
        sp)]))
 
 (define (make-failed-panel line-number filename old-bitmap new-bitmap)
-  (define diff-bitmap (delay (compute-diffs old-bitmap new-bitmap)))
+  (define diff-bitmap 'unk)
   (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 computing-msg (new message% [label computing-label] [parent f]))
   (define chk (new check-box% 
                    [label "Show diff"]
                    [parent f]
                    [callback
                     (λ (_1 _2)
+                      (define (update-check)
+                        (cond
+                          [(send chk get-value)
+                           (send right-hand set-label (force diff-bitmap))]
+                          [else
+                           (send right-hand set-label new-bitmap)]))
                       (cond
-                        [(send chk get-value)
-                         (send right-hand set-label (force diff-bitmap))]
+                        [(eq? diff-bitmap 'unk)
+                         (send chk enable #f)
+                         (send computing-msg set-label computing-label)
+                         (thread
+                          (λ ()
+                            (set! diff-bitmap (compute-diffs old-bitmap new-bitmap))
+                            (queue-callback
+                             (λ ()
+                               (send computing-msg set-label "")
+                               (send chk enable #t)
+                               (update-check)))))]
                         [else
-                         (send right-hand set-label new-bitmap)]))]))
+                         (update-check)]))]))
+  (send computing-msg set-label "")
   (define btn (new button%
                    [parent f]
                    [label "Save"]

collects/redex/tests/bitmap-test.rkt

@@ -14,15 +14,15 @@
   (v number (λ (x) e))
   ((x y) variable-not-otherwise-mentioned))
 
-(test (render-language lang) "language.png")
+(btest (render-language lang) "language.png")
 
-(test (render-language lang #:nts '(e v)) "language-nox.png")
+(btest (render-language lang #:nts '(e v)) "language-nox.png")
 
 (define-extended-language lang++ lang
   (e .... number (+ e e))
   (v .... number))
 
-(test (render-language lang++) "extended-language.png")
+(btest (render-language lang++) "extended-language.png")
 
 (define red
   (reduction-relation
@@ -30,40 +30,40 @@
    (--> ((λ (x) e) v) (S x v e))))
 
 ;; tests: reduction-relation
-(test (render-reduction-relation red)
-      "reduction-relation.png")
+(btest (render-reduction-relation red)
+       "reduction-relation.png")
 
-(test (render-reduction-relation 
-       (extend-reduction-relation red lang (--> 1 2)))
-      "extended-reduction-relation.png")
+(btest (render-reduction-relation 
+        (extend-reduction-relation red lang (--> 1 2)))
+       "extended-reduction-relation.png")
 
-(test (render-reduction-relation
-       (with-unquote-rewriter
-        (let ([once? #f])
-          (λ (l)
-            (if once?
-                l
-                (begin0
-                  (struct-copy lw
-                               l
-                               [e "a: any"]
-                               [unq? #f])
-                  (set! once? #t)))))
-        (reduction-relation
-         lang
-         (--> (a any) 1 "a" (computed-name (format "a: ~a" (term any))))
-         (--> (b any) 2 "b" (computed-name (format "b: ~a" (term any))))
-         (--> (c any) 3 (computed-name (format "c: ~a" (term any)))))))
-      "reduction-relation-with-computed-labels.png")
+(btest (render-reduction-relation
+        (with-unquote-rewriter
+         (let ([once? #f])
+           (λ (l)
+             (if once?
+                 l
+                 (begin0
+                   (struct-copy lw
+                                l
+                                [e "a: any"]
+                                [unq? #f])
+                   (set! once? #t)))))
+         (reduction-relation
+          lang
+          (--> (a any) 1 "a" (computed-name (format "a: ~a" (term any))))
+          (--> (b any) 2 "b" (computed-name (format "b: ~a" (term any))))
+          (--> (c any) 3 (computed-name (format "c: ~a" (term any)))))))
+       "reduction-relation-with-computed-labels.png")
 
 (let ([R (reduction-relation
           lang
           (--> 1 1 "a")
           (--> 2 2 "b" (computed-name "a"))
           (--> 3 3 (computed-name "c")))])
-  (test (parameterize ([render-reduction-relation-rules (remq 'b (reduction-relation->rule-names R))])
-          (render-reduction-relation R))
-        "reduction-relation-with-computed-labels-and-hiding.png"))
+  (btest (parameterize ([render-reduction-relation-rules (remq 'b (reduction-relation->rule-names R))])
+           (render-reduction-relation R))
+         "reduction-relation-with-computed-labels-and-hiding.png"))
 
 ;; this test should fail because it gets the order wrong
 ;; for the where/side-conditions
@@ -77,27 +77,27 @@
         (where any_z any_x)
         (side-condition (= (term number_d) 5)))))
 
-(test (render-reduction-relation red2)
-      "red2.png")
+(btest (render-reduction-relation red2)
+       "red2.png")
 
 (let ()
   (define-judgment-form lang
     #:mode (id I O)
     [(id e e)])
-  (test (render-reduction-relation
-         (reduction-relation
-          lang
-          (--> e_1
-               q
-               (where (name q e_2) e_1)
-               (judgment-holds (id e_2 (name r e_3))))))
-        "red-with-where-name.png"))
-        
+  (btest (render-reduction-relation
+          (reduction-relation
+           lang
+           (--> e_1
+                q
+                (where (name q e_2) e_1)
+                (judgment-holds (id e_2 (name r e_3))))))
+         "red-with-where-name.png"))
+
 (define-metafunction lang
   [(S x v e) e])
 
-(test (render-metafunction S)
-      "metafunction.png")
+(btest (render-metafunction S)
+       "metafunction.png")
 
 (let ()
   (define-metafunction lang
@@ -108,8 +108,8 @@
   (define-judgment-form lang
     #:mode (J I O)
     [(J e e)])
-  (test (render-metafunction f)
-        "metafunction-judgment-holds.png"))
+  (btest (render-metafunction f)
+         "metafunction-judgment-holds.png"))
 
 (define-metafunction lang
   [(T x y)
@@ -123,14 +123,14 @@
 ;; in this test, the metafunction has 2 clauses 
 ;; with a side-condition on the first clause
 ;; and a 'where' in the second clause
-(test (render-metafunction T) "metafunction-T.png")
+(btest (render-metafunction T) "metafunction-T.png")
 
 ;; in this test, the `x' is italic and the 'z' is sf, since 'x' is in the grammar, and 'z' is not.
-(test (render-lw 
-       lang 
-       (to-lw ((λ (x) (x x))
-               (λ (z) (z z)))))
-      "lw.png")
+(btest (render-lw 
+        lang 
+        (to-lw ((λ (x) (x x))
+                (λ (z) (z z)))))
+       "lw.png")
 
 (define-metafunction lang
   [(TL 1) (a
@@ -140,11 +140,11 @@
   [(TL 2) (a
            ,(term-let ((x (term 1)))
                       (term x)) beside
-           below)])
+                      below)])
 
 ;; this tests that term-let is sucked away properly
 ;; when the metafunction is rendered
-(test (render-metafunction TL) "metafunction-TL.png")
+(btest (render-metafunction TL) "metafunction-TL.png")
 
 (define-metafunction lang
   [(Name (name x-arg arg)) 
@@ -155,12 +155,12 @@
 ;; this tests that the three variable bindings
 ;; (x-arg, x-term-let, and x-where) 
 ;; all show up in the output.
-(test (render-metafunction Name) "metafunction-Name.png")
+(btest (render-metafunction Name) "metafunction-Name.png")
 
 ;; same as previous, but with vertical organization of the bindings
-(test (parameterize ([metafunction-pict-style 'up-down/vertical-side-conditions])
-        (render-metafunction Name))
-      "metafunction-Name-vertical.png")
+(btest (parameterize ([metafunction-pict-style 'up-down/vertical-side-conditions])
+         (render-metafunction Name))
+       "metafunction-Name-vertical.png")
 
 ;; makes sure that there is no overlap inside or across metafunction calls  
 ;; or when there are unquotes involved
@@ -179,7 +179,7 @@
     ,@(term (multi-arg with-unquote))
     ,@(term (multi-arg with-unquote)))])
 
-(test (render-metafunction multi-arg) "metafunction-multi-arg.png")
+(btest (render-metafunction multi-arg) "metafunction-multi-arg.png")
 
 ;; makes sure that the LHS and RHS of metafunctions are appropriately
 ;; rewritten
@@ -205,13 +205,13 @@
         (list-ref lws 4)
         "}"))
 
-(test (with-compound-rewriter 'subst subst-rw
-        (render-metafunction subst))
-      "metafunction-subst.png")
+(btest (with-compound-rewriter 'subst subst-rw
+                               (render-metafunction subst))
+       "metafunction-subst.png")
 
 
 ;; make sure two metafunctions simultaneously rewritten line up properly
-(test (render-metafunctions S T TL) "metafunctions-multiple.png")
+(btest (render-metafunctions S T TL) "metafunctions-multiple.png")
 
 ;; make sure that the ellipses don't have commas before them.
 (define-metafunction lang
@@ -223,13 +223,13 @@
    (where (x_3 ...) (rdups x_2 ...))]
   [(rdups) ()])
 
-(test (render-metafunction rdups) "rdups-delimited.png")
+(btest (render-metafunction rdups) "rdups-delimited.png")
 (parameterize ([delimit-ellipsis-arguments? #f])
-  (test (render-metafunction rdups) "rdups-undelimited.png"))
+  (btest (render-metafunction rdups) "rdups-undelimited.png"))
 
 ;; Non-terminal superscripts
-(test (render-lw lang (to-lw (x_^abcdef x_q^abcdef)))
-      "superscripts.png")
+(btest (render-lw lang (to-lw (x_^abcdef x_q^abcdef)))
+       "superscripts.png")
 
 ;; `variable-not-in' in `where' RHS rendered as `fresh'
 (define-metafunction lang
@@ -238,13 +238,13 @@
    (where x ,(variable-not-in 'y 'x))
    (where (x_1 x_2) ,(variables-not-in 'z '(x1 x2)))
    (where x_3 (variables-not-in 'z '(x1 x2)))])
-(test (render-metafunction f) "var-not-in.png")
+(btest (render-metafunction f) "var-not-in.png")
 (let ([variable-not-in list])
   (define-metafunction lang
     [(g 1) 
      x
      (where x ,(variable-not-in 'y 'x))])
-  (test (render-metafunction g) "var-not-in-rebound.png"))
+  (btest (render-metafunction g) "var-not-in-rebound.png"))
 
 ;; hidden `where' and `side-condition' clauses
 (define-metafunction lang
@@ -252,36 +252,36 @@
    2
    (where/hidden number 7)
    (side-condition/hidden (= 1 2))])
-(test (render-metafunction mf-hidden) "mf-hidden.png")
-(test (render-reduction-relation
-       (reduction-relation
-        lang
-        (--> 1
-             2
-             (where/hidden number 7)
-             (side-condition/hidden (= 1 2)))))
-      "rr-hidden.png")
+(btest (render-metafunction mf-hidden) "mf-hidden.png")
+(btest (render-reduction-relation
+        (reduction-relation
+         lang
+         (--> 1
+              2
+              (where/hidden number 7)
+              (side-condition/hidden (= 1 2)))))
+       "rr-hidden.png")
 
 ;; holes
 (let ()
   (define-language L
     (n (hole x) ; a "named hole" at one time
        hole))
-  (test (render-language L) "holes.png"))
+  (btest (render-language L) "holes.png"))
 
 (let ()
   ;; the 'has no lambdas' relation (useful because it has a case with no premises)
   (define-relation lang
     [(r e_1 e_2) (r e_1) (r e_2)]
     [(r x)])
-  (test (render-relation r) "relation.png"))
+  (btest (render-relation r) "relation.png"))
 
 (let ()
   ;; a relation with a `name' pattern in its conclusion
   (define-relation lang
     [(r (name e (λ (x) x)))
      (r x)])
-  (test (render-relation r) "relation-with-name.png"))    
+  (btest (render-relation r) "relation-with-name.png"))    
 
 ;; judgment form
 (let ()
@@ -319,22 +319,22 @@
      (lt2 n) ...
      (sum z z z)])
   
-  (test (vc-append 
-         10
-         (render-judgment-form sum)
+  (btest (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))
          
-         (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"))
+         "judgment-form-examples.png"))
 
 (let ()
   (define-language STLC
@@ -375,12 +375,12 @@
   (define (rewrite-lookup lws)
     (list "" (list-ref lws 2) "(" (list-ref lws 3) ")"))
   
-  (test (with-compound-rewriters
-         (['typeof rewrite-typeof]
-          ['extend rewrite-extend]
-          ['lookup rewrite-lookup])
-         (render-judgment-form typeof))
-        "stlc.png"))  
+  (btest (with-compound-rewriters
+          (['typeof rewrite-typeof]
+           ['extend rewrite-extend]
+           ['lookup rewrite-lookup])
+          (render-judgment-form typeof))
+         "stlc.png"))  
 
 (printf "bitmap-test.rkt: ")
 (done)

collects/redex/tests/run-tests.rkt

@@ -5,14 +5,14 @@
 (require racket/runtime-path
          racket/cmdline
          racket/match
-         "test-util.rkt")
+         "test-util.rkt"
+         "bitmap-test-util.rkt")
 
-(define test-bitmaps? #t)
 (define test-examples? #f)
 
 (command-line
  #:once-each
- [("--no-bitmaps") "executes bitmap-test.rkt" (set! test-bitmaps? #f)]
+ [("--no-bitmap-gui") "skips the GUI for bitmap-test.rkt" (show-bitmap-test-gui? #f)]
  [("--examples") "executes the tests in the examples directory" (set! test-examples? #t)])
 
 (define test-files
@@ -31,8 +31,8 @@
      "defined-checks-test.rkt"
      "check-syntax-test.rkt"
      "test-docs-complete.rkt"
-     "tut-subst-test.rkt")
-   (if test-bitmaps? '("bitmap-test.rkt") '())
+     "tut-subst-test.rkt"
+     "bitmap-test.rkt")
    (if test-examples?
        '("../examples/cbn-letrec.rkt"
          "../examples/stlc.rkt"
@@ -64,7 +64,7 @@
                    [(? string?) 
                     (values test-file #f values)])])
      (flush)
-     (printf "testing ~a\n" file)
+     (printf "running ~a\n" file)
      (flush)
      (action (dynamic-require (build-path here file) provided))
      (flush)))