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

changed world?/universe? to check-with

Browse Source 
svn: r15196
This commit is contained in:
Matthias Felleisen 2009-06-17 18:55:14 +00:00
parent 962987f4dc
commit 06ea83c600
6 changed files with 82 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/2htdp/private/checked-cell.ss Normal file
View File

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

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

@ -1,6 +1,7 @@
#lang scheme/gui
(require (for-syntax "syn-aux.ss")
"checked-cell.ss"
"check-aux.ss"
"timer.ss"
"last.ss"
@ -39,28 +40,13 @@
(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])
;; 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)
(field
[universe
(new checked-cell% [msg "UniSt"] [value0 universe0] [ok? check-with])])
;; -----------------------------------------------------------------------
;; dealing with events
(define-syntax-rule
@ -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 ...)))
(set-universe (format "~a callback" 'name) u)
(define-values (u mails bad)
(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)))

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

@ -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,28 +65,10 @@
(record? #f) ;; Boolean
)
;; -----------------------------------------------------------------------
(field (world #f))
(field
(world
(new checked-cell% [msg "World"] [value0 world0] [ok? check-with])))
;; Symbol (U World Package) -> Boolean
;; 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
[*rec* (make-custodian)]) ;; Custodian, monitor traffic)
@ -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 ...)))
(unless changed-world?
(when draw (pdraw))
(when (pstop)
(callback-stop! 'name)
(enable-images-button)))
changed-world?)))))
(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?))))))
;; 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"))

7
collects/2htdp/universe.ss
View File

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

4
collects/2htdp/utest/balls.ss
View File

@ -80,8 +80,8 @@
(define (run _)
(universe '()
(on-new add-world)
(universe? list?)
(check-with list?)
(on-msg switch)
(on-disconnect disconnect)))
(run 'go)
(run 'go)

1
collects/2htdp/utest/shared.ss
View File

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