bug fix: when the initial world is a final world, big-bang should use only the final draw handler -- if it exists

collects/2htdp/private/world.rkt

@@ -133,7 +133,7 @@
              [disable-images-button void]
              [visible (new pasteboard%)])
       
-      (define (show-canvas)
+      (define/private (show-canvas)
         (send visible set-cursor (make-object cursor% 'arrow))
         (let ([fst-scene (ppdraw)])
           (if (2:image? fst-scene)
@@ -253,9 +253,6 @@
            ;; Any ... -> Boolean
            (begin
              (define/public (name arg ...) 
-               (define (last-draw)
-                 (set! draw last-picture)
-                 (pdraw))
                (queue-callback 
                 (lambda ()
                   (define H (handler #t))
@@ -279,9 +276,7 @@
                         (begin
                           (set! nw (stop-the-world-world nw))
                           (send world set tag nw)
-                          (cond
-                            [last-picture (last-draw)]
-                            [draw (pdraw)])
+                          (last-draw)
                           (callback-stop! 'name)
                           (enable-images-button))
                         (let ([changed-world? (send world set tag nw)]
@@ -306,9 +301,7 @@
                                [else 
                                 (set! draw# (- draw# 1))])]
                             [stop?
-                             (cond 
-                               [last-picture (last-draw)]
-                               [draw (pdraw)])
+                             (last-draw)
                              (callback-stop! 'name)
                              (enable-images-button)])
                           changed-world?)))))))]))
@@ -347,6 +340,10 @@
       (field [stop (if (procedure? stop-when) stop-when (first stop-when))]
              [last-picture (if (pair? stop-when) (second stop-when) #f)])
       
+      (define/private (last-draw)
+        (when last-picture (set! draw last-picture))
+        (pdraw))
+      
       (define/private (pstop)
         (define result (stop (send world get)))
         (check-result (name-of stop 'your-stop-when) boolean? "boolean" result)
@@ -366,12 +363,18 @@
         (with-handlers ([exn? (handler #t)])
           (when width ;; and height
             (check-scene-dimensions "your to-draw clause" width height))
-          (if draw (show-canvas) (error 'big-bang "internal error: draw can never be false"))
           (when register (register-with-host))
           (define w (send world get))
           (cond
-            [(stop w) (stop! w)]
-            [(stop-the-world? w) (stop! (stop-the-world-world w))])))
+            [(stop w) 
+             (when last-picture (set! draw last-picture))
+             (show-canvas)
+             (stop! w)]
+            [(stop-the-world? w) 
+             (when last-picture (set! draw last-picture))
+             (show-canvas)
+             (stop! (stop-the-world-world w))]
+            [else (show-canvas)])))
       
       (define/public (stop! w)
         (set! live #f)

collects/2htdp/tests/stop-when-crash.rkt

@@ -1,42 +1,11 @@
 #lang racket
 
+;; ---------------------------------------------------------------------------------------------------
+;; the stop-when clause crashes. make sure that it signals a catchable error.
+
 (require 2htdp/universe 2htdp/image)
 
 (with-handlers ((exn:fail? void))
   (big-bang 0
             (on-draw (λ _ (empty-scene 500 500)))
             (stop-when (λ _ (car '())))))
-
-#| -----------------------------------------------------------------------------
-(struct:object:...tdp/private/last.rkt:8:2
- `#<procedure:...p-when-crash.rkt:6:19>
- #(struct:object:checked-cell% ...) 
- #f
- #<custodian>
- #<procedure:...p-when-crash.rkt:6:19> 
- #f 
- 501
- 501
- #<procedure:void>
- #<procedure:void>
- #(struct:object:pasteboard% ...) 
- #f
- #<procedure:K>
- #f
- #f
- #<procedure:...p-when-crash.rkt:7:21> 
- #f
- 0
- #f
- #f
- #f
- #<procedure:True>
- #f
- #f
- #f
- #<procedure:show-canvas>
- #f
- #<procedure:set-draw#!>
- 1 
- #<procedure:handler> ...)
-|#

collects/2htdp/tests/world0-stops.rkt

@@ -1,16 +1,28 @@
-;; The first three lines of this file were inserted by DrScheme. They record metadata
-;; about the language level of this file in a form that our tools can easily process.
-#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+#lang racket 
+
+;; ---------------------------------------------------------------------------------------------------
+;; does big-bang stop when the initial world is already a final world? does it draw the final image? 
 
 (require 2htdp/universe)
 (require 2htdp/image)
 
-(define draw (lambda (x) (circle 3 'solid 'red)))
+(define ((draw message) x)
+  (display message) 
+  (circle 3 'solid 'red))
 
-"does big-bang stop when the initial world is already a final world?"
-(big-bang 0 (stop-when zero?) (on-tick add1) (to-draw draw))
+(define-syntax-rule 
+  (test body expected-value expected-output)
+  (begin
+    (define actual-value (gensym))
+    (define actual-output (with-output-to-string (lambda () (set! actual-value body))))
+    (unless (equal? actual-value expected-value)
+      (error 'failure "~a expected value ~e, value produced ~e" 'test expected-value actual-value))
+    (unless (string=? actual-output expected-output)
+      (error 'failure "~a expected output ~e, output produced ~e" 'test expected-output actual-output))))
 
-"does big bang stop when the initial world is a stop world?"
-(big-bang (stop-with 0) (on-tick add1) (to-draw draw))
+(test (big-bang 0 (stop-when zero?) (on-tick add1) (to-draw (draw ""))) 0 "")
+
+(test (big-bang (stop-with 0) (on-tick add1) (to-draw (draw ""))) 0 "")
+
+(test (big-bang 0 (on-draw (draw 0)) (stop-when zero? (draw 1))) 0 "1")
 
-(define-struct stop (x))