fix bug with boolean result check in stop-when, Rackety

pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt

@@ -270,7 +270,6 @@
            (def/cback pub (name arg ...) transform (object-name transform))]
           [(_ pub (name arg ...) transform tag)
            ;; Any ... -> Boolean
-           (begin
            (define/public (name arg ...) 
              (queue-callback 
               (lambda ()
@@ -291,15 +290,16 @@
                   (when (package? nw)
                     (broadcast (package-message nw))
                     (set! nw (package-world nw)))
-                    (if (stop-the-world? nw)
+                  (cond
-                        (begin
+                    [(stop-the-world? nw)
                      (set! nw (stop-the-world-world nw))
                      (send world set tag nw)
                      (last-draw)
                      (callback-stop! 'name)
-                          (enable-images-button))
+                     (enable-images-button)]
-                        (let ([changed-world? (send world set tag nw)]
+                    [else 
-                              [stop? (pstop)])
+                     [define changed-world? (send world set tag nw)]
+                     [define stop? (stop (send world get))]
                      ;; this is the old "Robby optimization" see checked-cell:
                      ; unless changed-world? 
                      (cond
@@ -323,7 +323,7 @@
                         (last-draw)
                         (callback-stop! 'name)
                         (enable-images-button)])
-                          changed-world?)))))))]))
+                     changed-world?])))))]))
       
       ;; tick, tock : deal with a tick event for this world 
       (def/cback pubment (ptock) (lambda (w) (pptock w)) (name-of-tick-handler))
@@ -357,21 +357,20 @@
       (define/public (ppdraw)
         (check-scene-result (name-of draw 'your-draw) (draw (send world get))))
       
-      ;; -----------------------------------------------------------------------
+      ;; ---------------------------------------------------------------------------------------------
       ;; stop-when 
-      (field [stop (if (procedure? stop-when) stop-when (first stop-when))]
+      (field [stop (let ((s (if (procedure? stop-when) stop-when (first stop-when))))
+                     (lambda (x)
+                       (define result (s x))
+                       (check-result (name-of s 'your-stop-when) boolean? "boolean" result)
+                       result))]
              [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)
-        result)
-      
-      ;; ----------------------------------------------------------------------
       ;; start & stop
       (define/public (callback-stop! msg)
         (stop! (send world get)))
@@ -508,93 +507,3 @@
 
 (define ANIMATED-GIF-FILE "i-animated.gif")
 
-;; the version of aworld below records all events (pointers to functions)
-;; and replays them starting from the initial world. In terms of space, this 
-;; is quite efficient because there are only six differente actions (pointers)
-;; BUT, it doesn't work with random or other effectful stuff
-;; EXPLORE: put random into the library and make it an event 
-(define aworld-old%
-  (class world% (super-new)
-    (inherit-field world0 tick key pad release mouse rec draw rate width height record?)
-    (inherit show callback-stop!)
-    
-    ;; Frame Custodian ->* (-> Void) (-> Void)
-    ;; adds the stop animation and image creation button, 
-    ;; whose callbacks runs as a thread in the custodian
-    (define/augment (create-frame/universe frm play-back-custodian)
-      (define p (new horizontal-pane% [parent frm][alignment '(center center)]))
-      (define (pb)
-        (parameterize ([current-custodian play-back-custodian])
-          (thread (lambda () (play-back)))
-          (stop)))
-      (define (switch)
-        (send stop-button enable #f)
-        (if (and (string? record?) (directory-exists? record?))
-            (pb)
-            (send image-button enable #t)))
-      (define (stop) 
-        (send image-button enable #f)
-        (send stop-button enable #f))
-      (define-syntax-rule (btn l a y ...)
-        (new button% [parent p] [label l] [style '(border)] 
-             [callback (lambda a y ...)]))
-      (define stop-button 
-        (btn break-button:label (b e) (callback-stop! 'stop-images) (switch)))
-      (define image-button 
-        (btn image-button:label (b e) (pb)))
-      (send image-button enable #f)
-      (values switch stop))
-    
-    (field [event-history '()]) ;; [Listof Evt]
-    ;; Symbol  Any *-> Void
-    (define/private (add-event type . stuff)
-      (set! event-history (cons (cons type stuff) event-history)))
-    
-    ;; --- new callbacks ---
-    (define-syntax-rule
-      (def/cb ovr (pname name arg ...))
-      (define/override (pname arg ...) 
-        (when (super pname arg ...) (add-event name arg ...))))
-    
-    (def/cb augment (ptock tick))
-    (def/cb augment (pkey key e))
-    (def/cb augment (ppad pad e))
-    (def/cb augment (prelease release e))
-    (def/cb augment (pmouse mouse x y me))
-    (def/cb augment (prec rec m))
-    
-    ;; --> Void
-    ;; re-play the history of events; create a png per step; create animated gif
-    ;; effect: write to user-chosen directory
-    (define/private (play-back)
-      ;; World EventRecord -> World 
-      (define (world-transition world fst) (apply (car fst) world (cdr fst)))
-      ;; --- creating images 
-      (define total (+ (length event-history) 1))
-      (define digt# (string-length (number->string total)))
-      (define imag# 0)
-      (define bmps '())
-      ;; Image -> Void
-      (define (save-image img)
-        (define bm (make-object bitmap% width height))
-        (define dc (make-object bitmap-dc% bm))
-        (send dc clear)
-        (send img draw dc 0 0 0 0 width height 0 0 #f)
-        (set! imag# (+ imag# 1))
-        (send bm save-file (format "i~a.png" (zero-fill imag# digt#)) 'png)
-        (set! bmps (cons bm bmps)))
-      ;; --- choose place 
-      (define img:dir 
-        (or (and (string? record?) (directory-exists? record?) record?)
-            (get-directory "image directory:" #f (current-directory))))
-      (when img:dir
-        (parameterize ([current-directory img:dir])
-          (define worldN 
-            (let L ([history event-history][world world0])
-              (save-image (draw world))
-              (if (empty? history) 
-                  world
-                  (L (rest history) (world-transition world (first history))))))
-          (show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
-          (create-animated-gif rate (reverse bmps))
-          (show (draw worldN)))))))

pkgs/htdp-pkgs/htdp-test/2htdp/tests/stop-when-not-boolean.rkt

@@ -5,7 +5,9 @@
 
 (require 2htdp/universe 2htdp/image)
 
-(with-handlers ((exn:fail? void))
+(with-handlers ((exn:fail? (λ (x) 
+                             (unless (pair? (regexp-match #px"return a boolean" (exn-message x)))
+                               (raise x)))))
   (big-bang 0
             (on-draw (λ _ (empty-scene 500 500)))
             (stop-when (λ _ 5)))