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

separated out the list of worlds from universeState

Browse Source 
svn: r13055
This commit is contained in:
Matthias Felleisen 2009-01-09 23:18:05 +00:00
parent 65fad6047d
commit 38ef7d3c41
2 changed files with 35 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -31,7 +31,8 @@
(last-mixin
(clock-mixin
(class* object% (start-stop<%>) (inspect #f) (super-new)
(init-field ;; type Result = (make-bundle Universe [Listof Mail])
(init-field ;; type Result
; = (make-bundle [Listof World] Universe [Listof Mail])
universe0 ;; the initial state of the universe
on-new ;; Universe World -> Result
on-msg ;; Universe World Message -> Result
@ -56,8 +57,9 @@
(define (pname a ...)
(define (handler e) (stop! e))
(with-handlers ([exn? handler])
(define r (check-state-x-mail 'name (name universe a ...)))
(define r (check-state-x-mail 'name (name worlds universe a ...)))
(define u (bundle-state r))
(set! worlds (bundle-low r))
(set! universe u)
(unless (boolean? to-string) (send gui add (to-string u)))
(broadcast (bundle-mails r))))))
@ -68,9 +70,9 @@
(def/cback private (pnew world) ppnew)
(define/private (ppnew uni p)
(define/private (ppnew low uni p)
(world-send p 'okay)
(on-new uni p))
(on-new low uni p))
(def/cback public (ptock) tick)
@ -80,8 +82,9 @@
(define/private (check-state-x-mail tag r)
(with-handlers ((exn? (lambda (x) (stop! x))))
(define s (format "expected from ~a, given: " tag))
(define f "(make-bundle [Listof World] Universe [Listof Mail]) ~a~e")
(unless (bundle? r)
(error tag (format "(make-bundle Universe [Listof Mail]) ~a~e" s r)))
(error tag (format f s r)))
r))
;; -----------------------------------------------------------------------
@ -109,7 +112,7 @@
(match next
[(cons 'REGISTER info)
(let* ([w (create-world in (second in-out) info)])
(set! worlds (cons w worlds))
; (set! worlds (cons w worlds))
(pnew w)
(send gui add (format "~a signed up" info))
(loop))]
@ -334,24 +337,30 @@
;
(provide
;; type Bundle = (make-bundle Universe [Listof Mail])
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; Universe [Listof Mail] -> Bundle
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
)
(define-struct bundle (state mails) #:transparent)
(define-struct bundle (low state mails) #:transparent)
(set! make-bundle
(let ([make-bundle make-bundle])
(lambda (state mails)
(check-arg 'make-bundle (list? mails) "list [of mails]" "second" mails)
(for-each (lambda (c)
(check-arg 'make-bundle (mail? c) "mail" "(elements of) second" c))
mails)
(make-bundle state mails))))
(lambda (low state mails)
(check-arg-list 'make-bundle low world? "world" "first")
(check-arg-list 'make-bundle mails mail? "mail" "third")
(make-bundle low state mails))))
;; Symbol Any (Any -> Boolean) String String -> Void
;; raise a TP exception if low is not a list of world? elements
(define (check-arg-list tag low world? msg rank)
(check-arg tag (list? low) (format "list [of ~as]" msg) rank low)
(for-each (lambda (c)
(check-arg tag (world? c) msg (format "(elements of) ~a" rank) c))
low))
(define-struct mail (to content) #:transparent)

22
collects/2htdp/universe.ss
View File

@ -231,9 +231,9 @@
world1 ;; sample worlds
world2
world3
;; type Bundle = (make-bundle Universe [Listof Mail])
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; Universe [Listof Mail] -> Bundle
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
@ -254,10 +254,10 @@
;; in the console
(define-keywords UniSpec
[on-new (function-with-arity 2)]
[on-msg (function-with-arity 3)]
[on-disconnect (function-with-arity 2)]
[to-string (function-with-arity 1)])
[on-new (function-with-arity 3)]
[on-msg (function-with-arity 4)]
[on-disconnect (function-with-arity 3)]
[to-string (function-with-arity 2)])
(define-syntax (universe stx)
(syntax-case stx ()
@ -297,15 +297,15 @@
;; (World World -> U) (U World Msg) -> U
(define (universe2 create process)
;; UniState = '() | (list World) | Universe
;; UniState World -> (cons UniState [Listof (list World S-expression)])
(define (nu s p)
;; [Listof World] UniState World -> (cons UniState [Listof (list World S-expression)])
(define (nu s x p)
(cond
[(null? s) (make-bundle (list p) '())]
[(not (pair? s)) (make-bundle s '())]
[(null? s) (make-bundle (list p) '* '())]
[(not (pair? s)) (make-bundle s '* '())]
[(null? (rest s)) (create (first s) p)]
[else (error 'create "a third world is signing up!")]))
(universe '()
(on-new nu)
(on-msg process)
#;
(on-tick (lambda (u) (printf "hello!\n") (list u)) 1)))
(on-tick (lambda (u x) (printf "hello!\n") (list u)) 1)))