added state display to world programs

svn: r15836

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

@@ -1,4 +1,4 @@
-#lang scheme
+#lang scheme/gui
 
 (require htdp/error)
 
@@ -9,29 +9,63 @@
     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?)
+    (init-field msg    ;; String 
-
+                value0 ;; X
-    ;; Any -> ok?
+                ok?)   ;; Any -> Boolean : X 
+    
+    (init [display #f]) ;; (U String #f) ; a string is the name of the state display window
+    
+    (field 
+     [value (coerce "initial value" value0)]
+     ;; (U False pasteboard%)
+     [pb (if (boolean? display)
+             #f
+             (let* ([f (new frame% [label display][width 400][height 400])]
+                    [p (new pasteboard%)]
+                    [e (new editor-canvas% [parent f] [editor p] 
+                            [style '(hide-hscroll hide-vscroll)])])
+               (send f show #t)
+               p))])
+    
+    (define/private (show-state)
+      (define xbox (box #f)) ;; x coordinate (throw away)
+      (define ybox (box 0))  ;; y coordinate for next snip
+      (define s (pretty-format value 80))
+      ;; turn s into lines and display them in pb
+      (send pb erase)
+      (if (is-a? value snip%)
+          (send pb insert value 0 0)
+          (parameterize ([current-input-port (open-input-string s)])
+            (let read-all ()
+              (define nxt (read-line))
+              (unless (eof-object? nxt)
+                (let ([s (make-object string-snip% nxt)])
+                  (send pb insert s 0 (unbox ybox))
+                  (send pb get-snip-location s xbox ybox #t)
+                  (read-all)))))))
+    
+    ;; Symbol 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)])
+    ;; Symbol Any -> Void 
-
+    ;; effect: set value to v if distinct, also display it if pb exists
     (define/public (set tag v) 
       (define nw  (coerce tag v))
       (if (equal? value nw)
           #t
           (begin
             (set! value nw)
+            (when pb (show-state))
             #f)))
     
     ;; -> ok?

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

@@ -1,6 +1,6 @@
 #lang scheme
 
-(provide define-keywords function-with-arity except err)
+(provide define-keywords function-with-arity expr-with-check except err)
 
 (require 
  (for-template "syn-aux-aux.ss" 
@@ -15,6 +15,15 @@
     ...
     (define-for-syntax the-list (list (list 'kw (coerce ''kw)) ...))))
 
+(define-syntax (expr-with-check stx)
+  (syntax-case stx ()
+    [(_ check> msg)
+     #`(lambda (tag)
+         (lambda (p)
+           (syntax-case p ()
+             [(x) #`(check> #,tag x)]
+             [_ (err tag p msg)])))]))
+
 (define-syntax function-with-arity 
   (syntax-rules (except)
     [(_ arity)
@@ -32,9 +41,9 @@
            [_ (err tag p)])))]))
 
 (define (err spec p . extra-spec)
+  (printf "~s\n" p)
   (raise-syntax-error (cadr spec)
-    (if (null? extra-spec)
+                      (if (null? extra-spec)
-	"illegal specification"
+                          "illegal specification"
-	(string-append "illegal specification: " (car extra-spec)))
+                          (string-append "illegal specification: " (car extra-spec)))
-    #`(#,spec . #,p) p))
+                      p))
-

collects/2htdp/private/universe.ss

@@ -37,6 +37,7 @@
        on-new            ;; Universe World -> Result
        on-msg            ;; Universe World Message -> Result
        tick              ;; Universe -> Result
+       (state #f)         ;; Boolean 
        (on-disconnect    ;; Universe World -> Result
         (lambda (u w) (make-bundle u '() '())))
        (to-string #f)    ;; Universe -> String 
@@ -45,7 +46,8 @@
       
       (field 
        [universe 
-        (new checked-cell% [msg "UniSt"] [value0 universe0] [ok? check-with])])
+        (new checked-cell% [msg "UniSt"] [value0 universe0] [ok? check-with] 
+             [display (and state "your server's state")])])
  
       ;; -----------------------------------------------------------------------
       ;; dealing with events

collects/2htdp/private/world.ss

@@ -52,7 +52,8 @@
       
       (init-field
        world0            ;; World
-       (name #f)         ;; (U #f Symbol)
+       (name #f)         ;; (U #f String)
+       (state #f)         ;; Boolean 
        (register #f)     ;; (U #f IP)
        (check-with True) ;; Any -> Boolean 
        (tick K))         ;; (U (World -> World) (list (World -> World) Nat))
@@ -67,8 +68,10 @@
       
       ;; -----------------------------------------------------------------------
       (field
-       (world
+       [world
-        (new checked-cell% [msg "World"] [value0 world0] [ok? check-with])))
+        (new checked-cell% [msg "World"] [value0 world0] [ok? check-with]
+             [display (and state (or name "your world program's state"))])])
+      
       
       ;; -----------------------------------------------------------------------
       (field [*out* #f] ;; (U #f OutputPort), where to send messages to 
@@ -198,7 +201,7 @@
         (send visible lock #t)
         (send visible end-edit-sequence))
       
-      ;; -----------------------------------------------------------------------
+      ;; ----------------------------------------------------------------------
       ;; callbacks 
       (field
        (key    on-key)
@@ -239,7 +242,7 @@
       ;; receive revents 
       (def/pub-cback (prec msg) rec)
       
-      ;; -----------------------------------------------------------------------
+      ;; ----------------------------------------------------------------------
       ;; draw : render this world 
       (define/private (pdraw) (show (ppdraw)))
       
@@ -256,7 +259,7 @@
         (check-result (name-of stop 'your-stop-when) boolean? "boolean" result)
         result)
       
-      ;; -----------------------------------------------------------------------
+      ;; ----------------------------------------------------------------------
       ;; start & stop
       (define/public (callback-stop! msg)
         (stop! (send world get)))

collects/2htdp/uchat/chatter.ss

@@ -482,6 +482,7 @@
             (on-receive receive)
             (check-with world?)
             (name n)
+	    (state true)
             (register LOCALHOST)))
 
 (define (run* _)

collects/2htdp/uchat/server.ss

@@ -92,7 +92,8 @@
 ;; Any -> Universe
 ;; run the chat server 
 (define (run _)
-  (universe '() 
+  (universe '()
+            (state true)
             (on-new new-chatter)
             (on-msg forward)))
 

collects/2htdp/universe.ss

@@ -36,6 +36,8 @@
 ;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
 ;;      = (check-with Expr)
 ;; -- check-with must specify a predicate 
+;;      | (state Expr)
+;; -- state specifies whether to display the world's or universe's current state
 
 (define-keywords AllSpec
   [on-tick (function-with-arity
@@ -44,6 +46,13 @@
             [(x rate) 
              #'(list (proc> 'on-tick (f2h x) 1) 
                      (num> 'on-tick rate positive? "pos. number" "rate"))])]
+  [state (expr-with-check bool> "expected a boolean (show state or not)")
+         #;
+         (lambda (tag)
+           (lambda (p)
+             (syntax-case p ()
+               [(b) #`(bool> #,tag b)]
+               [_ (err tag p "expected a boolean (show state or not)")])))]
   [check-with (function-with-arity 1)])
 
 ;                                     
@@ -97,7 +106,7 @@
 ;; WorldSpec = AllSpec 
 ;;      | (on-draw Expr)
 ;;      | (on-draw Expr Expr Expr)
-;; -- on-draw must specify a rendering function; it may specify canvas dimensions
+;; -- on-draw must specify a rendering function; it may specify canvas dimension
 ;;      | (on-key Expr)
 ;; -- on-key must specify a key event handler 
 ;;      | (on-mouse Expr) 
@@ -131,21 +140,9 @@
               [(stop? last-picture)
                #'(list (proc> 'stop-when (f2h stop?) 1)
                        (proc> 'stop-when (f2h last-picture) 1))])]
-  [register (lambda (tag)
+  [record? (expr-with-check bool> "expected a boolean (to record? or not)")]
-              (lambda (p)
+  [name (expr-with-check string> "expected a name (string) for the world")]
-                (syntax-case p ()
+  [register (expr-with-check ip> "expected a host (ip address)")])
-                  [(host) #`(ip> #,tag host)]
-                  [_ (err tag p "expected a host (ip address)")])))]
-  [name (lambda (tag)
-          (lambda (p)
-            (syntax-case p ()
-              [(n) #`(string> #,tag n)]
-              [_ (err tag p "expected a string for the current world")])))]
-  [record? (lambda (tag)
-             (lambda (p)
-               (syntax-case p ()
-                 [(b) #`(bool> #,tag b)]
-                 [_ (err tag p "expected a boolean (to record or not to record?")])))])
 
 (define-syntax (big-bang stx)
   (syntax-case stx ()