From 48e07fb2aba05999fb441097cbbfc46a21138d9b Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Sat, 23 Jun 2012 13:55:55 -0400
Subject: [PATCH] send world's name to universe properly, Closes PR 12857

---
 collects/2htdp/private/check-aux.rkt     |  6 ++---
 collects/2htdp/private/universe.rkt      |  4 +---
 collects/2htdp/tests/name.rkt            | 30 ++++++++++++++++++++----
 collects/2htdp/tests/struct-universe.rkt | 19 +++++++++------
 4 files changed, 42 insertions(+), 17 deletions(-)

diff --git a/collects/2htdp/private/check-aux.rkt b/collects/2htdp/private/check-aux.rkt
index 2d587d0681..851b125799 100644
--- a/collects/2htdp/private/check-aux.rkt
+++ b/collects/2htdp/private/check-aux.rkt
@@ -131,7 +131,7 @@
           x))))
 
 ;; InPort OutPort (X -> Y) -> (U Y Void)
-;; process a registration from a potential client, invoke k if it is okay
+;; process a registration from a potential client, invoke k on name if it is okay
 (define (tcp-process-registration in out k)
   (define next (tcp-receive in))
   (match next
@@ -140,9 +140,9 @@
      (k name)]))
   
 ;; InPort OutPort (U #f String) -> Void 
-;; register with the server 
+;; register with the server, send the given name or make up a symbol 
 (define (tcp-register in out name)
-  (define msg `(REGISTER ((name ,(if name name (symbol->string (gensym 'world)))))))
+  (define msg `(REGISTER ((name ,(if name name (gensym 'world))))))
   (tcp-send out msg)
   (define ackn (tcp-receive in))
   (unless (equal? ackn '(OKAY))
diff --git a/collects/2htdp/private/universe.rkt b/collects/2htdp/private/universe.rkt
index 2d6f47cfe4..f7bc2bd62e 100644
--- a/collects/2htdp/private/universe.rkt
+++ b/collects/2htdp/private/universe.rkt
@@ -251,9 +251,7 @@
 
 ;; IPort OPort Sexp -> IWorld 
 (define (create-iworld i o info)
-  (if (string? info)
-      (make-iworld i o info "info field not available")
-      (make-iworld i o (symbol->string (gensym 'iworld)) "info field not available")))
+  (make-iworld i o info "info field not available"))
 
 ;; Player S-exp -> Void
 (define (iworld-send p sexp)
diff --git a/collects/2htdp/tests/name.rkt b/collects/2htdp/tests/name.rkt
index 6e70cd83ce..28a7f7448d 100644
--- a/collects/2htdp/tests/name.rkt
+++ b/collects/2htdp/tests/name.rkt
@@ -1,9 +1,31 @@
 #lang racket
+
+;; created in response to pr 12857
+;; make sure the name of a world is transmitted to the server 
+
+(require rackunit)
 (require 2htdp/universe)
 (require 2htdp/image)
 
-(big-bang '*
-         (name 'jimbob)
-         (on-tick (λ (w) w) 1/3 2)
-         (to-draw (λ (w) (empty-scene 200 200))))
+(define NAME 'ian-johnson)
 
+(define c (make-custodian))
+
+(define-values (_ n)
+  (parameterize ((current-custodian c))
+    (launch-many-worlds
+     ;; --- world: 
+     (big-bang 10
+               (on-tick sub1)
+               (to-draw (lambda (w) (empty-scene 200 200)))
+               (name NAME)
+               (register LOCALHOST))
+     ;; --- universe: 
+     (universe #f
+               (on-new (lambda (u w) (make-bundle (iworld-name w) '() '())))
+               (on-msg (lambda (u w m) (make-bundle u '() '())))
+               (on-tick (lambda (u) (make-bundle u '() '())) 1 1)))))
+
+(check-equal? n NAME)
+
+(custodian-shutdown-all c)
diff --git a/collects/2htdp/tests/struct-universe.rkt b/collects/2htdp/tests/struct-universe.rkt
index 5313c0f19c..4fae9ab918 100644
--- a/collects/2htdp/tests/struct-universe.rkt
+++ b/collects/2htdp/tests/struct-universe.rkt
@@ -1,4 +1,4 @@
-#lang racket/load
+#lang racket
 
 (module shared racket/base
   (require 2htdp/universe 2htdp/image)
@@ -7,7 +7,7 @@
   (provide s s-t (all-from-out 2htdp/universe 2htdp/image)))
 
 (module client racket
-  (require 'shared)
+  (require (submod ".." shared))
 
   ;; Color -> Boolean 
   (define (client c)
@@ -15,6 +15,7 @@
     (big-bang #true
               (to-draw (lambda (w) (text (if w "hello world" "good bye") 22 c)))
               (register LOCALHOST)
+              #;
               (stop-when (lambda (w) (> count 3)))
               (on-receive 
                (lambda (w msg)
@@ -22,10 +23,10 @@
                  ;; send out a prefabed struct to the server 
                  (make-package (not w) (s count)))))) 
   
-  (launch-many-worlds (client 'blue) (client 'red)))
+  (provide client))
 
 (module server racket 
-  (require 'shared)
+  (require (submod ".." shared))
   
   (define (server)
     (universe '()
@@ -41,8 +42,12 @@
                  (displayln (s-t msg))
                  (make-bundle state '() '())))))
   
-  (thread server))
+  
+  (provide server))
 
-(require 'server)
+(module run racket/base
+  (require (submod ".." client) (submod ".." server) (submod ".." shared))
+  
+  (launch-many-worlds (client 'blue) (client 'red) (server)))
 
-(require 'client)
+(require (submod "." run))
\ No newline at end of file