DrDr related changes

svn: r16403

collects/redex/private/bitmap-test-util.ss

@@ -5,11 +5,14 @@
            (lib "class.ss")
            "../pict.ss"
            "../reduction-semantics.ss")
-
+  
   (provide test done)
   
   (define-struct failed-test (panel))
   
+  (define show-diffs?-env "PLT_REDEX_TEST_NOSHOW_DIFFS")
+  (define show-diffs? (not (getenv show-diffs?-env)))
+  
   (define tests 0)
   (define failed '())
   (define (done)
@@ -50,8 +53,10 @@
       (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 (make-failed-test failed-panel)))))))))
+          (if show-diffs?
+              (let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)])
+                (set! failed (append failed (list (make-failed-test failed-panel)))))
+              (set! failed (append failed (list #f))))))))
   
   (define (compute-diffs old-bitmap new-bitmap)
     (let* ([w (max (send old-bitmap get-width)
@@ -128,7 +133,7 @@
          (set! test-result-single-panel sp)
          (send f show #t)
          sp)]))
-         
+  
   (define (make-failed-panel line-number filename old-bitmap new-bitmap diff-bitmap)
     (define f (new vertical-panel% [parent (get-test-result-single-panel)]))
     (define msg (new message% [label (format "line ~a" line-number)] [parent f]))

collects/redex/private/run-tests.ss

@@ -17,6 +17,8 @@
 
 (define-runtime-path here ".")
 
+(putenv "PLT_REDEX_TEST_NOSHOW_DIFFS" "yes")
+
 (define (flush)
   ;; these flushes are here for running under cygwin, 
   ;; which somehow makes mzscheme think it isn't using

collects/teachpack/door.ss

@@ -26,7 +26,7 @@
   
   (define (center base state y)
     (define w (pict-width state))
-    (define d (quotient (- width w) 2))
+    (define d (quotient (round (- width w)) 2))
     (pin-over base d y state))
   
   (define nx 

collects/teachpack/server.ss

@@ -105,7 +105,7 @@
 
 (define (center base state x)
   (define w (pict-height state))
-  (define d (quotient (- width w) 2))
+  (define d (quotient (round (- width w)) 2))
   (pin-over base x d state))
 
 (define width (pict-height bg))

collects/teachpack/world.ss

@@ -104,7 +104,7 @@
 
 (define (center base state x)
   (define w (pict-height state))
-  (define d (quotient (- width w) 2))
+  (define d (quotient (round (- width w)) 2))
   (pin-over base x d state))
 
 (define width (pict-height bg))

collects/tests/mred/windowing.ss

@@ -456,6 +456,8 @@
 		(car l)))
 (st "Yes & No" frame get-label)
 
+(send frame show #f)
+
 (define (test-controls parent frame)
   (define side-effect #f)