changed world?/universe? to check-with

svn: r15196

collects/2htdp/private/checked-cell.ss

@@ -0,0 +1,43 @@
+#lang scheme
+
+(require htdp/error)
+
+(provide checked-cell%)
+
+(define checked-cell<%>
+  (interface ()
+    set ;; Symbol Any -> Boolean 
+    ;; does the new state differ from the old? 
+    ;; effect: if so only, set state
+
+    get ;; -> Any (ok?)
+    ))
+
+(define checked-cell% 
+  (class* object% (checked-cell<%>) 
+    (init-field msg value0 ok?)
+
+    ;; Any -> ok?
+    (define/private (coerce tag nw)
+      (let ([b (ok? nw)])
+        (check-result "check-with predicate" boolean? "Boolean" b)
+        (check-result tag (lambda _ b) (format "~a (see check-with)" msg) nw)
+        nw))
+    
+    (field [value (coerce "initial value" value0)])
+
+    (define/public (set tag v) 
+      (define nw  (coerce tag v))
+      (if (equal? value nw)
+          #t
+          (begin
+            (set! value nw)
+            #f)))
+    
+    ;; -> ok?
+    (define/public (get) value)
+    
+    (super-new)))
+
+; (define c (new checked-cell% [msg "World"] [value0 1] [ok? positive?]))
+; (send c set "tick" 10)

collects/2htdp/private/universe.ss

@@ -1,6 +1,7 @@
 #lang scheme/gui
 
 (require (for-syntax "syn-aux.ss")
+         "checked-cell.ss"
          "check-aux.ss"
          "timer.ss"    
          "last.ss"
@@ -39,27 +40,12 @@
        (on-disconnect    ;; Universe World -> Result
         (lambda (u w) (list u)))
        (to-string #f)    ;; Universe -> String 
-       (universe? True)  ;; Universe -> Boolean 
+       (check-with True) ;; Any -> Boolean 
        )
       
-      (field [universe #f])
+      (field 
-      
+       [universe 
-      ;; Symbol (U World Package) -> Boolean 
+        (new checked-cell% [msg "UniSt"] [value0 universe0] [ok? check-with])])
-      ;; 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
@@ -75,8 +61,9 @@
             (define (handler e) (stop! e))
             (with-handlers ([exn? handler])
               (define ___  (begin 'dummy body ...))
-              (define-values (u mails bad) (bundle> 'name (name universe a ...)))
+              (define-values (u mails bad) 
-              (set-universe (format "~a callback" 'name) u)
+                (bundle> 'name (name (send universe get) a ...)))
+              (send universe set (format "~a callback" 'name) u)
               (unless (boolean? to-string) (send gui add (to-string u)))
               (broadcast mails)
               (for-each (lambda (iw)
@@ -124,7 +111,7 @@
       
       (field [iworlds   '()] ;; [Listof World]
              [gui      (new gui%
-                            [stop-server (lambda () (stop! universe))] 
+                            [stop-server (lambda () (stop! (send universe get)))] 
                             [stop-and-restart (lambda () (restart))])]
              [dr:custodian  (current-custodian)]
              [the-custodian (make-custodian)])
@@ -163,7 +150,7 @@
                 (loop))))
           ;; --- go universe go ---
           (set! iworlds '())
-          (set-universe "initial value" universe0)
+          (send universe set "initial value" universe0)
           (send gui add "a new universe is up and running")
           (thread loop)))
       

collects/2htdp/private/world.ss

@@ -3,6 +3,7 @@
 (require "check-aux.ss"
          "timer.ss"
          "last.ss"
+         "checked-cell.ss"
          htdp/image
          htdp/error
          mzlib/runtime-path
@@ -52,7 +53,7 @@
        world0            ;; World
        (name #f)         ;; (U #f Symbol)
        (register #f)     ;; (U #f IP)
-       (world? True)     ;; World -> Boolean 
+       (check-with True) ;; Any -> Boolean 
        (tick K))         ;; (U (World -> World) (list (World -> World) Nat))
       
       (init
@@ -64,27 +65,9 @@
        (record? #f)      ;; Boolean 
        )
       ;; -----------------------------------------------------------------------
-      (field (world #f))
+      (field
-      
+       (world
-      ;; Symbol (U World Package) -> Boolean 
+        (new checked-cell% [msg "World"] [value0 world0] [ok? check-with])))
-      ;; does the new world differ from the old? 
-      ;; effect: if so, set world
-      (define/private (set-world tag nw)
-        (define tcb tag)
-        (define wcb "world? predicate")
-        (when (package? nw)
-          (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 nw)
-              #f)))
-
-      (set-world "initial value" world0)
       
       ;; -----------------------------------------------------------------------
       (field [*out* #f] ;; (U #f OutputPort), where to send messages to 
@@ -225,13 +208,17 @@
            (lambda ()
              (with-handlers ([exn:break? (handler #f)][exn? (handler #t)])
                (define tag (format "~a callback" 'transform))
-               (define changed-world? (set-world tag (transform world arg ...)))
+               (define nw (transform (send world get) arg ...))
+               (when (package? nw)
+                 (broadcast (package-message nw))
+                 (set! nw (package-world nw)))
+               (let ([changed-world? (send world set tag nw)])
                  (unless changed-world?
                    (when draw (pdraw))
                    (when (pstop) 
                      (callback-stop! 'name)
                      (enable-images-button)))
-               changed-world?)))))
+                 changed-world?))))))
       
       ;; tick, tock : deal with a tick event for this world 
       (def/pub-cback (ptock) tick)
@@ -250,26 +237,26 @@
       (define/private (pdraw) (show (ppdraw)))
       
       (define/private (ppdraw)
-        (check-scene-result (name-of draw 'your-draw) (draw world)))
+        (check-scene-result (name-of draw 'your-draw) (draw (send world get))))
       
       ;; -----------------------------------------------------------------------
       ;; stop-when 
       (field [stop  stop-when])
       
       (define/private (pstop)
-        (define result (stop world))
+        (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! world))
+        (stop! (send world get)))
       
       (define (handler re-raise)
         (lambda (e)
           (disable-images-button)
-          (stop! (if re-raise e world))))
+          (stop! (if re-raise e (send world get)))))
       
       (define/public (start!)
         (when draw (show-canvas))
@@ -283,7 +270,7 @@
       ;; initialize the world and run 
       (super-new)
       (start!)
-      (when (stop-when world) (stop! world))))))
+      (when (stop-when (send world get)) (stop! (send world get)))))))
 
 ;; -----------------------------------------------------------------------------
 (define-runtime-path break-btn:path '(lib "icons/break.png"))

collects/2htdp/universe.ss

@@ -25,6 +25,8 @@
 ;; Spec = (on-tick Expr) 
 ;;      | (on-tick Expr Expr) 
 ;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
+;;      = (check-with Expr)
+;; -- check-with must specify a predicate 
 
 (define-keywords AllSpec
   [on-tick (function-with-arity
@@ -32,7 +34,8 @@
             except
             [(x rate) 
              #'(list (proc> 'on-tick (f2h x) 1) 
-                     (num> 'on-tick rate positive? "pos. number" "rate"))])])
+                     (num> 'on-tick rate positive? "pos. number" "rate"))])]
+  [check-with (function-with-arity 1)])
 
 ;                                     
 ;                                     
@@ -113,7 +116,6 @@
   [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 ()
@@ -265,7 +267,6 @@
   [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,7 +80,7 @@
 (define (run _)
   (universe '() 
             (on-new add-world)
-            (universe? list?)
+            (check-with list?)
             (on-msg switch)
             (on-disconnect disconnect)))
 

collects/2htdp/utest/shared.ss

@@ -60,6 +60,7 @@
             (on-receive receive)
             (on-tick move)
 	    (name t)
+	    (check-with (lambda (w) (or (symbol? w) (number? w))))
             (register LOCALHOST)))
 
 (generate-report)