world? and universe? added, comments to come

svn: r15178

collects/2htdp/private/check-aux.ss

@@ -14,6 +14,7 @@
 
 (define (K w . r) w)
 (define (False w) #f)
+(define (True w) #t)
 
 ;                                                                               
 ;                                                                               

collects/2htdp/private/universe.ss

@@ -39,9 +39,27 @@
        (on-disconnect    ;; Universe World -> Result
         (lambda (u w) (list u)))
        (to-string #f)    ;; Universe -> String 
+       (universe? True)  ;; Universe -> Boolean 
        )
       
-      (field [universe universe0])
+      (field [universe #f])
+      
+      ;; Symbol (U World Package) -> Boolean 
+      ;; does the new world differ from the old? 
+      ;; effect: if so, set world
+      (define/private (set-universe tag nw)
+        (define tcb tag)
+        (define wcb "universe? predicate")
+        (let ([b (universe? nw)])
+          (check-result wcb boolean? "Boolean" b)
+          (check-result tag (lambda _ b) "UniState (see universe?)" nw))
+        (if (equal? universe nw)
+            #t
+            (begin
+              (set! universe nw)
+              #f)))
+      
+      (set-universe "initial value" universe0)
 
       ;; -----------------------------------------------------------------------
       ;; dealing with events
@@ -58,7 +76,7 @@
             (with-handlers ([exn? handler])
               (define ___  (begin 'dummy body ...))
               (define-values (u mails bad) (bundle> 'name (name universe a ...)))
-              (set! universe u)
+              (set-universe (format "~a callback" 'name) u)
               (unless (boolean? to-string) (send gui add (to-string u)))
               (broadcast mails)
               (for-each (lambda (iw)
@@ -145,7 +163,7 @@
                 (loop))))
           ;; --- go universe go ---
           (set! iworlds '())
-          (set! universe universe0)
+          (set-universe "initial value" universe0)
           (send gui add "a new universe is up and running")
           (thread loop)))
       

collects/2htdp/private/world.ss

@@ -52,6 +52,7 @@
        world0            ;; World
        (name #f)         ;; (U #f Symbol)
        (register #f)     ;; (U #f IP)
+       (world? True)     ;; World -> Boolean 
        (tick K))         ;; (U (World -> World) (list (World -> World) Nat))
       
       (init
@@ -63,21 +64,28 @@
        (record? #f)      ;; Boolean 
        )
       ;; -----------------------------------------------------------------------
-      (field (world  world0))
+      (field (world #f))
       
-      ;; (U World Package) -> Boolean 
+      ;; Symbol (U World Package) -> Boolean 
       ;; does the new world differ from the old? 
       ;; effect: if so, set world
-      (define/private (set-world new-world)
+      (define/private (set-world tag nw)
-        (when (package? new-world)
+        (define tcb tag)
-          (broadcast (package-message new-world))
+        (define wcb "world? predicate")
-          (set! new-world (package-world new-world)))
+        (when (package? nw)
-        (if (equal? world new-world)
+          (broadcast (package-message nw))
+          (set! nw (package-world nw)))
+        (let ([b (world? nw)])
+          (check-result wcb boolean? "Boolean" b)
+          (check-result tag (lambda _ b) "World (see world?)" nw))
+        (if (equal? world nw)
             #t
             (begin
-              (set! world new-world)
+              (set! world nw)
               #f)))
 
+      (set-world "initial value" world0)
+
       ;; -----------------------------------------------------------------------
       (field [*out* #f] ;; (U #f OutputPort), where to send messages to 
              [*rec* (make-custodian)]) ;; Custodian, monitor traffic)
@@ -216,7 +224,8 @@
           (queue-callback 
            (lambda ()
              (with-handlers ([exn:break? (handler #f)][exn? (handler #t)])
-               (define changed-world? (set-world (transform world arg ...)))
+               (define tag (format "~a callback" 'transform))
+               (define changed-world? (set-world tag (transform world arg ...)))
                (unless changed-world? 
                  (when draw (pdraw))
                  (when (pstop) 

collects/2htdp/universe.ss

@@ -113,6 +113,7 @@
   [on-key (function-with-arity 2)]
   [on-receive (function-with-arity 2)]
   [stop-when (function-with-arity 1)]
+  [world? (function-with-arity 1)]
   [register (lambda (tag)
               (lambda (p)
                 (syntax-case p ()
@@ -264,6 +265,7 @@
   [on-new (function-with-arity 2)]
   [on-msg (function-with-arity 3)]
   [on-disconnect (function-with-arity 2)]
+  [universe? (function-with-arity 1)]
   [to-string (function-with-arity 1)])
 
 (define-syntax (universe stx)

collects/2htdp/utest/balls.ss

@@ -80,6 +80,7 @@
 (define (run _)
   (universe '() 
             (on-new add-world)
+            (universe? list?)
             (on-msg switch)
             (on-disconnect disconnect)))