From 68fb5e42fab770bcd8bf3e774f18f4aadb3534db Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sun, 30 Aug 2009 18:11:02 +0000 Subject: [PATCH] added state display to world programs svn: r15836 --- collects/2htdp/private/checked-cell.ss | 48 ++++++++++++++++++++++---- collects/2htdp/private/syn-aux.ss | 21 +++++++---- collects/2htdp/private/universe.ss | 4 ++- collects/2htdp/private/world.ss | 15 ++++---- collects/2htdp/uchat/chatter.ss | 1 + collects/2htdp/uchat/server.ss | 3 +- collects/2htdp/universe.ss | 29 +++++++--------- 7 files changed, 84 insertions(+), 37 deletions(-) diff --git a/collects/2htdp/private/checked-cell.ss b/collects/2htdp/private/checked-cell.ss index 927c0eb1dd..9b2a03bd15 100644 --- a/collects/2htdp/private/checked-cell.ss +++ b/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?) - - ;; Any -> ok? + (init-field msg ;; String + value0 ;; X + 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? diff --git a/collects/2htdp/private/syn-aux.ss b/collects/2htdp/private/syn-aux.ss index abe71ac3a1..302d4d0240 100644 --- a/collects/2htdp/private/syn-aux.ss +++ b/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) - "illegal specification" - (string-append "illegal specification: " (car extra-spec))) - #`(#,spec . #,p) p)) - + (if (null? extra-spec) + "illegal specification" + (string-append "illegal specification: " (car extra-spec))) + p)) diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss index 4f56894c36..01ddded200 100644 --- a/collects/2htdp/private/universe.ss +++ b/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 diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss index e06b0f1839..ef6a5271ab 100644 --- a/collects/2htdp/private/world.ss +++ b/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 - (new checked-cell% [msg "World"] [value0 world0] [ok? check-with]))) + [world + (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))) diff --git a/collects/2htdp/uchat/chatter.ss b/collects/2htdp/uchat/chatter.ss index e7f4ee4391..c8cf147c2e 100644 --- a/collects/2htdp/uchat/chatter.ss +++ b/collects/2htdp/uchat/chatter.ss @@ -482,6 +482,7 @@ (on-receive receive) (check-with world?) (name n) + (state true) (register LOCALHOST))) (define (run* _) diff --git a/collects/2htdp/uchat/server.ss b/collects/2htdp/uchat/server.ss index 3e5ce6d1f6..0049cc31cf 100644 --- a/collects/2htdp/uchat/server.ss +++ b/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))) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index e584831bc3..cf4fde1d7e 100644 --- a/collects/2htdp/universe.ss +++ b/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) - (lambda (p) - (syntax-case p () - [(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?")])))]) + [record? (expr-with-check bool> "expected a boolean (to record? or not)")] + [name (expr-with-check string> "expected a name (string) for the world")] + [register (expr-with-check ip> "expected a host (ip address)")]) (define-syntax (big-bang stx) (syntax-case stx ()