From 8cfa68b647d35bcb74ca32a076a8fadbcca1934b Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Sat, 27 Sep 2014 20:14:17 -0600
Subject: [PATCH] allow universe handlers to return state of universe, nt just
 bundle

---
 .../2htdp/tests/universe-disappearing.rkt     | 70 +++++++++++++++++++
 .../htdp-pkgs/htdp-test/2htdp/utest/balls.rkt | 19 ++---
 pkgs/htdp-pkgs/htdp-test/2htdp/utest/xrun     |  2 +-
 pkgs/htdp-pkgs/htdp-test/2htdp/xtest          |  1 +
 4 files changed, 83 insertions(+), 9 deletions(-)
 create mode 100644 pkgs/htdp-pkgs/htdp-test/2htdp/tests/universe-disappearing.rkt

diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/universe-disappearing.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/universe-disappearing.rkt
new file mode 100644
index 0000000000..b2f56183b3
--- /dev/null
+++ b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/universe-disappearing.rkt
@@ -0,0 +1,70 @@
+#lang racket
+
+(module universe racket
+  (provide
+   ;; Boolean -> [Listof IWorld]
+   ;; run a univsere server, show state if given #true
+   run)
+  ;; ---------------------------------------------------------------------------
+  
+  (require 2htdp/universe)
+  (require 2htdp/image)
+  
+  (define (run show?)
+    (universe '()
+              (on-tick identity 1 15)
+              (state show?)
+              (on-new (lambda (u nw) (cons nw u)))
+              (on-msg (lambda (u sender msg)
+                        (define new-u (remq sender u))
+                        (define throw (list sender))
+                        (make-bundle new-u (mail2 new-u msg) throw)))
+              (on-disconnect (lambda (u gone)
+                               (remq gone u)))))
+  
+  ;; [Listof IWorld] String -> [Listof Mail]
+  (define (mail2 lo-iw sender)
+    (for/list ((iw lo-iw))
+      (make-mail iw (format "~a says good-bye" sender)))))
+
+(module client racket
+  (provide 
+   ;; Boolean -> ???
+   run)
+  ;; -----------------------------------------------------------------------------
+  
+  (require 2htdp/universe)
+  (require 2htdp/image)  
+  
+  ;; String -> Natural 
+  ;; run for at most 9 seconds, send your secret to server at t = 1
+  (define (run secret)
+    (big-bang (random 10)
+              (register LOCALHOST)
+              (on-receive (lambda (x msg)
+                            (displayln msg)
+                            x))
+              (to-draw (lambda (x) 
+                         (overlay (text secret 12 'blue)
+                                  (circle (+ 100 (* 10 x)) 'solid 'red))))
+              (on-tick (lambda (x)
+                         (if (= x 1)
+                             (make-package 0 secret)
+                             (sub1 x)))
+                       1
+                       10)
+              (stop-when zero?))))
+
+(require (prefix-in server: (submod "." universe))
+         (prefix-in client: (submod "." client))
+         2htdp/universe)
+
+(define (main show?)
+  (launch-many-worlds 
+   (server:run show?)
+   (client:run "matthias") 
+   (client:run "matthew") 
+   (client:run "robby") 
+   (client:run "shriram")))
+
+(main #f)
\ No newline at end of file
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/utest/balls.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/utest/balls.rkt
index 867058f456..6c41a9737f 100644
--- a/pkgs/htdp-pkgs/htdp-test/2htdp/utest/balls.rkt
+++ b/pkgs/htdp-pkgs/htdp-test/2htdp/utest/balls.rkt
@@ -11,7 +11,17 @@
 ;; BallMail = (make-mail IWorld 'go)
 ;; Result   = (make-bundle [Listof IWorld] [Listof BallMail] '())
 
-(define Result0 (make-bundle '() '() '()))
+(define Result0 '() #;(make-bundle '() '() '()))
+
+;; -----------------------------------------------------------------------------
+;; Any -> [Listof IWorld]
+
+(define (run _)
+  (universe '() 
+            (on-new add-world)
+            (check-with list?)
+            (on-msg switch)
+            (on-disconnect disconnect)))
 
 ;; -----------------------------------------------------------------------------
 ;; [Listof IWorld] -> Result
@@ -79,11 +89,4 @@
 
 (test)
 
-(define (run _)
-  (universe '() 
-            (on-new add-world)
-            (check-with list?)
-            (on-msg switch)
-            (on-disconnect disconnect)))
-
 ; (run 'go)
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/utest/xrun b/pkgs/htdp-pkgs/htdp-test/2htdp/utest/xrun
index ad7a1892b7..70a8dfeaaf 100755
--- a/pkgs/htdp-pkgs/htdp-test/2htdp/utest/xrun
+++ b/pkgs/htdp-pkgs/htdp-test/2htdp/utest/xrun
@@ -1,6 +1,6 @@
 #! /bin/sh
 #|
-exec racket -tm "$0" ${1+"$@"}
+exec racket -t "$0" ${1+"$@"}
 |#
 
 #lang racket 
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/xtest b/pkgs/htdp-pkgs/htdp-test/2htdp/xtest
index a5c90aed4c..cd015978ee 100755
--- a/pkgs/htdp-pkgs/htdp-test/2htdp/xtest
+++ b/pkgs/htdp-pkgs/htdp-test/2htdp/xtest
@@ -10,6 +10,7 @@ run() {
 
 cd tests 
 
+run universe-disappearing.rkt
 run bitmap-as-image-in-universe.rkt
 run key-error.rkt
 run to-draw-error.rkt