suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added state display to world programs

Browse Source 
svn: r15836
This commit is contained in:
Matthias Felleisen 2009-08-30 18:11:02 +00:00
parent 6708347021
commit 68fb5e42fa
7 changed files with 84 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/2htdp/private/checked-cell.ss
View File

@ -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?

21
collects/2htdp/private/syn-aux.ss
View File

@ -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))

4
collects/2htdp/private/universe.ss
View File

@ -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

15
collects/2htdp/private/world.ss
View File

@ -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)))

1
collects/2htdp/uchat/chatter.ss
View File

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

3
collects/2htdp/uchat/server.ss
View File

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

29
collects/2htdp/universe.ss
View File

@ -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 ()