From bb4c88338c43ff55ddee00b296f13dd665be3368 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Mon, 30 Nov 2009 16:52:01 +0000
Subject: [PATCH] stop the world and let me get off

svn: r17111
---
 collects/2htdp/private/stop.ss       |  5 +++++
 collects/2htdp/private/world.ss      | 14 ++++++++++++--
 collects/2htdp/tests/world0-stops.ss | 10 +++++++++-
 collects/2htdp/universe.ss           |  4 ++++
 4 files changed, 30 insertions(+), 3 deletions(-)
 create mode 100644 collects/2htdp/private/stop.ss

diff --git a/collects/2htdp/private/stop.ss b/collects/2htdp/private/stop.ss
new file mode 100644
index 0000000000..816d57201b
--- /dev/null
+++ b/collects/2htdp/private/stop.ss
@@ -0,0 +1,5 @@
+#lang scheme
+
+(provide (struct-out stop-the-world))
+
+(define-struct stop-the-world (world) #:transparent)
diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss
index 67f90960c9..59480ffe1a 100644
--- a/collects/2htdp/private/world.ss
+++ b/collects/2htdp/private/world.ss
@@ -4,6 +4,7 @@
          "timer.ss"
          "last.ss"
          "checked-cell.ss"
+         "stop.ss"
          htdp/image
          htdp/error
          mzlib/runtime-path
@@ -214,15 +215,20 @@
           (queue-callback 
            (lambda ()
              (with-handlers ([exn? (handler #t)])
+	       (define stop-it #f)
                (define tag (format "~a callback" 'transform))
                (define nw (transform (send world get) arg ...))
                (when (package? nw)
                  (broadcast (package-message nw))
                  (set! nw (package-world nw)))
+               (printf "~s\n" nw)
+	       (when (stop-the-world? nw)
+		 (set! nw (stop-the-world-world nw))
+		 (set! stop-it #t))
                (let ([changed-world? (send world set tag nw)])
                  (unless changed-world?
                    (when draw (pdraw))
-                   (when (pstop) 
+                   (when (or stop-it (pstop))
                      (when last-picture 
                        (set! draw last-picture)
                        (pdraw))
@@ -284,7 +290,11 @@
       ;; initialize the world and run 
       (super-new)
       (start!)
-      (when (stop (send world get)) (stop! (send world get)))))))
+      (let ([w (send world get)])
+        (cond
+          [(stop w) (stop! (send world get))]
+          [(stop-the-world? w) 
+           (stop! (stop-the-world-world (send world get)))]))))))
 
 ;; -----------------------------------------------------------------------------
 (define-runtime-path break-btn:path '(lib "icons/break.png"))
diff --git a/collects/2htdp/tests/world0-stops.ss b/collects/2htdp/tests/world0-stops.ss
index 60857b8753..54fda9bf27 100644
--- a/collects/2htdp/tests/world0-stops.ss
+++ b/collects/2htdp/tests/world0-stops.ss
@@ -1,5 +1,13 @@
 ;; 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 ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp")))))
+#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 ())))
 
+(require 2htdp/universe)
+
+"does big-bang stop when the initial world is already a final world?"
 (big-bang 0 (stop-when zero?) (on-tick add1))
+
+"does big bang stop when the initial world is a stop world?"
+(big-bang (STOP! 0) (on-tick add1))
+
+(define-struct stop (x))
\ No newline at end of file
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index 2c1e62050c..a13d4fd3ee 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -17,11 +17,15 @@
          "private/world.ss"
          "private/universe.ss"
          "private/launch-many-worlds.ss"
+         "private/stop.ss"
          htdp/error
          (rename-in lang/prim (first-order->higher-order f2h)))
 
 (provide (all-from-out "private/image.ss"))
 
+(provide 
+ (rename-out (make-stop-the-world STOP!))) ;; World -> STOP!
+
 (provide
  launch-many-worlds
  ;; (launch-many-worlds e1 ... e2)