diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index a84b9f27c4..30a3e66e13 100644 --- a/collects/2htdp/private/world.rkt +++ b/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) diff --git a/collects/2htdp/tests/stop-when-crash.rkt b/collects/2htdp/tests/stop-when-crash.rkt index f8c0384f44..2aa5c9d338 100644 --- a/collects/2htdp/tests/stop-when-crash.rkt +++ b/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 - `# - #(struct:object:checked-cell% ...) - #f - # - # - #f - 501 - 501 - # - # - #(struct:object:pasteboard% ...) - #f - # - #f - #f - # - #f - 0 - #f - #f - #f - # - #f - #f - #f - # - #f - # - 1 - # ...) -|# diff --git a/collects/2htdp/tests/world0-stops.rkt b/collects/2htdp/tests/world0-stops.rkt index 51749bc7e0..6dcac1b3c3 100644 --- a/collects/2htdp/tests/world0-stops.rkt +++ b/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))