From 8c91d96c50c141c071abcaf2b4d1ae6b5dd5b7ff Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 11 Nov 2011 17:56:12 -0500 Subject: [PATCH] added prefab structs to messages that universe can exchange --- collects/2htdp/private/check-aux.rkt | 18 +++++--- collects/2htdp/tests/struct-universe.rkt | 46 +++++++++++++++++++ collects/2htdp/xtest | 1 + .../2htdp/scribblings/universe.scrbl | 7 +-- 4 files changed, 63 insertions(+), 9 deletions(-) create mode 100644 collects/2htdp/tests/struct-universe.rkt diff --git a/collects/2htdp/private/check-aux.rkt b/collects/2htdp/private/check-aux.rkt index 45b8d96cb7..2d587d0681 100644 --- a/collects/2htdp/private/check-aux.rkt +++ b/collects/2htdp/private/check-aux.rkt @@ -26,7 +26,7 @@ ; ; -;; ----------------------------------------------------------------------------- +;; --------------------------------------------------------------------------------------------------- ;; Any -> Boolean (define (nat? x) @@ -37,14 +37,14 @@ (check-arg t (and (number? x) (real? x)) "real number" p x) (inexact->exact (floor x))) -;; ----------------------------------------------------------------------------- +;; --------------------------------------------------------------------------------------------------- ;; Nat Nat ->String ;; converts i to a string, adding leading zeros, make it at least as long as L (define (zero-fill i L) (let ([n (number->string i)]) (string-append (make-string (max (- L (string-length n)) 0) #\0) n))) -;; ----------------------------------------------------------------------------- +;; --------------------------------------------------------------------------------------------------- ;; MouseEvent% -> [List Nat Nat MouseEventType] ;; turn a mouse event into its pieces @@ -78,13 +78,13 @@ [(symbol? x) (symbol->string x)] [else (error 'on-key (format "Unknown event: ~a" x))])) -;; ----------------------------------------------------------------------------- +;; --------------------------------------------------------------------------------------------------- ;; Any -> Symbol (define (name-of draw tag) (define fname (object-name draw)) (if fname fname tag)) -;; ----------------------------------------------------------------------------- +;; --------------------------------------------------------------------------------------------------- ;; Any -> Boolean (define (sexp? x) (cond @@ -95,12 +95,18 @@ [(boolean? x) true] [(char? x) true] [(pair? x) (and (list? x) (andmap sexp? x))] + [(and (struct? x) (prefab-struct-key x)) (for/and ((i (struct->vector x))) (sexp? i))] [else false])) +; tests: +;(struct s (t) #:prefab) +;(unless (sexp? (list (s (list 'a)))) +; (error 'prefab "structs should be sexp?")) + (define (no-newline? x) (not (member #\newline (string->list x)))) -;; ----------------------------------------------------------------------------- +;; --------------------------------------------------------------------------------------------------- ;; exchange one-line messages between worlds and the server (define tcp-eof (gensym 'tcp-eof)) diff --git a/collects/2htdp/tests/struct-universe.rkt b/collects/2htdp/tests/struct-universe.rkt new file mode 100644 index 0000000000..5b9a593af3 --- /dev/null +++ b/collects/2htdp/tests/struct-universe.rkt @@ -0,0 +1,46 @@ +#lang racket/load + +(module shared racket/base + (require 2htdp/universe 2htdp/image) + + (struct s (t) #:prefab) + (provide s s-t (all-from-out 2htdp/universe 2htdp/image))) + +(module client racket + (require 'shared) + + ;; Color -> Boolean + (define (client c) + (define count 0) + (big-bang #true + (to-draw (lambda (w) (text (if w "hello world" "good bye") 22 c))) + (register LOCALHOST) + (stop-when (lambda (w) (> count 3))) + (on-receive + (lambda (w msg) + (set! count (+ count 1)) + ;; send out a prefabed struct to the server + (make-package (not w) (s count)))))) + + (launch-many-worlds (client 'blue) (client 'red))) + +(module server racket + (require 'shared) + + (define (server) + (universe '() + (on-new (lambda (w n) (make-bundle (cons n w) '() '()))) + (on-tick + (lambda (w*) + (make-bundle w* (map (lambda (w) (make-mail w 'go)) w*) '()))) + (on-msg + (lambda (state iw msg) + ;; display the received prefabbed struct's content + (displayln (s-t msg)) + (make-bundle state '() '()))))) + + (thread server)) + +(require 'server) + +(require 'client) \ No newline at end of file diff --git a/collects/2htdp/xtest b/collects/2htdp/xtest index 2efd7d3556..1d874d4338 100755 --- a/collects/2htdp/xtest +++ b/collects/2htdp/xtest @@ -36,4 +36,5 @@ run stop-when-crash.rkt run on-tick-universe-with-limit.rkt run on-tick-with-limit.rkt run on-release-no-key.rkt +run struct-universe.rkt diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index a3d1f5a4e7..97f3894bf1 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -692,9 +692,10 @@ data; to be precise, an S-expression is one of: @item{a number,} @item{a boolean,} @item{a char, or} - @item{a list of S-expressions.} + @item{a list of S-expressions, or} + @item{a prefab struct of S-expressions.} ] -Note the last clause includes @racket[empty] of course. +Note the @racket[list] clause includes @racket[empty] of course. @defproc[(sexp? [x any/c]) boolean?]{ determines whether @racket[x] is an @tech{S-expression}.} @@ -734,7 +735,7 @@ As mentioned, all event handlers may return @tech{WorldState}s or } @defform/none[#:literals (on-tick) - (on-tick tick-expr rate-expr) + (on-tick tick-expr rate-expr limit-expr) #:contracts ([tick-expr (-> (unsyntax @tech{WorldState}) (or/c (unsyntax @tech{WorldState}) package?))] [rate-expr (and/c real? positive?)]