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

renamed world to iworld, for internal

Browse Source 
svn: r13587
This commit is contained in:
Matthias Felleisen 2009-02-15 00:57:41 +00:00
parent 7ac7491d53
commit 203ba8e2db
2 changed files with 58 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -57,21 +57,21 @@
(define (pname a ...) (define (pname a ...)
(define (handler e) (stop! e)) (define (handler e) (stop! e))
(with-handlers ([exn? handler]) (with-handlers ([exn? handler])
(define r (check-state-x-mail 'name (name worlds universe a ...))) (define r (check-state-x-mail 'name (name iworlds universe a ...)))
(define u (bundle-state r)) (define u (bundle-state r))
(set! worlds (bundle-low r)) (set! iworlds (bundle-low r))
(set! universe u) (set! universe u)
(unless (boolean? to-string) (send gui add (to-string worlds u))) (unless (boolean? to-string) (send gui add (to-string iworlds u)))
(broadcast (bundle-mails r)))))) (broadcast (bundle-mails r))))))
(def/cback private (pmsg world received) on-msg) (def/cback private (pmsg iworld received) on-msg)
(def/cback private (pdisconnect world) on-disconnect) (def/cback private (pdisconnect iworld) on-disconnect)
(def/cback private (pnew world) ppnew) (def/cback private (pnew iworld) ppnew)
(define/private (ppnew low uni p) (define/private (ppnew low uni p)
(world-send p 'okay) (iworld-send p 'okay)
(on-new low uni p)) (on-new low uni p))
(def/cback public (ptock) tick) (def/cback public (ptock) tick)
@ -90,7 +90,7 @@
;; ----------------------------------------------------------------------- ;; -----------------------------------------------------------------------
;; start and stop server, start and stop the universe ;; start and stop server, start and stop the universe
(field [worlds '()] ;; [Listof World] (field [iworlds '()] ;; [Listof World]
[gui (new gui% [gui (new gui%
[stop-server (lambda () (stop! universe))] [stop-server (lambda () (stop! universe))]
[stop-and-restart (lambda () (restart))])] [stop-and-restart (lambda () (restart))])]
@ -103,50 +103,50 @@
(parameterize ([current-custodian the-custodian]) (parameterize ([current-custodian the-custodian])
(define (loop) (define (loop)
(apply sync (apply sync
(handle-evt (tcp-accept-evt tcp-listener) add-world) (handle-evt (tcp-accept-evt tcp-listener) add-iworld)
(map world-wait-for-msg worlds))) (map iworld-wait-for-msg iworlds)))
(define (add-world in-out) (define (add-iworld in-out)
(with-handlers ((tcp-eof? (lambda _ (loop)))) (with-handlers ((tcp-eof? (lambda _ (loop))))
(define in (first in-out)) (define in (first in-out))
(define next (tcp-receive in)) (define next (tcp-receive in))
(match next (match next
[(cons 'REGISTER info) [(cons 'REGISTER info)
(let* ([w (create-world in (second in-out) info)]) (let* ([w (create-iworld in (second in-out) info)])
; (set! worlds (cons w worlds)) ; (set! iworlds (cons w iworlds))
(pnew w) (pnew w)
(send gui add (format "~a signed up" info)) (send gui add (format "~a signed up" info))
(loop))] (loop))]
[else (loop)]))) [else (loop)])))
(define (world-wait-for-msg p) (define (iworld-wait-for-msg p)
(handle-evt (world-in p) (handle-evt (iworld-in p)
(lambda (in) (lambda (in)
(with-handlers (with-handlers
((tcp-eof? ((tcp-eof?
(lambda (e) (lambda (e)
(handler p e (handler p e
(lambda () (lambda ()
(if (null? worlds) (if (null? iworlds)
(restart) (restart)
(loop))))))) (loop)))))))
(define r (tcp-receive in)) (define r (tcp-receive in))
(send gui add (format "~a ->: ~a" (world-name p) r)) (send gui add (format "~a ->: ~a" (iworld-name p) r))
(pmsg p r) (pmsg p r)
(loop))))) (loop)))))
(define tcp-listener (define tcp-listener
(with-handlers ((exn:fail:network? (lambda (x) (stop! x)))) (with-handlers ((exn:fail:network? (lambda (x) (stop! x))))
(tcp-listen SQPORT 4 #t))) (tcp-listen SQPORT 4 #t)))
;; --- go universe go --- ;; --- go universe go ---
(set! worlds '()) (set! iworlds '())
(set! universe universe0) (set! universe universe0)
(send gui add "a new universe is up and running") (send gui add "a new universe is up and running")
(thread loop))) (thread loop)))
;; World Exn (-> X) -> X ;; World Exn (-> X) -> X
(define/private (handler p e cont) (define/private (handler p e cont)
(close-output-port (world-out p)) (close-output-port (iworld-out p))
(close-input-port (world-in p)) (close-input-port (iworld-in p))
(send gui add (format "~a !! closed port" (world-name p))) (send gui add (format "~a !! closed port" (iworld-name p)))
(set! worlds (remq p worlds)) (set! iworlds (remq p iworlds))
(pdisconnect p) (pdisconnect p)
(cont)) (cont))
@ -163,12 +163,12 @@
;; (handler ;; (handler
(with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n")))) (with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n"))))
(define w (mail-to p+m)) (define w (mail-to p+m))
(define n (world-name w)) (define n (iworld-name w))
(define p (mail-content p+m)) (define p (mail-content p+m))
(unless (memq w worlds) (unless (memq w iworlds)
(send gui add (format "~s not on list" n))) (send gui add (format "~s not on list" n)))
(when (memq w worlds) (when (memq w iworlds)
(world-send w p) (iworld-send w p)
(send gui add (format "-> ~a: ~a" n p))))) (send gui add (format "-> ~a: ~a" n p)))))
lm)) lm))
@ -184,9 +184,9 @@
(send gui add "stopping the universe") (send gui add "stopping the universe")
(send gui add "----------------------------------") (send gui add "----------------------------------")
(for-each (lambda (w) (for-each (lambda (w)
(close-input-port (world-in w)) (close-input-port (iworld-in w))
(close-output-port (world-out w))) (close-output-port (iworld-out w)))
worlds) iworlds)
(custodian-shutdown-all the-custodian) (custodian-shutdown-all the-custodian)
(semaphore-post go))) (semaphore-post go)))
@ -217,35 +217,35 @@
; ;
(provide (provide
world? ;; Any -> Boolean iworld? ;; Any -> Boolean
world=? ;; World World -> Boolean iworld=? ;; World World -> Boolean
world-name ;; World -> Symbol iworld-name ;; World -> Symbol
world1 ;; sample worlds iworld1 ;; sample worlds
world2 iworld2
world3) iworld3)
;; --- the server representation of a world --- ;; --- the server representation of a world ---
(define-struct world (in out name info) #:transparent) (define-struct iworld (in out name info) #:transparent)
;; World = (make-world IPort OPort Symbol [Listof Sexp]) ;; World = (make-iworld IPort OPort Symbol [Listof Sexp])
(define world1 (make-world (current-input-port) (current-output-port) 'sk '())) (define iworld1 (make-iworld (current-input-port) (current-output-port) 'sk '()))
(define world2 (make-world (current-input-port) (current-output-port) 'mf '())) (define iworld2 (make-iworld (current-input-port) (current-output-port) 'mf '()))
(define world3 (make-world (current-input-port) (current-output-port) 'rf '())) (define iworld3 (make-iworld (current-input-port) (current-output-port) 'rf '()))
(define (world=? u v) (define (iworld=? u v)
(check-arg 'world=? (world? u) 'world "first" u) (check-arg 'iworld=? (iworld? u) 'iworld "first" u)
(check-arg 'world=? (world? v) 'world "second" v) (check-arg 'iworld=? (iworld? v) 'iworld "second" v)
(eq? u v)) (eq? u v))
;; IPort OPort Sexp -> Player ;; IPort OPort Sexp -> Player
(define (create-world i o info) (define (create-iworld i o info)
(if (and (pair? info) (symbol? (car info))) (if (and (pair? info) (symbol? (car info)))
(make-world i o (car info) (cdr info)) (make-iworld i o (car info) (cdr info))
(make-world i o (gensym 'world) info))) (make-iworld i o (gensym 'iworld) info)))
;; Player S-exp -> Void ;; Player S-exp -> Void
(define (world-send p sexp) (define (iworld-send p sexp)
(tcp-send (world-out p) sexp)) (tcp-send (iworld-out p) sexp))
; ;
; ;
@ -351,16 +351,16 @@
(set! make-bundle (set! make-bundle
(let ([make-bundle make-bundle]) (let ([make-bundle make-bundle])
(lambda (low state mails) (lambda (low state mails)
(check-arg-list 'make-bundle low world? "world" "first") (check-arg-list 'make-bundle low iworld? "iworld" "first")
(check-arg-list 'make-bundle mails mail? "mail" "third") (check-arg-list 'make-bundle mails mail? "mail" "third")
(make-bundle low state mails)))) (make-bundle low state mails))))
;; Symbol Any (Any -> Boolean) String String -> Void ;; Symbol Any (Any -> Boolean) String String -> Void
;; raise a TP exception if low is not a list of world? elements ;; raise a TP exception if low is not a list of world? elements
(define (check-arg-list tag low world? msg rank) (define (check-arg-list tag low iworld? msg rank)
(check-arg tag (list? low) (format "list [of ~as]" msg) rank low) (check-arg tag (list? low) (format "list [of ~as]" msg) rank low)
(for-each (lambda (c) (for-each (lambda (c)
(check-arg tag (world? c) msg (format "(elements of) ~a" rank) c)) (check-arg tag (iworld? c) msg (format "(elements of) ~a" rank) c))
low)) low))
(define-struct mail (to content) #:transparent) (define-struct mail (to content) #:transparent)
@ -368,6 +368,6 @@
(set! make-mail (set! make-mail
(let ([make-mail make-mail]) (let ([make-mail make-mail])
(lambda (to content) (lambda (to content)
(check-arg 'make-mail (world? to) 'world "first" to) (check-arg 'make-mail (iworld? to) 'iworld "first" to)
(check-arg 'make-mail (sexp? content) 'S-expression "second" content) (check-arg 'make-mail (sexp? content) 'S-expression "second" content)
(make-mail to content)))) (make-mail to content))))

12
collects/2htdp/universe.ss
View File

@ -226,12 +226,12 @@
(provide (provide
;; type World ;; type World
world? ;; Any -> Boolean iworld? ;; Any -> Boolean
world=? ;; World World -> Boolean iworld=? ;; World World -> Boolean
world-name ;; World -> Symbol iworld-name ;; World -> Symbol
world1 ;; sample worlds iworld1 ;; sample worlds
world2 iworld2
world3 iworld3
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail]) ;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
;; type Mail = (make-mail World S-expression) ;; type Mail = (make-mail World S-expression)
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle