diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss new file mode 100644 index 0000000000..b0a404c4d7 --- /dev/null +++ b/collects/2htdp/private/check-aux.ss @@ -0,0 +1,174 @@ +#lang scheme + +(require htdp/image + htdp/error + (only-in lang/htdp-beginner image?)) + +(provide (all-defined-out)) + +(define INSET 5) ;; the space around the image in the canvas +(define RATE 1/30) ;; the clock tick rate +(define TRIES 3) ;; how many times should register try to connect to the server +(define PAUSE 1/2) ;; # secs to wait between attempts to connect to server +(define SQPORT 4567) ;; the port on which universe traffic flows + +(define (K w . r) w) +(define (False w) #f) + +; +; +; +; ;;; ;;; +; ; ; ; ; +; ; ; ; ; +; ; ;;; ;;;;; ;;;;; ;;; ;;;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; +; ;;; ;;; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ;; +; +; +; + +;; ----------------------------------------------------------------------------- + +;; Any -> Boolean +(define (scene? i) + (and (image? i) (internal-scene? i))) + +;; Image -> Boolean +(define (internal-scene? i) + (and (= 0 (pinhole-x i)) (= 0 (pinhole-y i)))) + +;; Number -> Integer +(define (number->integer 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 +(define (mouse-event->parts e) + (define x (- (send e get-x) INSET)) + (define y (- (send e get-y) INSET)) + (list x y (cond [(send e button-down?) 'button-down] + [(send e button-up?) 'button-up] + [(send e dragging?) 'drag] + [(send e moving?) 'move] + [(send e entering?) 'enter] + [(send e leaving?) 'leave] + [else ; (send e get-event-type) + (error 'on-mouse-event + (format + "Unknown event type: ~a" + (send e get-event-type)))]))) + +;; ----------------------------------------------------------------------------- +;; Any -> Symbol +(define (name-of draw tag) + (define fname (object-name draw)) + (if fname fname tag)) + +;; ----------------------------------------------------------------------------- +;; Any -> Boolean +(define (sexp? x) + (cond + [(empty? x) true] + [(string? x) true] + [(symbol? x) true] + [(number? x) true] + [(char? x) true] + [(pair? x) (and (list? x) (andmap sexp? x))] + [else false])) + +(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)) + +;; Any -> Boolean +(define (tcp-eof? a) (eq? tcp-eof a)) + +;; OutPort Sexp -> Void +(define (tcp-send out msg) + (write msg out) + (newline out) + (flush-output out)) + +;; InPort -> Sexp +(define (tcp-receive in) + (with-handlers ((exn? (lambda (x) (raise tcp-eof)))) + (define x (read in)) + (if (eof-object? x) + (raise tcp-eof) + (begin + (read-line in) ;; read the newline + x)))) + +; +; +; +; ;;; ;;; ; ; +; ; ; ; ; ; ; +; ; ; ; ; ; ; +; ; ; ; ;; ;;;; ; ;;;; ; ; +; ;;;;; ;; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ;;;; ;;; ; ; ; ; +; ; +; ; ; +; ;;; + +;; Symbol Any String -> Void +(define (check-pos t c r) + (check-arg + t (and (number? c) (> (number->integer c) 0)) "positive integer" r c)) + +;; Symbol Any String String *-> Void +(define (check-image tag i rank . other-message) + (if (and (pair? other-message) (string? (car other-message))) + (check-arg tag (image? i) (car other-message) rank i) + (check-arg tag (image? i) "image" rank i))) + +;; Symbol Any String -> Void +(define (check-scene tag i rank) + (define error "image with pinhole at (~s,~s)") + (if (image? i) + (check-arg tag (internal-scene? i) "scene" rank (image-pins i)) + (check-arg tag #f "scene" rank i))) + +;; Symbol Any -> Void +(define (check-scene-result tname i) + (if (image? i) + (check-result tname internal-scene? "scene" i (image-pins i)) + (check-result tname (lambda (x) (image? x)) "scene" i))) + +(define (image-pins i) + (format "image with pinhole at (~s,~s)" (pinhole-x i) (pinhole-y i))) + + +;; Symbol Any String -> Void +(define (check-color tag width rank) + (check-arg tag (or (symbol? width) (string? width)) + "color symbol or string" rank width)) + +;; Symbol (union Symbol String) Nat -> Void +(define (check-mode tag s rank) + (check-arg tag (or (eq? s 'solid) + (eq? s 'outline) + (string=? "solid" s) + (string=? "outline" s)) "mode (solid or outline)" rank s)) + diff --git a/collects/2htdp/private/design.txt b/collects/2htdp/private/design.txt new file mode 100644 index 0000000000..df68373fc0 --- /dev/null +++ b/collects/2htdp/private/design.txt @@ -0,0 +1,17 @@ + +Files for constructing universe.ss: + + world.ss the old world + world% = (clock-mixin ...) -- the basic world + aworld% = (class world% ...) -- the world with recording + + universe.ss the universe server + universe% = (clock-mixin ...) -- the basic universe + + timer.ss the clock-mixin + + check-aux.ss common primitives + image.ss the world image functions + syn-aux.ss syntactic auxiliaries + syn-aux-aux.ss auxiliaries to the syntactic auxiliaries + diff --git a/collects/2htdp/private/image.ss b/collects/2htdp/private/image.ss new file mode 100644 index 0000000000..de4c4b39ce --- /dev/null +++ b/collects/2htdp/private/image.ss @@ -0,0 +1,195 @@ +#lang scheme + +(require htdp/image + htdp/error + "check-aux.ss") + +; +; +; ;;;;; ;;;;; +; ; ; +; ; ; +; ; ;;; ; ;;;; ;;;; ;;; ; ; ; ; ;; ;;; +; ; ; ;;; ; ; ; ; ; ; ;;;;; ; ; ;; ; ; ; +; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ; +; ;;;;; ; ; ; ;; ; ;; ; ;;;; ; ;; ; ; ; ;;; +; ; +; ;;;; +; + +(provide (all-from-out htdp/image)) + +(provide + ;; Scene is Image with pinhole in origin + nw:rectangle ;; Number Number Mode Color -> Image + place-image ;; Image Number Number Scene -> Scene + empty-scene ;; Number Number -> Scene + scene+line ;; Scene Number Number Number Number Color -> Scene + ;; cut all pieces that are outside the given rectangle + ) + +(define (nw:rectangle width height mode color) + (check-pos 'rectangle width "first") + (check-pos 'rectangle height "second") + (check-mode 'rectangle mode "third") + (check-color 'rectangle color "fourth") + (put-pinhole (rectangle width height mode color) 0 0)) + +(define (place-image image x y scene) + (check-image 'place-image image "first") + (check-arg 'place-image (number? x) 'integer "second" x) + (check-arg 'place-image (number? y) 'integer "third" y) + (check-scene 'place-image scene "fourth") + (let ([x (number->integer x)] + [y (number->integer y)]) + (place-image0 image x y scene))) + +(define (empty-scene width height) + (check-pos 'empty-scene width "first") + (check-pos 'empty-scene height "second") + (put-pinhole + (overlay (rectangle width height 'solid 'white) + (rectangle width height 'outline 'black)) + 0 0)) + +(define (scene+line img x0 y0 x1 y1 c) + ;; img and c are checked via calls to add-line from image.ss + (check-arg 'scene+line (scene? img) "scene" "first" "plain image") + (check-arg 'scene+line (number? x0) "number" "second" x0) + (check-arg 'scene+line (number? y0) "number" "third" y0) + (check-arg 'scene+line (number? x1) "number" "fourth" x1) + (check-arg 'scene+line (number? y1) "number" "fifth" y1) + (let ([x0 (number->integer x0)] + [x1 (number->integer x1)] + [y0 (number->integer y0)] + [y1 (number->integer y1)]) + (add-line-to-scene0 img x0 y0 x1 y1 c))) + +;; Image Number Number Image -> Image +(define (place-image0 image x y scene) + (define sw (image-width scene)) + (define sh (image-height scene)) + (define ns (overlay/xy scene x y image)) + (define nw (image-width ns)) + (define nh (image-height ns)) + (if (and (= sw nw) (= sh nh)) ns (shrink ns 0 0 (- sw 1) (- sh 1)))) + +;; Image Number Number Number Number Color -> Image +(define (add-line-to-scene0 img x0 y0 x1 y1 c) + (define w (image-width img)) + (define h (image-height img)) + (cond + [(and (<= 0 x0) (< x0 w) (<= 0 x1) (< x1 w) (<= 0 y0) (< y0 w) (<= 0 y1) (< y1 w)) + (add-line img x0 y0 x1 y1 c)] + [(= x0 x1) ;; vertical + (if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)] + [(= y0 y1) ;; horizontal + (if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)] + [else + (local ((define lin (points->line x0 y0 x1 y1)) + (define dir (direction x0 y0 x1 y1)) + (define-values (upp low lft rgt) (intersections lin w h)) + (define (add x y) (add-line img x0 y0 x y c))) + (cond + [(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior + (case dir + [(upper-left) (if (number? upp) (add upp 0) (add 0 lft))] + [(lower-left) (if (number? low) (add low h) (add 0 lft))] + [(upper-right) (if (number? upp) (add upp 0) (add h rgt))] + [(lower-right) (if (number? low) (add low h) (add w rgt))] + [else (error 'dir "contract violation: ~e" dir)])] + [(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry! + (add-line-to-scene0 img x1 y1 x0 y0 c)] + [else + (cond + [(and (number? upp) (number? low)) (add-line img upp 0 low h c)] + [(and (number? upp) (number? lft)) (add-line img upp 0 0 lft c)] + [(and (number? upp) (number? rgt)) (add-line img upp 0 w rgt c)] + [(and (number? low) (number? lft)) (add-line img low h 0 lft c)] + [(and (number? low) (number? rgt)) (add-line img low h w rgt c)] + [(and (number? lft) (number? rgt)) (add-line img 0 lft w rgt c)] + [else img])]))])) + +;; Nat Nat -> Nat +;; y if in [0,h], otherwise the closest boundary +(define (app y h) + (cond + [(and (<= 0 y) (< y h)) y] + [(< y 0) 0] + [else (- h 1)])) + +;; Nat Nat Nat Nat -> (union 'upper-left 'upper-right 'lower-left 'lower-right) +;; how to get to (x1,y1) from (x0,y0) +(define (direction x0 y0 x1 y1) + (string->symbol + (string-append + (if (<= y0 y1) "lower" "upper") "-" (if (<= x0 x1) "right" "left")))) + +#| TESTS +'direction +(equal? (direction 10 10 0 0) 'upper-left) +(equal? (direction 10 10 20 20) 'lower-right) +(equal? (direction 10 10 0 20) 'lower-left) +(equal? (direction 10 10 20 0) 'upper-right) +|# + +;; ----------------------------------------------------------------------------- +;; LINEs + +;; Number Number -> LINE +;; create a line from a slope and the intersection with the y-axis +(define-struct lyne (slope y0)) + +;; Nat Nat Nat Nat -> LINE +;; determine the line function from the four points (or the attributes) +;; ASSUME: (not (= x0 x1)) +(define (points->line x0 y0 x1 y1) + (local ((define slope (/ (- y1 y0) (- x1 x0)))) + (make-lyne slope (- y0 (* slope x0))))) + +;; LINE Number -> Number +(define (of ln x) (+ (* (lyne-slope ln) x) (lyne-y0 ln))) + +;; LINE Nat Nat -> [Opt Number] [Opt Number] [Opt Number] [Opt Number] +;; where does the line intersect the rectangle [0,w] x [0,h] +;; (values UP LW LF RT) means the line intersects with +;; the rectangle [0,w] x [0,h] at (UP,0) or (LW,h) or (0,LF) or (w,RT) +;; when a field is false, the line doesn't interesect with that side +(define (intersections l w h) + (values + (opt (X l 0) w) (opt (X l h) w) (opt (lyne-y0 l) h) (opt (of l w) h))) + +;; Number Number -> [Opt Number] +(define (opt z lft) (if (<= 0 z lft) z false)) + +;; LINE Number -> Number +;; the x0 where LINE crosses y(x) = h +;; assume: LINE is not a horizontal +(define (X ln h) (/ (- h (lyne-y0 ln)) (lyne-slope ln))) + +;; --- TESTS --- +#| +(define line1 (points->line 0 0 100 100)) +(= (of line1 0) 0) +(= (of line1 100) 100) +(= (of line1 50) 50) + +(= (X (make-lyne 1 0) 0) 0) +(= (X (make-lyne 1 0) 100) 100) + +(equal? (call-with-values + (lambda () (intersections (points->line -10 -10 110 110) 100 100)) + list) + (list 0 100 0 100)) +(equal? (call-with-values + (lambda () (intersections (points->line 0 10 100 80) 100 100)) + list) + (list false false 10 80)) +|# + +;; ----------------------------------------------------------------------------- + +; +; diff --git a/collects/2htdp/private/last.ss b/collects/2htdp/private/last.ss new file mode 100644 index 0000000000..8faf32bcd2 --- /dev/null +++ b/collects/2htdp/private/last.ss @@ -0,0 +1,30 @@ +#lang scheme/gui + +(require "timer.ss") + +(provide last-mixin) + +(define last-mixin + (mixin (start-stop<%>) () + (field [end:ch (make-channel)]) + ;; X -> Void + (define/override (stop! w) + (send-to-last w) + (super stop! w)) + + ;; -> World + (define/public (last) + (define result (yield end:ch)) + (if (exn? result) (raise result) result)) + + (field [dr:cust (current-custodian)]) + + ;; X -> Void + ;; send x to last method + (define/private (send-to-last x) + (parameterize ((current-custodian dr:cust)) + (thread (lambda () (channel-put end:ch x))))) + + (super-new))) + + diff --git a/collects/2htdp/private/syn-aux-aux.ss b/collects/2htdp/private/syn-aux-aux.ss new file mode 100644 index 0000000000..538164f672 --- /dev/null +++ b/collects/2htdp/private/syn-aux-aux.ss @@ -0,0 +1,60 @@ +#lang scheme + +(require htdp/error) + +; +; +; +; ;;; ;;; +; ; ; ; ; +; ; ; ; +; ; ; ; ;;;; ; ; ; ; ; ; +; ;;; ; ; ; ; ;;;;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ;; ; ; +; ;;; ;;;; ; ; ; ; ;; ; ; ; +; ; +; ; ; +; ;;; + +(provide nat> nat? proc> bool> num> ip> string> symbol>) + +;; Any -> Boolean +(define (nat? x) + (and (number? x) (integer? x) (>= x 0))) + +;; Symbol X -> X +(define (bool> tag x) + (check-arg tag (boolean? x) "boolean" "first" x) + x) + +;; Symbol X -> X +(define (string> tag x) + (check-arg tag (string? x) "string" "first" x) + x) + +(define ip> string>) + +;; Symbol X -> X +(define (symbol> tag x) + (check-arg tag (symbol? x) "symbol" "second" x) + x) + +;; Symbol X Nat -> X +(define (proc> tag f ar) + (check-proc tag f ar "first" + (if (> ar 1) + (format "~a arguments" ar) + "one argument")) + f) + +;; Symbol X (Number -> Boolean) String String -> X +(define (num> tag x pred? spec which) + (check-arg tag (and (number? x) (pred? x)) spec which x) + x) + +;; Symbol X String -> X +(define (nat> tag x spec) + (check-arg tag (nat? x) spec "natural number" x) + x) diff --git a/collects/2htdp/private/syn-aux.ss b/collects/2htdp/private/syn-aux.ss new file mode 100644 index 0000000000..a44a2af08d --- /dev/null +++ b/collects/2htdp/private/syn-aux.ss @@ -0,0 +1,43 @@ +#lang scheme + +(provide define-keywords function-with-arity except err check-flat-spec + (all-from-out "syn-aux-aux.ss")) + +(require "syn-aux-aux.ss" + (for-template "syn-aux-aux.ss" + scheme + (rename-in lang/prim (first-order->higher-order f2h)))) + +(define-syntax-rule (define-keywords the-list (kw coerce) ...) + (begin + (provide kw ...) + (define-syntax (kw x) + (raise-syntax-error 'kw "used out of context" x)) + ... + (define-for-syntax the-list (list (list 'kw (coerce ''kw)) ...)))) + +(define-syntax function-with-arity + (syntax-rules (except) + [(_ arity) + (lambda (tag) + (lambda (p) + (syntax-case p () + [(x) #`(proc> #,tag (f2h x) arity)] + [_ (err tag p)])))] + [(_ arity except extra) + (lambda (tag) + (lambda (p) + (syntax-case p () + [(x) #`(proc> #,tag (f2h x) arity)] + extra + [_ (err tag p)])))])) + +(define (err spec p) + (raise-syntax-error #f "illegal specification" #`(#,spec . #,p) p)) + +;; Symbol (Symbol X -> X) -> (X -> X) +(define (check-flat-spec tag coerce>) + (lambda (p) + (syntax-case p () + [(b) #'(coerce> tag b)] + [_ (err tag p)]))) \ No newline at end of file diff --git a/collects/2htdp/private/timer.ss b/collects/2htdp/private/timer.ss new file mode 100644 index 0000000000..1beaa18c30 --- /dev/null +++ b/collects/2htdp/private/timer.ss @@ -0,0 +1,38 @@ +#lang scheme/gui + +;; The module provides a timer mixing for world and universe. + +;; The interface ensures that super class provides start and stop method, +;; plus a call back for clock ticks. The super-init call provides the +;; on-tick parameter, which the super-class uses to define the callback. + + +(require "check-aux.ss") + +(provide clock-mixin start-stop<%>) + +(define start-stop<%> (interface () start! ptock stop!)) + +;; T = (U (World -> World) (list (World -> World) Nat)) +;; X [(list (World -> World) Nat) -> X] [(World -> World) -> X] -> [T -> X] +(define (selector default lchoice pchoice) + (lambda (on-tick) + (cond + [(cons? on-tick) (lchoice on-tick)] + [(procedure? on-tick) (pchoice on-tick)] + [else default]))) + +(define clock-mixin + (mixin (start-stop<%>) () + (inherit ptock) + (init-field [on-tick #f]) + (field [rate ((selector 0 second (lambda _ RATE)) on-tick)] + [timer (new timer% [notify-callback (lambda () (ptock))])]) + (define/override (start!) + (unless (<= rate 0) + (send timer start (number->integer (* 1000 rate)))) + (super start!)) + (define/override (stop! w) + (send timer stop) + (super stop! w)) + (super-new [tick ((selector void first (lambda (x) x)) on-tick)]))) diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss new file mode 100644 index 0000000000..17b5263732 --- /dev/null +++ b/collects/2htdp/private/universe.ss @@ -0,0 +1,363 @@ +#lang scheme/gui + +(require (for-syntax "syn-aux.ss") + "check-aux.ss" + "timer.ss" + "last.ss" + scheme/match + htdp/error + (only-in mzlib/etc evcase) + string-constants) + +(provide universe%) + +; +; +; +; ; ; ; +; ; ; ; +; ; ; +; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;; +; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;; ; ; ; ; ;;; ; ;;; ;;; +; +; +; + +(define universe% + (last-mixin + (clock-mixin + (class* object% (start-stop<%>) (inspect #f) (super-new) + (init-field ;; type Result = (make-bundle Universe [Listof Mail]) + universe0 ;; the initial state of the universe + on-new ;; Universe World -> Result + on-msg ;; Universe World Message -> Result + tick ;; Universe -> Result + (on-disconnect ;; Universe World -> Result + (lambda (u w) (list u))) + (to-string #f) ;; Universe -> String + ) + + (field [universe universe0]) + + ;; ----------------------------------------------------------------------- + ;; dealing with events + (define-syntax-rule + ;; A B ... -> Void + (def/cback pub (pname a ...) + ;; Universe A B ... -> (cons Universe Mail) + ;; effect: change server state, broadcast mails + name) + (begin + (pub pname) + (define (pname a ...) + (define (handler e) (stop! e)) + (with-handlers ([exn? handler]) + (define r (check-state-x-mail 'name (name universe a ...))) + (define u (bundle-state r)) + (set! universe u) + (unless (boolean? to-string) (send gui add (to-string u))) + (broadcast (bundle-mails r)))))) + + (def/cback private (pmsg world received) on-msg) + + (def/cback private (pdisconnect world) on-disconnect) + + (def/cback private (pnew world) ppnew) + + (define/private (ppnew uni p) + (world-send p 'okay) + (on-new uni p)) + + (def/cback public (ptock) tick) + + ;; Symbol Any -> Result + ;; check that r is Result + ;; effect: stop the server if the callbacks perform badly + (define/private (check-state-x-mail tag r) + (with-handlers ((exn? (lambda (x) (stop! x)))) + (define s (format "expected from ~a, given: " tag)) + (unless (bundle? r) + (error tag (format "(make-bundle Universe [Listof Mail]) ~a~e" s r))) + r)) + + ;; ----------------------------------------------------------------------- + ;; start and stop server, start and stop the universe + + (field [worlds '()] ;; [Listof World] + [gui (new gui% + [stop-server (lambda () (stop! universe))] + [stop-and-restart (lambda () (restart))])] + [dr:custodian (current-custodian)] + [the-custodian (make-custodian)]) + + ;; start the universe, enable registrations and message exchanges + (define/public (start!) + (set! the-custodian (make-custodian)) + (parameterize ([current-custodian the-custodian]) + (define (loop) + (apply sync + (handle-evt (tcp-accept-evt tcp-listener) add-world) + (map world-wait-for-msg worlds))) + (define (add-world in-out) + (with-handlers ((tcp-eof? (lambda _ (loop)))) + (define in (first in-out)) + (define next (tcp-receive in)) + (match next + [(cons 'REGISTER info) + (let* ([w (create-world in (second in-out) info)]) + (set! worlds (cons w worlds)) + (pnew w) + (send gui add (format "~a signed up" info)) + (loop))] + [else (loop)]))) + (define (world-wait-for-msg p) + (handle-evt (world-in p) + (lambda (in) + (with-handlers + ((tcp-eof? + (lambda (e) + (handler p e + (lambda () + (if (null? worlds) + (restart) + (loop))))))) + (define r (tcp-receive in)) + (send gui add (format "~a ->: ~a" (world-name p) r)) + (pmsg p r) + (loop))))) + (define tcp-listener + (with-handlers ((exn:fail:network? (lambda (x) (stop! x)))) + (tcp-listen SQPORT 4 #t))) + ;; --- go universe go --- + (set! worlds '()) + (set! universe universe0) + (send gui add "a new universe is up and running") + (thread loop))) + + ;; World Exn (-> X) -> X + (define/private (handler p e cont) + (close-output-port (world-out p)) + (close-input-port (world-in p)) + (send gui add (format "~a !! closed port" (world-name p))) + (set! worlds (remq p worlds)) + (pdisconnect p) + (cont)) + + ;; [Listof Mail] -> Void + ;; send payload of messages to designated worlds + (define/private (broadcast lm) + ;;; --- why the heck is there no exception handler ------------- + (for-each (lambda (p+m) + ;; what exception should I catch + ;; remove the world from the list + ;; factor out from elsewhere + ;; can this mean I perform a callback during a callback? + ;; collect 'bad' worlds instead and disconnect them later? + ;; (handler + (with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n")))) + (define w (mail-to p+m)) + (define n (world-name w)) + (define p (mail-content p+m)) + (unless (memq w worlds) + (send gui add (format "~s not on list" n))) + (when (memq w worlds) + (world-send w p) + (send gui add (format "-> ~a: ~a" n p))))) + lm)) + + (define/private (restart) + ;; I am running in a custodian that is about to be killed, + ;; so let's switch to one up in the hierarchy + (let ([old-t (current-thread)] + [go (make-semaphore)]) + (parameterize ([current-custodian dr:custodian]) + (thread (lambda () + (sync old-t go) + (start!)))) + (send gui add "stopping the universe") + (send gui add "----------------------------------") + (for-each (lambda (w) + (close-input-port (world-in w)) + (close-output-port (world-out w))) + worlds) + (custodian-shutdown-all the-custodian) + (semaphore-post go))) + + (define/public (stop! msg) + (send gui show #f) + (custodian-shutdown-all the-custodian)) + + ;; ----------------------------------------------------------------------- + ;; initialize the universe and run + (send gui show #t) + (start!))))) + + +; +; +; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ;;; ; ;; ; ;;;; ;;; +; ; ; ; ; ;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;; +; ;; ;; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ;;; ; ;; ;;;; ;;; +; +; +; + +(provide + world? ;; Any -> Boolean + world=? ;; World World -> Boolean + world1 ;; sample worlds + world2 + world3) + +;; --- the server representation of a world --- +(define-struct world (in out name info) #:transparent) +;; World = (make-world IPort OPort Symbol [Listof Sexp]) + +(define world1 (make-world (current-input-port) (current-output-port) 'sk '())) +(define world2 (make-world (current-input-port) (current-output-port) 'mf '())) +(define world3 (make-world (current-input-port) (current-output-port) 'rf '())) + +(define (world=? u v) + (check-arg 'world=? (world? u) 'world "first" u) + (check-arg 'world=? (world? v) 'world "second" v) + (eq? u v)) + +;; IPort OPort Sexp -> Player +(define (create-world i o info) + (if (and (pair? info) (symbol? (car info))) + (make-world i o (car info) (cdr info)) + (make-world i o (gensym 'world) info))) + +;; Player S-exp -> Void +(define (world-send p sexp) + (tcp-send (world-out p) sexp)) + +; +; +; +; ;;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ;;; ;;; ; +; +; +; + +;; effect: create and show a gui with two buttons and an editor for logging +(define gui% + (class frame% + (init stop-server stop-and-restart) + (inherit show) + (define/augment (on-close) (end)) + (super-new [label "Universe"][width 500][height 300][style '(metal)]) + (field + [end (lambda _ (show #f) (stop-server))] + [panel (new horizontal-panel% [parent this] [stretchable-height #f] + [alignment '(center center)])] + [stop (new button% [parent panel] [label "stop"] [callback end])] + [s&re (new button% [parent panel] [label "stop and restart"] + [callback (lambda (but evt) (stop-and-restart))])] + [text (new text%)] + [edit (new editor-canvas% [parent this] [editor text] + [style '(no-border combo no-hscroll auto-vscroll)])]) + + ;; add lines to the end of the text + (define/public (add str) + (queue-callback + (lambda () + (send text lock #f) + (send text insert (format "~a\n" str) (send text last-position)) + (send text lock #t)))) + + ;; ------------------------------------------------------------------------- + ;; add menu, lock, and show + (copy-and-paste this) + (send text lock #t))) + +;; ----------------------------------------------------------------------------- +;; Frame Text -> Void +;; add menu bar to frame for copying all of the text +(require string-constants) + +(define (copy-and-paste frame) + (define mb (new menu-bar% [parent frame])) + (define edit (new menu% + [label (string-constant edit-menu-label)] + [parent mb])) + (new menu-item% + [label (string-constant copy-menu-item)] + [parent edit] + [shortcut #\c] + [callback (lambda (m e) + (define t (send frame get-focus-object)) + (when (is-a? t editor<%>) + (send t copy)))]) + (new menu-item% + [label (string-constant select-all-menu-item)] + [parent edit] + [shortcut #\a] + [callback (lambda (m e) + (define t (send frame get-focus-object)) + (when (is-a? t text%) + (send t set-position 0 (send t last-position))))]) + (void)) + +; +; +; ;;; ;;; ; ;; +; ;; ;; ; +; ;; ;; ;;; ;;; ; +; ; ; ; ; ; ; ; +; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; +; ; ; ; ; ; ; +; ;;; ;;; ;;;;; ;;;;; ;;;;; +; +; +; +; + +(provide + ;; type Bundle = (make-bundle Universe [Listof Mail]) + ;; type Mail = (make-mail World S-expression) + make-bundle ;; 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) + +(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)))) + +(define-struct mail (to content) #:transparent) + +(set! make-mail + (let ([make-mail make-mail]) + (lambda (to content) + (check-arg 'make-mail (world? to) 'world "first" to) + (check-arg 'make-mail (sexp? content) 'S-expression "second" content) + (make-mail to content)))) diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss new file mode 100644 index 0000000000..2270aafeb1 --- /dev/null +++ b/collects/2htdp/private/world.ss @@ -0,0 +1,382 @@ +#lang scheme/gui + +(require "check-aux.ss" + "timer.ss" + "last.ss" + htdp/image + htdp/error + mzlib/runtime-path + mrlib/bitmap-label + string-constants + mrlib/gif) + +(provide world% aworld%) + +; +; +; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ;;; ; ;; ; ;;;; +; ; ; ; ; ;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ;; ;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; +; ; ; ;;; ; ;; ;;;; +; +; +; + +;; ----------------------------------------------------------------------------- +;; packages for broadcasting information to the universe + +(define-struct package (world message) #:transparent) + +;; World Sexp -> Package +(define (create-package w m) + (check-arg 'make-package (sexp? m) 'sexp "second" m) + (make-package w m)) + +(provide + (rename-out (create-package make-package)) ;; World S-expression -> Package + package? ;; Any -> Package + ) + +(define world% + (last-mixin + (clock-mixin + (class* object% (start-stop<%>) + (inspect #f) + (init-field + world0 ;; World + (tick K)) ;; (U (World -> World) (list (World -> World) Nat)) + + (init + (on-key K) ;; World KeyEvent -> World + (on-mouse K) ;; World Nat Nat MouseEvent -> World + (on-receive #f) ;; (U #f (World S-expression -> World)) + (on-draw #f) ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat)) + (stop-when False) ;; World -> Boolean + (record? #f) ;; Boolean + (register #f)) ;; (U #f String (list String Symbol)) + + ;; ----------------------------------------------------------------------- + (field (world world0)) + + ;; (U World Package) -> Boolean + ;; does the new world differ from the old? + ;; effect: if so, set world + (define/private (set-world new-world) + (when (package? new-world) + (broadcast (package-message new-world)) + (set! new-world (package-world new-world))) + (if (equal? world new-world) + #t + (begin + (set! world new-world) + #f))) + + ;; ----------------------------------------------------------------------- + (field [*out* #f] ;; (U #f OutputPort), where to send messages to + [*rec* (make-custodian)] ;; Custodian, monitor traffic + [host (cond + [(string? register) register] + [(pair? register) (car register)] + [else register])] + [name (cond + [(string? register) (gensym 'world)] + [(pair? register) (second register)] + [else register])]) + + (define/private (register-with-host) + (define FMTtry "unable to register with ~a after ~s tries") + (define FMTcom "unable to register with ~a due to protocol problems") + ;; try to register with the server n times + (define (register n) + (printf "trying to register with ~a ...\n" host) + (with-handlers ((tcp-eof? + (lambda (x) + (error 'register FMTcom host))) + (exn:fail:network? + (lambda (x) + (if (= n 1) + (error 'register FMTtry host TRIES) + (begin (sleep PAUSE) + (register (- n 1))))))) + (define-values (in out) (tcp-connect host SQPORT)) + (tcp-send out `(REGISTER ,(if name name (gensym 'world)))) + (if (eq? (tcp-receive in) 'okay) + (values in out) + (raise tcp-eof)))) + ;; --- now register, obtain connection, and spawn a thread for receiving + (parameterize ([current-custodian *rec*]) + (define-values (in out) (register TRIES)) + (define dis (text "the universe disappeared" 11 'red)) + (define (RECEIVE) + (sync + (handle-evt + in + (lambda (in) + (with-handlers ((tcp-eof? (compose (handler #f) + (lambda (e) + (set! draw (lambda (w) dis)) + (pdraw) + e)))) + ;; --- "the universe disconnected" should come from here --- + (define msg (tcp-receive in)) + (cond + [(sexp? msg) (prec msg) (RECEIVE)] ;; break loop if EOF + [#t (error 'RECEIVE "sexp expected, received: ~e" msg)])))))) + (printf "... successful registered and ready to receive\n") + (set! *out* out) + (thread RECEIVE))) + + (define/private (broadcast msg) + (when *out* + (check-result 'send sexp? "Sexp expected; given ~e\n" msg) + (tcp-send *out* msg))) + + ;; ----------------------------------------------------------------------- + (field + (draw (cond + [(procedure? on-draw) on-draw] + [(pair? on-draw) (first on-draw)] + [else on-draw])) + (live (not (boolean? draw))) + (width (if (pair? on-draw) (second on-draw) #f)) + (height (if (pair? on-draw) (third on-draw) #f))) + + ;; the visible world + (field [enable-images-button void] ;; used if stop-when call produces #t + [disable-images-button void] + [visible (new pasteboard%)]) + + (define (show-canvas) + (send visible set-cursor (make-object cursor% 'arrow)) + (let ([fst-scene (ppdraw)]) + (set! width (if width width (image-width fst-scene))) + (set! height (if height height (image-height fst-scene))) + (create-frame) + (show fst-scene))) + + ;; effect: create, show and set the-frame + (define/pubment (create-frame) + (define play-back:cust (make-custodian)) + (define frame (new (class frame% + (super-new) + (define/augment (on-close) + (callback-stop! 'frame-stop) + (custodian-shutdown-all play-back:cust))) + (label (if name (format "~a's World" name) "World")) + (stretchable-width #f) + (stretchable-height #f) + (style '(no-resize-border metal)))) + (define editor-canvas + (new (class editor-canvas% + (super-new) + ;; deal with keyboard events + (define/override (on-char e) + (when live (pkey (send e get-key-code)))) + ;; deal with mouse events if live and within range + (define/override (on-event e) + (define l (mouse-event->parts e)) + (when live + (when (and (<= 0 (first l) width) (<= 0 (second l) height)) + (pmouse . l))))) + (parent frame) + (editor visible) + (style '(no-hscroll no-vscroll)) + (horizontal-inset INSET) + (vertical-inset INSET))) + (send editor-canvas min-client-width (+ width INSET INSET)) + (send editor-canvas min-client-height (+ height INSET INSET)) + (set!-values (enable-images-button disable-images-button) + (inner (values void void) create-frame frame play-back:cust)) + (send editor-canvas focus) + (send frame show #t)) + + ;; Image -> Void + ;; show the image in the visible world + (define/public (show pict) + (send visible begin-edit-sequence) + (send visible lock #f) + (let ([s (send visible find-first-snip)] + [c (send visible get-canvas)]) + (when s (send visible delete s)) + (send visible insert (send pict copy) 0 0)) + (send visible lock #t) + (send visible end-edit-sequence)) + + ;; ----------------------------------------------------------------------- + ;; callbacks + (field + (key on-key) + (mouse on-mouse) + (rec on-receive)) + + (define-syntax-rule (def/pub-cback (name arg ...) transform) + ;; Any ... -> Boolean + (define/public (name arg ...) + (queue-callback + (lambda () + (with-handlers ([exn:break? (handler #f)][exn? (handler #t)]) + (define changed-world? (set-world (transform world arg ...))) + (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) + + ;; key events + (def/pub-cback (pkey ke) key) + + ;; mouse events + (def/pub-cback (pmouse x y me) mouse) + + ;; receive revents + (def/pub-cback (prec msg) rec) + + ;; ----------------------------------------------------------------------- + ;; draw : render this world + (define/private (pdraw) (show (ppdraw))) + + (define/private (ppdraw) + (check-scene-result (name-of draw 'your-draw) (draw world))) + + ;; ----------------------------------------------------------------------- + ;; stop-when + (field [stop stop-when]) + + (define/private (pstop) + (define result (stop world)) + (check-result (name-of stop 'your-stop-when) boolean? "boolean" result) + result) + + ;; ----------------------------------------------------------------------- + ;; start & stop + (define/public (callback-stop! msg) + (stop! world)) + + (define (handler re-raise) + (lambda (e) + (disable-images-button) + (stop! (if re-raise e world)))) + + (define/public (start!) + (when draw (show-canvas)) + (when host (register-with-host))) + + (define/public (stop! w) + (set! live #f) + (custodian-shutdown-all *rec*)) + + ;; ------------------------------------------------------------------------- + ;; initialize the world and run + (super-new) + (start!))))) + +;; ----------------------------------------------------------------------------- +(define-runtime-path break-btn:path '(lib "icons/break.png")) +(define break-button:label + ((bitmap-label-maker (string-constant break-button-label) break-btn:path) '_)) + +(define-runtime-path image-button:path '(lib "icons/file.gif")) +(define image-button:label ((bitmap-label-maker "Images" image-button:path) '_)) + +(define aworld% + (class world% (super-new) + (inherit-field world0 tick key mouse rec draw rate width height) + (inherit show callback-stop!) + + ;; Frame Custodian -> (-> Void) + ;; adds the stop animation and image creation button, + ;; whose callbacks runs as a thread in the custodian + ;; provide a function for switching button enabling + (define/augment (create-frame frm play-back-custodian) + (define p (new horizontal-pane% [parent frm][alignment '(center center)])) + (define (switch) + (send stop-button enable #f) + (send image-button enable #t)) + (define (stop) (send stop-button enable #f)) + (define-syntax-rule (btn l a y ...) + (new button% [parent p] [label l] [style '(border)] + [callback (lambda a y ...)])) + (define stop-button + (btn break-button:label (b e) (callback-stop! 'stop-images) (switch))) + (define image-button + (btn image-button:label (b e) + (parameterize ([current-custodian play-back-custodian]) + (thread (lambda () (play-back))) + (stop)))) + (send image-button enable #f) + (values switch stop)) + + (field [event-history '()]) ;; [Listof Evt] + ;; Symbol Any *-> Void + (define/private (add-event type . stuff) + (set! event-history (cons (cons type stuff) event-history))) + + ;; --- new callbacks --- + (define-syntax-rule (def/over-cb (pname name arg ...)) + (define/override (pname arg ...) + (when (super pname arg ...) (add-event name arg ...)))) + + (def/over-cb (ptock tick)) + (def/over-cb (pkey key e)) + (def/over-cb (pmouse mouse x y me)) + (def/over-cb (prec rec m)) + + ;; --> Void + ;; re-play the history of events; create a png per step; create animated gif + ;; effect: write to user-chosen directory + (define/private (play-back) + ;; World EventRecord -> World + (define (world-transition world fst) (apply (car fst) world (cdr fst))) + ;; --- creating images + (define total (+ (length event-history) 1)) + (define digt# (string-length (number->string total))) + (define imag# 0) + (define bmps '()) + ;; Image -> Void + (define (save-image img) + (define bm (make-object bitmap% width height)) + (define dc (make-object bitmap-dc% bm)) + (send dc clear) + (send img draw dc 0 0 0 0 width height 0 0 #f) + (set! imag# (+ imag# 1)) + (send bm save-file (format "i~a.png" (zero-fill imag# digt#)) 'png) + (set! bmps (cons bm bmps))) + ;; --- choose place + (define img:dir (get-directory "image directory:" #f (current-directory))) + (when img:dir + (parameterize ([current-directory img:dir]) + (define last + (foldr (lambda (event world) + (save-image (draw world)) + (show (text (format "~a/~a created" imag# total) 18 'red)) + (world-transition world event)) + world0 + event-history)) + (show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red)) + (create-animated-gif rate (reverse bmps)) + (show (draw last))))))) + +;; Number [Listof (-> bitmap)] -> Void +;; turn the list of thunks into animated gifs +;; effect: overwrite the ANIMATED-GIF-FILE (in current directory) +;; [Listof (-> bitmap)] -> Void +;; turn the list of thunks into animated gifs +;; effect: overwrite the ANIMATED-GIF-FILE (in current directory) +(define (create-animated-gif R bitmap-list) + (when (file-exists? ANIMATED-GIF-FILE) (delete-file ANIMATED-GIF-FILE)) + (write-animated-gif bitmap-list (if (> +inf.0 R 0) (number->integer R) 5) + ANIMATED-GIF-FILE + #:one-at-a-time? #t + #:loop? #f)) + +(define ANIMATED-GIF-FILE "i-animated.gif") diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss new file mode 100755 index 0000000000..33801da892 --- /dev/null +++ b/collects/2htdp/universe.ss @@ -0,0 +1,311 @@ +#lang scheme/gui + +#| TODO: + -- make window resizable :: why? +|# + +(require (for-syntax "private/syn-aux.ss") + "private/syn-aux-aux.ss" + "private/syn-aux.ss" + "private/check-aux.ss" + "private/image.ss" + "private/world.ss" + "private/universe.ss" + htdp/error + (rename-in lang/prim (first-order->higher-order f2h)) + (only-in mzlib/etc evcase)) + +(provide (all-from-out "private/image.ss")) + +(provide + sexp? ;; Any -> Boolean + scene? ;; Any -> Boolean + ) + +;; Spec = (on-tick Expr) +;; | (on-tick Expr Expr) +;; -- on-tick must specify a tick handler; it may specify a clock-tick rate + +(define-keywords AllSpec + [on-tick (function-with-arity + 1 + except + [(x rate) + #'(list (proc> 'on-tick (f2h x) 1) + (num> 'on-tick rate positive? "pos. number" "rate"))])]) + +; +; +; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ;;; ; ;; ; ;;;; +; ; ; ; ; ;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ;; ;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; +; ; ; ;;; ; ;; ;;;; +; +; +; + +(provide big-bang ;; : see below + make-package ;; World Sexp -> Package + package? ;; Any -> Boolean + run-movie ;; [Listof Image] -> true + + ;; A MouseEventType is one of: + ;; - 'button-down + ;; - 'button-up + ;; - 'drag + ;; - 'move + ;; - 'enter + ;; - 'leave + + mouse-event? ;; Any -> Boolean + mouse=? ;; MouseEventType MouseEventType -> Boolean + + ;; KeyEvent is one of: + ;; -- Char + ;; -- Symbol + + key-event? ;; Any -> Boolean + key=? ;; KeyEvent KeyEvent -> Boolean + + ;; IP : a string that points to a machine on the net + LOCALHOST ;; IP + ) + +(provide-higher-order-primitive + run-simulation (create-scene) ; (Number Number Number (Nat -> Scene) -> true) + ) + +;; Expr = (big-bang Expr WorldSpec ...) +;; WorldSpec = AllSpec +;; | (on-draw Expr) +;; | (on-draw Expr Expr Expr) +;; -- on-draw must specify a rendering function; it may specify canvas dimensions +;; | (on-key Expr) +;; -- on-key must specify a key event handler +;; | (on-mouse Expr) +;; -- on-mouse must specify a mouse event handler +;; | (stop-when Expr) +;; -- stop-when must specify a boolean-valued function +;; | (register Expr) +;; | (register Expr Expr) +;; -- register must specify the internet address of a host (including LOCALHOST) +;; -- it may specify a world's name +;; | (record? Expr) +;; -- should the session be recorded and turned into PNGs and an animated GIF +;; | (on-receive Expr) +;; -- on-receive must specify a receive handler + +(define-keywords WldSpec + [on-draw (function-with-arity + 1 + except + [(f width height) + #'(list (proc> 'on-draw (f2h f) 1) + (nat> 'on-draw width "width") + (nat> 'on-draw height "height"))])] + [on-mouse (function-with-arity 4)] + [on-key (function-with-arity 2)] + [on-receive (function-with-arity 2)] + [stop-when (function-with-arity 1)] + [register (lambda (tag) + (lambda (p) + (syntax-case p () + [(host) #`(ip> #,tag host)] + [(ip name) #`(list (ip> #,tag ip) (symbol> #,tag name))] + [_ (err tag p)])))] + [record? (lambda (tag) + (lambda (p) + (syntax-case p () + [(b) #`(bool> #,tag b)] + [_ (err tag p)])))]) + +(define-syntax (big-bang stx) + (syntax-case stx () + [(big-bang) (raise-syntax-error #f "bad world description" stx)] + [(big-bang w s ...) + (let* ([Spec (append AllSpec WldSpec)] + [kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))] + [rec? #'#f] + [spec (map (lambda (stx) + (syntax-case stx () + [(kw . E) + (and (identifier? #'kw) + (for/or ([n kwds]) (free-identifier=? #'kw n))) + (begin + (when (free-identifier=? #'kw #'record?) + (syntax-case #'E () + [(V) (set! rec? #'V)] + [_ (err 'record? stx)])) + (cons (syntax-e #'kw) (syntax E)))] + [_ (raise-syntax-error + 'big-bang "not a legal big-bang clause" stx)])) + (syntax->list (syntax (s ...))))] + ;; assert: all bind = (kw . E) and kw is constrained via Bind + [args (map (lambda (x) + (define kw (car x)) + (define co (assq kw Spec)) + (list kw ((cadr co) (cdr x)))) + spec)]) + #`(send (new (if #,rec? aworld% world%) [world0 w] #,@args) last))])) + + +; +; +; +; ; ; ; ; ;;; +; ; ; ; ; ; ; +; ; ; ; ; ; ; +; ; ; ;;; ; ;; ; ;;;; ; ; ; ; ; ; +; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ;; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; +; ; ; ;;; ; ;; ;;;; ; ; ;; ; ; ; +; +; +; + +(define (run-simulation f) + (check-proc 'run-simulation f 1 "first" "one argument") + (big-bang 1 (on-tick add1) (on-draw f))) + +(define (run-movie r m*) + (check-arg 'run-movie (positive? r) "positive number" "first" r) + (check-arg 'run-movie (list? m*) "list (of images)" "second" m*) + (for-each (lambda (m) (check-image 'run-movie m "first" "list of images")) m*) + (let* ([fst (car m*)] + [wdt (image-width fst)] + [hgt (image-height fst)]) + (big-bang + m* + (on-tick rest r) + (on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m)))) + (stop-when empty?)))) + +(define (mouse-event? a) + (pair? (member a '(button-down button-up drag move enter leave)))) + +(define (mouse=? k m) + (check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k) + (check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m) + (eq? k m)) + +(define (key-event? k) + (or (char? k) (symbol? k))) + +(define (key=? k m) + (check-arg 'key=? (key-event? k) 'KeyEvent "first" k) + (check-arg 'key=? (key-event? m) 'KeyEvent "second" m) + (eqv? k m)) + +(define LOCALHOST "127.0.0.1") + +;; ----------------------------------------------------------------------------- + +; +; +; +; ; ; ; +; ; ; ; +; ; ; +; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;; +; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;; ; ; ; ; ;;; ; ;;; ;;; +; +; +; + +(provide + ;; type World + world? ;; Any -> Boolean + world=? ;; World World -> Boolean + world1 ;; sample worlds + world2 + world3 + ;; type Bundle = (make-bundle Universe [Listof Mail]) + ;; type Mail = (make-mail World S-expression) + make-bundle ;; Universe [Listof Mail] -> Bundle + bundle? ;; is this a bundle? + make-mail ;; World S-expression -> Mail + mail? ;; is this a real mail? + universe ;; : see below + universe2 ;; (World World -> U) (U World Message) -> U + ) + +;; Expr = (universe Expr UniSpec) +;; UniSpec = AllSepc +;; | (on-new Expr) +;; -- on-new must specify a 'new world" handler; what happens when a world joins +;; | (on-msg Expr) +;; -- on-msg must specify a 'message' handler +;; | (on-disconnect Expr) +;; -- on-disconnect may specify a handler for the event that a world is leaving +;; | (to-string Expr) +;; -- to-string specifies how to render the universe as a string for display +;; 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)]) + +(define-syntax (universe stx) + (syntax-case stx () + [(universe) (raise-syntax-error #f "not a legal universe description" stx)] + [(universe u) (raise-syntax-error #f "not a legal universe description" stx)] + [(universe u bind ...) + (let* ([Spec (append AllSpec UniSpec)] + [kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))] + [spec (map (lambda (stx) + (syntax-case stx () + [(kw . E) + (and (identifier? #'kw) + (for/or ([n kwds]) (free-identifier=? #'kw n))) + (cons (syntax-e #'kw) (syntax E))] + [(kw E) + (and (identifier? #'kw) + (for/or ([n kwds]) (free-identifier=? #'kw n))) + (list (syntax-e #'kw) (syntax E))] + [_ (raise-syntax-error + 'universe "not a legal universe clause" stx)])) + (syntax->list (syntax (bind ...))))] + ;; assert: all bind = (kw . E) and kw is constrained via Bind + [args (map (lambda (x) + (define kw (car x)) + (define co (assq kw Spec)) + (list kw ((cadr co) (cdr x)))) + spec)] + [domain (map car args)]) + (cond + [(not (memq 'on-new domain)) + (raise-syntax-error #f "missing on-new clause" stx)] + [(not (memq 'on-msg domain)) + (raise-syntax-error #f "missing on-msg clause" stx)] + [else ; (and (memq #'on-new domain) (memq #'on-msg domain)) + #`(send (new universe% [universe0 u] #,@args) last)]))])) + +;; (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) + (cond + [(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))) \ No newline at end of file diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 486d2f4218..de17f770ea 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -662,11 +662,16 @@ data-class-names))))))))) (define (get-teachpack-from-user parent) - (define tp-dir (collection-path "teachpack" "htdp")) + (define tp-dirs (list (collection-path "teachpack" "htdp") + (collection-path "teachpack" "2htdp"))) (define columns 2) - (define tps (filter - (λ (x) (file-exists? (build-path tp-dir x))) - (directory-list tp-dir))) + (define tps (apply + append + (map (λ (tp-dir) + (filter + (λ (x) (file-exists? (build-path tp-dir x))) + (directory-list tp-dir))) + tp-dirs))) (define sort-order (λ (x y) (string<=? (path->string x) (path->string y)))) (define pre-installed-tps (sort tps sort-order)) (define dlg (new dialog% [parent parent] [label (string-constant drscheme)])) @@ -826,7 +831,7 @@ (define compiling-message (new message% [parent button-panel] [label ""] [stretchable-width #t])) (define-values (ok-button cancel-button) (gui-utils:ok/cancel-buttons button-panel - (λ (b e) + (λ (b e) (set! answer (figure-out-answer)) (send dlg show #f)) (λ (b e) @@ -837,9 +842,15 @@ (cond [(send pre-installed-lb get-selection) => - (λ (i) `(lib ,(send pre-installed-lb get-string i) - "teachpack" - "htdp"))] + (λ (i) + (define f (send pre-installed-lb get-string i)) + (cond + [(file-exists? (build-path (collection-path "teachpack" "htdp") f)) + `(lib ,f "teachpack" "htdp")] + [(file-exists? (build-path (collection-path "teachpack" "2htdp") f)) + `(lib ,f "teachpack" "2htdp")] + [else (error 'figuer-out-answer "argh: ~a ~a" + (collection-path "teachpack" "htdp") f)]))] [(send user-installed-lb get-selection) => (λ (i) `(lib ,(send user-installed-lb get-string i) diff --git a/collects/teachpack/2htdp/scribblings/balls.ss b/collects/teachpack/2htdp/scribblings/balls.ss new file mode 100644 index 0000000000..a0e3bda180 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/balls.ss @@ -0,0 +1,59 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname balls) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +(require (lib "world.ss" "htdp")) + +;; constants +(define height 50) +(define delta 80) +(define width (+ delta (* 2 height))) + +(define left (quotient height 2)) +(define right (+ height delta left)) + +;; World = (make-posn left Number) | (make-posn right Number) + +(define server (text "server" 11 'black)) +(define server* (overlay server (nw:rectangle (image-width server) (image-height server) 'outline 'black))) + +;; visual constants +(define bg + (place-image + (text "universe" 11 'green) + 60 0 + (place-image + server* + (+ height 15) 20 + (place-image + (text "left" 11 'blue) + 10 10 + (place-image + (text "right" 11 'red) + (+ height delta 10) 10 + (place-image + (nw:rectangle delta height 'solid 'white) + height 0 + (place-image + (nw:rectangle width height 'solid 'gray) + 0 0 + (empty-scene width height)))))))) + +(define ball (circle 3 'solid 'red)) + +;; World -> Scene +(define (draw w) + (place-image ball (posn-x w) (posn-y w) bg)) + + +;; World -> World +(define (tick w) + (local ((define y (posn-y w)) + (define x (posn-x w))) + (cond + [(> y 0) (make-posn x (- y 1))] + [(= x left) (make-posn right height)] + [(= x right) (make-posn left height)]))) + +(big-bang width height 1/66 (make-posn left height) true) +(on-redraw draw) +(on-tick-event tick) diff --git a/collects/teachpack/2htdp/scribblings/fsa.ss b/collects/teachpack/2htdp/scribblings/fsa.ss new file mode 100644 index 0000000000..6fd029e6a5 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/fsa.ss @@ -0,0 +1,59 @@ +#lang slideshow + +(require slideshow/pict) + +(define DELTA 40) +(define FT 12) + +; (fsa "unlock" "lock" "push" "tick") +(define (fsa L C O unlock lock push tick) + (define (make-state txt) + (define t (text txt '() FT)) + (define e (rounded-rectangle (+ 10 (pict-width t)) (+ 10 (pict-height t)))) + (cc-superimpose t e)) + + (define locked (make-state L)) + (define closed (make-state C)) + (define open (make-state O)) + + (define bg (rectangle (+ (pict-width locked) (* 2 DELTA)) + (+ (pict-height locked) + (pict-height closed) + (pict-height open) + (* 3 DELTA)))) + + (define width (pict-width bg)) + + (define (center base state y) + (define w (pict-width state)) + (define d (quotient (- width w) 2)) + (pin-over base d y state)) + + (define nx + (center + (center + (center + bg locked (/ DELTA 2)) + closed + (+ (/ DELTA 2) (pict-height locked) DELTA)) + open + (+ (/ DELTA 2) DELTA (pict-height locked) DELTA (pict-height closed)))) + + (define (add-labeled-arrow nx locked lb-find closed lt-find txt) + (define-values (x0 y0) (lb-find nx locked)) + (define-values (x1 y1) (lt-find nx closed)) + (define lbl (text txt '() (- FT 2))) + (define wlbl (pict-width lbl)) + (define hlbl (pict-height lbl)) + (define x (- x0 (/ wlbl 2))) + (define y (+ y0 (/ ( - y1 y0 hlbl) 2))) + (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl)) + + (define l1 (add-labeled-arrow nx locked lb-find closed lt-find unlock)) + (define l2 (add-labeled-arrow l1 closed lb-find open lt-find push)) + (define l3 (add-labeled-arrow l2 open rt-find closed rb-find tick)) + (define l4 (add-labeled-arrow l3 closed rt-find locked rb-find lock)) + l4) + +(fsa "locked" "closed" "open" "unlock" "lock" "push" "time") +(fsa "'locked" "'closed" "'open" "#\\u" "#\\l" "#\\space" "tick") \ No newline at end of file diff --git a/collects/teachpack/2htdp/scribblings/nuworld.ss b/collects/teachpack/2htdp/scribblings/nuworld.ss new file mode 100644 index 0000000000..56a536a350 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/nuworld.ss @@ -0,0 +1,119 @@ +#lang slideshow + +(require slideshow/pict mred/mred) + +(define DELTA 80) +(define FT 12) + +(define txt + '("(big-bang World_0" + " (on-draw render WIDTH HEIGHT)" + " (on-tick tock RATE)" + " (on-mouse click)" + " (on-key react))" + )) + +(define program + (apply vl-append (map (lambda (t) (text t '() (- FT 2))) txt))) + +(define Program + (cc-superimpose + (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program))) + program)) + +(define (make-state txt) + (define t (text txt '() FT)) + (define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))) + (cc-superimpose t e)) + +(define False (text "FALSE" '() FT)) +(define True (text "TRUE" '() FT)) +(define BOOL (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False)))) + +;; String Boolean -> Pict +(define (make-state0 txt b) + ;; create the basic state + (define t (text txt '() FT)) + (define s (if b + (cc-superimpose + (rounded-rectangle (+ 5 (pict-width t)) (+ (- DELTA 5) (pict-height t))) + t) + t)) + (define w + (cc-superimpose + s + (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))) + ;; add the boolean + (define bb (cc-superimpose (if b True False) BOOL)) + (define ar (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done")) + (define scene (text "Scene" '() FT)) + (define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene))))) + (define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render")) + br) + +(define (add-labeled-arrow nx locked lb-find closed lt-find txt) + (define-values (x0 y0) (lb-find nx locked)) + (define-values (x1 y1) (lt-find nx closed)) + (define lbl (text txt '() (- FT 2))) + (define wlbl (pict-width lbl)) + (define hlbl (pict-height lbl)) + (define x (- x0 (/ wlbl 2))) + (define y (+ y0 (/ ( - y1 y0 hlbl) 2))) + (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl)) + +(define (h-labeled-arrow t) + (define tock (text t '() (- FT 2))) + (define blk (blank (+ DELTA 4) 2)) + (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find))) + +(define arrows + (vc-append (h-labeled-arrow "tock") + (h-labeled-arrow "click") + (h-labeled-arrow "react"))) + +(define state0 (make-state0 "World_0" #f)) +(define state1 (make-state0 "World_1" #f)) +(define dots (cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT))) +(define state2 (make-state0 "World_N-1" #f)) +(define stateN (make-state0 "World_N" #t)) +(define states (list state0 arrows state1 arrows dots arrows state2 arrows stateN)) + +(define bg (blank (+ (apply + (map pict-width states)) + DELTA #;(* (length states) DELTA)) + (+ (pict-height state0) DELTA))) + +(define (center base state x) + (define w (pict-height state)) + (define d (quotient (- width w) 2)) + (pin-over base x d state)) + +(define width (pict-height bg)) + +(define x (* 1/2 DELTA)) +(define xx + (foldl (lambda (f ls s) + (define y (center s f x)) + (set! x (+ x ls)) + y) + bg + states + (map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states))) + +(define the-image (ct-superimpose xx Program)) + +(define image-bm + (make-object bitmap% + (inexact->exact (round (pict-width the-image))) + (inexact->exact (round (pict-height the-image))))) + +(send image-bm ok?) + +(define image-dc + (new bitmap-dc% [bitmap image-bm])) +(send image-dc clear) + +(draw-pict the-image image-dc 0.0 0.0) + +(send image-bm save-file "nuworld.png" 'png) + +the-image diff --git a/collects/teachpack/2htdp/scribblings/server2.ss b/collects/teachpack/2htdp/scribblings/server2.ss new file mode 100644 index 0000000000..427a7c22ed --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/server2.ss @@ -0,0 +1,181 @@ +#lang slideshow + +(require slideshow/pict) + +(define DELTA 80) +(define FT 12) + +(define initialize "register") +(define proc-msg "process") + +(define program + (apply vl-append (map (lambda (t) (text t '() (- FT 2))) + (list (format "(universe ~a ~a)" initialize proc-msg))))) + +(define Program + (cc-superimpose + (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program))) + program)) + +;; String Boolean -> Pict +(define (make-state0 txt b) + ;; create the basic state + (define t (text txt '() FT)) + (cc-superimpose t (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))) + +(define (add-labeled-arrow nx locked lb-find closed lt-find txt) + (define-values (x0 y0) (lb-find nx locked)) + (define-values (x1 y1) (lt-find nx closed)) + (define lbl (text txt '() (- FT 2))) + (define wlbl (pict-width lbl)) + (define hlbl (pict-height lbl)) + (define x (- x0 (/ wlbl 2))) + (define y (+ y0 (/ ( - y1 y0 hlbl) 2))) + (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl)) + +(define (h-labeled-arrow t) + (define tock (text t '() (- FT 2))) + (define blk (blank (+ DELTA 4) 2)) + (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find))) + +(define message (text "Message" '() FT)) +(define (make-Message) + (cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message))))) + +(define Message (vc-append (make-Message) (arrowhead 4 (* 1/2 pi)))) +(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message))) +(define MessageI (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message))) + +(define M (rb-superimpose Message (blank DELTA DELTA))) +(define K (rb-superimpose MessageK (blank DELTA DELTA))) +(define I (rb-superimpose MessageI (blank DELTA DELTA))) + +(define (make-arrows M lbl) + (define Tock (h-labeled-arrow lbl)) + (values Tock (vc-append (blank DELTA (/ DELTA 2)) Tock M))) + +(define-values (TockM arrowsR) (make-arrows M proc-msg)) +(define-values (TockK arrowsL) (make-arrows K proc-msg)) +(define-values (init arrows) (make-arrows I initialize)) + +(define state0 (make-state0 "Server_0" #f)) +(define state2 (make-state0 "Server_N-1" #f)) +(define Univrs (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "Universe" '() FT )))) +(define dots (vc-append + (blank (pict-width state2) (quotient (pict-height state2) 1)) + (text "..." '() FT) + (blank (pict-width state2) (* (pict-height state2))) + Univrs)) + +(define states (list arrows + state0 + arrowsL + dots + arrowsR + state2 + (h-labeled-arrow proc-msg))) + +(define bg (blank (+ (apply + (map pict-width states)) DELTA) (pict-height dots))) + +(define (center base state x) + (define w (pict-height state)) + (define d (quotient (- (pict-height bg) w) 2)) + (pin-over base x d state)) + +(define x (* 1/2 DELTA)) +(define xx + (foldl (lambda (f ls s) + (define y (center s f x)) + (set! x (+ x ls)) + y) + bg + states + (map pict-width states))) + +(define zz (ct-superimpose xx Program)) + +(require mred/mred) + +(define the-image + (lt-superimpose + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz MessageK)) + (define-values (tx ty) (ct-find zz MessageK)) + (define-values (ix iy) (ct-find zz MessageI)) + (define-values (jx jy) (cb-find zz MessageI)) + (define-values (sx sy) (lc-find zz Univrs)) + (define-values (tockx tocky) (lb-find zz TockK)) + (define-values (initx inity) (lb-find zz init)) + (define (add-curve rx ry) + (set! dcp (make-object dc-path%)) + (set! cx (max rx tx)) + (set! cy (min ry ty)) + (send dcp move-to tx ty) + (send dcp curve-to tx ty cx cy rx ry) + (send dc draw-path dcp)) + (define dcp (make-object dc-path%)) + ;; --- draw arc from Message to Server + (define cx (min sx mx)) + (define cy (max sy my)) + (send dc set-smoothing 'aligned) + (send dcp move-to mx my) + (send dcp curve-to mx my cx cy sx sy) + (send dc draw-path dcp) + (set! dcp (make-object dc-path%)) + (set! cx (min sx jx)) + (set! cy (max sy jy)) + (send dc set-smoothing 'aligned) + (send dcp move-to jx jy) + (send dcp curve-to jx jy cx cy sx sy) + (send dc draw-path dcp) +;; --- draw arc from Message to Receiver + (add-curve tockx tocky) + (set! tx ix) (set! ty iy) + (add-curve initx inity) + ;; --- + dc) + (pict-width zz) (pict-height zz)) + (lt-superimpose + zz + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz Message)) + (define-values (tx ty) (ct-find zz Message)) + (define-values (sx sy) (rc-find zz Univrs)) + (define-values (tockx tocky) (rb-find zz TockM)) + (define (add-curve rx ry) + (set! dcp (make-object dc-path%)) + (set! cx (min rx tx)) + (set! cy (min ry ty)) + (send dcp move-to tx ty) + (send dcp curve-to tx ty cx cy rx ry) + (send dc draw-path dcp)) + (define dcp (make-object dc-path%)) + ;; --- draw arc from Message to Server + (define cx (max sx mx)) + (define cy (max sy my)) + (send dc set-smoothing 'aligned) + (send dcp move-to mx my) + (send dcp curve-to mx my cx cy sx sy) + (send dc draw-path dcp) + ;; --- draw arc from Message to Receiver + (add-curve tockx tocky) + ;; --- + dc) + (pict-width zz) (pict-height zz))))) + +(define image-bm + (make-object bitmap% + (inexact->exact (round (pict-width the-image))) + (inexact->exact (round (pict-height the-image))))) + +(send image-bm ok?) + +(define image-dc + (new bitmap-dc% [bitmap image-bm])) +(send image-dc clear) + +(draw-pict the-image image-dc 0.0 0.0) + +(send image-bm save-file "server2.png" 'png) + +the-image \ No newline at end of file diff --git a/collects/teachpack/2htdp/scribblings/shared.ss b/collects/teachpack/2htdp/scribblings/shared.ss new file mode 100644 index 0000000000..8bdc62c027 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/shared.ss @@ -0,0 +1,10 @@ +#lang scheme/base + +(require scribble/manual) + +(provide teachpack) + +(define (teachpack tp . name) + (apply title #:tag tp + `(,@name ": " ,(filepath (format "~a.ss" tp)) + ,(index (format "~a teachpack" tp))))) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl new file mode 100644 index 0000000000..c95ddeabc8 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -0,0 +1,1536 @@ +#lang scribble/doc + +@(require scribble/manual "shared.ss" + (for-label scheme ; lang/htdp-beginner + (only-in lang/htdp-beginner check-expect) + "../universe.ss" + teachpack/htdp/image)) +@(require scribble/struct) + +@(define (table* . stuff) + ;; (list paragraph paragraph) *-> Table + (define (flow* x) (make-flow (list x))) + (make-blockquote 'blockquote + (list + (make-table (make-with-attributes 'boxed + '((cellspacing . "6"))) + ;list + (map (lambda (x) (map flow* x)) stuff) + #;(map flow* (map car stuff)) + #;(map flow* (map cadr stuff)))))) + +@; ----------------------------------------------------------------------------- + +@title{Worlds and the Universe} + +@author{Matthias Felleisen} + +This @tt{universe.ss} teachpack implements and provides the functionality + for creating interactive, graphical programs that consist of plain + mathematical functions. We refer to such programs as @deftech{world} + programs. In addition, world programs can also become a part of a + @deftech{universe}, a collection of worlds that can exchange messages. + +The purpose of this documentation is to give experienced Schemers and HtDP + teachers a concise overview for using the library. The first part of the + documentation focuses on @tech{world} programs. Section @secref["world-example"] + presents an illustration of how to design such programs for a simple + domain; it is suited for a novice who knows how to design conditional + functions for symbols. The second half of the documentation focuses on + @tech{universe} programs: how it is managed via a server, how @tech{world} + programs register with the server, etc. The last two sections show how to + design a simple universe of two communicating worlds. + +@emph{Note}: For a quick and educational introduction to just worlds, see + @link["http://www.ccs.neu.edu/home/matthias/HtDP/Prologue/book.html"]{How + to Design Programs, Second Edition: Prologue}. As of August 2008, we also + have a series of projects available as a small booklet on + @link["http://world.cs.brown.edu/"]{How to Design Worlds}. + +@declare-exporting["../universe.ss" #:use-sources (teachpack/htdp/image)] + +@; ----------------------------------------------------------------------------- + +@section[#:tag "basics"]{Basics} + +The teachpack assumes working knowledge of the basic image manipulation + primitives and supports several functions that require a special kind of + image, called a @deftech{scene}, , which are images whose pinholes are at + position @scheme[(0,0)]. For example, the teachpack displays only + @tech{scene}s in its canvas. + +@defproc[(scene? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @tech{scene}.} + +@defproc[(empty-scene [width natural-number/c] + [height natural-number/c]) + scene?]{ + creates a plain white, @scheme[width] x @scheme[height] @tech{scene}.} + +@defproc[(place-image [img image?] [x number?] [y number?] + [s scene?]) + scene?]{ + creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s]; + @scheme[(x,y)] are computer graphics coordinates, i.e., they count right and + down from the upper-left corner.} + +@; ----------------------------------------------------------------------------- +@section[#:tag "simulations"]{Simple Simulations} + +The simplest kind of animated @tech{world} program is a time-based + simulation, which is a series of scenes. The programmer's task is to + supply a function that creates a scene for each natural number. By handing + this function to the teachpack displays the simulation. + +@defproc[(run-simulation [create-image (-> natural-number/c scene)]) + true]{ + + opens a canvas and starts a clock that tick 28 times per second + seconds. Every time the clock ticks, drscheme applies + @scheme[create-image] to the number of ticks passed since this function + call. The results of these applications are displayed in the canvas. +} + +Example: +@schemeblock[ +(define (create-UFO-scene height) + (place-image UFO 50 height (empty-scene 100 100))) + +(define UFO + (overlay (circle 10 'solid 'green) + (rectangle 40 4 'solid 'green))) + +(run-simulation create-UFO-scene) +] + +@;----------------------------------------------------------------------------- +@section[#:tag "interactive"]{Interactions} + +The step from simulations to interactive programs is relatively + small. Roughly speaking, a simulation designates one function, + @emph{create-image}, as a handler for one kind of event: clock ticks. In + addition to clock ticks, @tech{world} programs can also deal with two + other kinds of events: keyboard events and mouse events. A keyboard event + is triggered when a computer user presses or releases a key on the + keyboard. Similarly, a mouse event is the movement of the mouse, a click + on a mouse button, the crossing of a boundary by a mouse movement, etc. + +Your program may deal with such events via the @emph{designation} of + @emph{handler} functions. Specifically, the teachpack provides for the + installation of three event handlers: @scheme[on-tick], @scheme[on-key], + and @scheme[on-mouse]. In addition, a @tech{world} program may specify a + @emph{draw} function, which is called every time your program should + visualize the current world, and a @emph{stop?} predicate, which is used + to determine when the @tech{world} program should shut down. + +Each handler function consumes the current state of the @tech{world} and + optionally a data representation of the event. It produces a new state of + the @tech{world}. + +The following picture provides an intuitive overview of the workings of a + @tech{world} program in the form of a state transition diagram. + +@image["nuworld.png"] + + The @scheme[big-bang] form installs @emph{World_0} as the initial + world. The handlers @emph{tock}, @emph{react}, and @emph{click} transform + one world into another one; each time an event is handled, @emph{done} is + used to check whether the world is final, in which case the program is + shut down; and finally, @emph{draw} renders each world as a scene, which + is then displayed on an external canvas. + +@deftech{World} : @scheme[any/c] The design of a world program demands that + you come up with a data definition of all possible states. We use + @tech{World} to refer to this collection of data, using a capital W to + distinguish it from the program. In principle, there are no constraints + on this data definition though it mustn't be an instance of the + @tech{Package} structure (see below). You can even keep it implicit, even + if this violates the Design Recipe. + +@defform/subs[#:id big-bang + #:literals + (on-tick on-draw on-key on-mouse on-receive + stop-when register record?) + (big-bang state-expr clause ...) + ([clause + (on-tick tick-expr) + (on-tick tick-expr rate-expr) + (on-key key-expr) + (on-mouse key-expr) + (on-draw draw-expr) + (on-draw draw-expr width-expr height-expr) + (stop-when stop-expr) + (record? boolean-expr) + (on-receive rec-expr) + (register IP-expr) + (register IP-expr name-expr) + ])]{ + + starts a @tech{world} program in the initial state specified with + @scheme[state-expr], which must of course evaluate to an element of + @tech{World}. Its behavior is specified via the handler functions + designated in the optional @scheme[spec] clauses, especially how the + @tech{world} program deals with clock ticks, with key events, with mouse + events, and eventually with messages from the universe; how it renders + itself as a scene; when the program must shut down; where to register the + world with a universe; and whether to record the stream of events. A world + specification may not contain more than one @scheme[on-tick], + @scheme[on-draw], or @scheme[register] clause.} + +@itemize[ + +@item{ +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{ + +tell DrScheme to call the @scheme[tick-expr] function on the current +world every time the clock ticks. The result of the call becomes the +current world. The clock ticks at the rate of 28 times per second.}} + +@item{ +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))] + [rate-expr natural-number/c])]{ +tell DrScheme to call the @scheme[tick-expr] function on the current +world every time the clock ticks. The result of the call becomes the +current world. The clock ticks at the rate of @scheme[rate-expr].}} + +@item{An @tech{KeyEvent} represents key board events, e.g., keys pressed or + released. + +@deftech{KeyEvent} : @scheme[(or/c char? symbol?)] + +A @tech{Char} is used to signal that the user has hit an alphanumeric + key. A @tech{Symbol} denotes arrow keys or special events: + +@itemize[ + +@item{@scheme['left] is the left arrow,} + +@item{@scheme['right] is the right arrow,} + +@item{@scheme['up] is the up arrow,} + +@item{@scheme['down] is the down arrow, and} + +@item{@scheme['release] is the event of releasing a key.} +] + +@defproc[(key-event? [x any]) boolean?]{ + determines whether @scheme[x] is a @tech{KeyEvent}} + +@defproc[(key=? [x key-event?][y key-event?]) boolean?]{ + compares two @tech{KeyEvent} for equality} + +@defform[(on-key + [change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{ + tell DrScheme to call @scheme[change-expr] function on the current world and a + @tech{KeyEvent} for every keystroke the user of the computer makes. The result + of the call becomes the current world. + + Here is a typical key-event handler: +@(begin +#reader scribble/comment-reader +(schemeblock +(define (change w a-key) + (cond + [(key=? a-key 'left) (world-go w -DELTA)] + [(key=? a-key 'right) (world-go w +DELTA)] + [(char? a-key) w] ;; to demonstrate order-free checking + [(key=? a-key 'up) (world-go w -DELTA)] + [(key=? a-key 'down) (world-go w +DELTA)] + [else w])) +)) + } + The omitted, auxiliary function @emph{world-go} is supposed to consume a + world and a number and produces a world. +} + +@item{ A @tech{MouseEvent} represents mouse events, e.g., mouse movements + or mouse clicks, by the computer's user. + +@deftech{MouseEvent} : @scheme[(one-of/c 'button-down 'button-up 'drag 'move 'enter 'leave)] + +All @tech{MouseEvent}s are represented via symbols: +@itemize[ + +@item{@scheme['button-down] + signals that the computer user has pushed a mouse button down;} +@item{@scheme['button-up] + signals that the computer user has let go of a mouse button;} +@item{@scheme['drag] + signals that the computer user is dragging the mouse;} +@item{@scheme['move] + signals that the computer user has moved the mouse;} +@item{@scheme['enter] + signals that the computer user has moved the mouse into the canvas area; and} +@item{@scheme['leave] + signals that the computer user has moved the mouse out of the canvas area.} +] + +@defproc[(mouse-event? [x any]) boolean?]{ + determines whether @scheme[x] is a @tech{KeyEvent}} + +@defproc[(key=? [x mouse-event?][y mouse-event?]) boolean?]{ + compares two @tech{KeyEvent} for equality} + +@defform[(on-mouse + [clack-expr + (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{World}))])]{ + tell DrScheme to call @scheme[clack-expr] on the current world, the current + @scheme[x] and @scheme[y] coordinates of the mouse, and and a + @tech{MouseEvent} for every (noticeable) action of the mouse by the + computer user. The result of the call becomes the current world. + + Note: the computer's software doesn't really notice every single movement + of the mouse (across the mouse pad). Instead it samples the movements and + signals most of them.} +} + +@item{ + +@defform[(on-draw + [render-expr (-> (unsyntax @tech{World}) scene?)])]{ + + tell DrScheme to call the function @scheme[render-expr] whenever the + canvas must be drawn. The external canvas is usually re-drawn after DrScheme has + dealt with an event. Its size is determined by the size of the first + generated @tech{scene}.} + +@defform[(on-draw + [render-expr (-> (unsyntax @tech{World}) scene?)] + [width-expr natural-number/c] + [height-expr natural-number/c])]{ + + tell DrScheme to use a @scheme[width-expr] by @scheme[height-expr] + canvas instead of one determine by the first generated @tech{scene}. +} +} + +@item{ + +@defform[(stop-when + [last-world? (-> (unsyntax @tech{World}) boolean?)])]{ + tell DrScheme to call the @scheme[last-world?] function whenever the canvas is + drawn. If this call produces @scheme[true], the world program is shut + down. Specifically, the clock is stopped; no more + tick events, @tech{KeyEvent}s, or @tech{MouseEvent}s are forwarded to + the respective handlers. +}} + +@item{ + +@defform[(record? + [boolean-expr boolean?])]{ + tell DrScheme to record all events and to enable a replay of the entire + interaction. The replay action also generates one png image per scene and + an animated gif for the entire sequence. +}} +] + +The following example shows that @scheme[(run-simulation create-UFO-scene)] is +a short-hand for three lines of code: + +@(begin +#reader scribble/comment-reader +@schemeblock[ +(define (create-UFO-scene height) + (place-image UFO 50 height (empty-scene 100 100))) + +(define UFO + (overlay (circle 10 'solid 'green) + (rectangle 40 4 'solid 'green))) + +;; (run-simulation create-UFO-scene) is short for: +(big-bang 0 + (on-tick add1) + (on-draw create-UFO-scene)) +]) + +Exercise: Add a condition for stopping the flight of the UFO when it +reaches the bottom. + +@; ----------------------------------------------------------------------------- +@section[#:tag "scenes-and-images"]{Scenes and Images} + +For the creation of scenes from the world, use the functions from +@secref["image"]. The teachpack adds the following two functions, which +are highly useful for creating scenes. + +@defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-filled Mode] [c Color]) image?]{ + creates a @scheme[width] by @scheme[height] rectangle, solid or outlined as specified by + @scheme[solid-or-filled] and colored according to @scheme[c], with a pinhole at the upper left + corner.} + +@defproc[(scene+line [s scene?][x0 number?][y0 number?][x1 number?][y1 number?][c Color]) scene?]{ + creates a scene by placing a line of color @scheme[c] from @scheme[(x0,y0)] to + @scheme[(x1,y1)] into @scheme[scene]; + @scheme[(x,y)] are computer graphics coordinates. + In contrast to the @scheme[add-line] function, @scheme[scene+line] cuts + off those portions of the line that go beyond the boundaries of + the given @scheme[s].} + +@; ----------------------------------------------------------------------------- +@section[#:tag "world-example"]{A First Sample World} + +This section uses a simple example to explain the design of worlds. The + first subsection introduces the sample domain, a door that closes + automatically. The second subsection is about the design of @tech{world} + programs in general, the remaining subsections implement a simulation of + the door. + +@subsection{Understanding a Door} + +Say we wish to design a @tech{world} program that simulates the working of + a door with an automatic door closer. If this kind of door is locked, you + can unlock it with a key. While this doesn't open the door per se, it is + now possible to do so. That is, an unlocked door is closed and pushing at + the door opens it. Once you have passed through the door and you let go, + the automatic door closer takes over and closes the door again. When a + door is closed, you can lock it again. + +Here is a diagram that translates our words into a graphical + representation: + +@image["door-real.png"] + +Like the picture of the general workings of a @tech{world} program, this + diagram displays a so-called "state machine". The three circled words are + the states that our informal description of the door identified: locked, + closed (and unlocked), and open. The arrows specify how the door can go + from one state into another. For example, when the door is open, the + automatic door closer shuts the door as time passes. This transition is + indicated by the arrow labeled "time passes." The other arrows represent + transitions in a similar manner: + +@itemize[ + +@item{"push" means a person pushes the door open (and let's go);} + +@item{"lock" refers to the act of inserting a key into the lock and turning +it to the locked position; and} + +@item{"unlock" is the opposite of "lock".} + +] + +@; ----------------------------------------------------------------------------- +@subsection{Hints on Designing Worlds} + +Simulating any dynamic behavior via a @tech{world} program demands two + different activities. First, we must tease out those portions of our + domain that change over time or in reaction to actions, and we must + develop a data representation @deftech{D} for this information. Keep in + mind that a good data definition makes it easy for readers to map data to + information in the real world and vice versa. For all others aspects of + the world, we use global constants, including graphical or visual + constants that are used in conjunction with the rendering operations. + +Second, we must translate the actions in our domain---the arrows in the + above diagram---into interactions with the computer that the universe + teachpack can deal with. Once we have decided to use the passing of time + for one aspect, key presses for another, and mouse movements for a third, + we must develop functions that map the current state of the + world---represented as data from @tech{D}---into the next state of the + world. Put differently, we have just created a wish list with three + handler functions that have the following general contract and purpose + statements: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; tick : @tech{D} -> @tech{D} +;; deal with the passing of time +(define (tick w) ...) + +;; click : @tech{D} @emph{Number} @emph{Number} @tech{MouseEvent} -> @tech{D} +;; deal with a mouse click at @emph{(x,y)} of kind @emph{me} +;; in the current world @emph{w} +(define (click w x y me) ...) + +;; control : @tech{D} @tech{KeyEvent} -> @tech{D} +;; deal with a key event (symbol, char) @emph{ke} +;; in the current world @emph{w} +(define (control w ke) ...) +)) + +That is, the contracts of the various handler designations dictate what the + contracts of our functions are, once we have defined how to represent the + domain with data in our chosen language. + +A typical program does not use all three of these functions. Furthermore, + the design of these functions provides only the top-level, initial design + goal. It often demands the design of many auxiliary functions. The + collection of all these functions is your @tech{world} program. + +@; ----------------------------------------------------------------------------- +@subsection{Simulating a Door: Data} + +Our first and immediate goal is to represent the world as data. In this + specific example, the world consists of our door and what changes about + the door is whether it is locked, unlocked but closed, or open. We use + three symbols to represent the three states: + +@deftech{SD} : state of door + +@(begin +#reader scribble/comment-reader +(schemeblock +;; The state of the door (SD) is one of: +;; -- @scheme['locked] +;; -- @scheme['closed] +;; -- @scheme['open] +)) + +Symbols are particularly well-suited here because they directly express + the state of the door. + +Now that we have a data definition, we must also decide which computer + interactions should model the various actions on the door. Our pictorial + representation of the door's states and transitions, specifically the + arrow from @tt{open} to @tt{closed} suggests the use of a function that + simulates time. For the other three arrows, we could use either keyboard + events or mouse clicks or both. Our solution uses three keystrokes: + @scheme[#\u] for unlocking the door, @scheme[#\l] for locking it, and + @scheme[#\space] for pushing it open. We can express these choices + graphically by translating the above state-machine diagram from the world + of information into the world of data. + +@table*[ @list[ @t{@image["door-sim.png"]} @t{@image["door-real.png"]}] ] + +For completeness, we have repeated the original diagram on the right so +that you can see which computer interaction corresponds to which domain +action. + +@; ----------------------------------------------------------------------------- +@subsection{Simulating a Door: Functions} + +Our analysis and data definition leaves us with three functions to design: + +@itemize[ + +@item{@emph{automatic-closer}, which closes the time during one tick;} + +@item{@emph{door-actions}, which manipulates the time in response to +pressing a key; and} + +@item{@emph{render}, which translates the current state of the door into +a visible scene.} + +] + +Let's start with @emph{automatic-closer}. Substituting @tech{SD} for +@tech{D} and @emph{automatic-closer} for @emph{tick}, we get its contract, +and it is easy to refine the purpose statement, too: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; automatic-closer : @tech{SD} -> @tech{SD} +;; closes an open door over the period of one tick +(define (automatic-closer state-of-door) ...) +)) + + Making up examples is trivial when the world can only be in one of three + states: + +@table*[ + @list[@t{ given state } @t{ desired state }] + @list[@t{ @scheme['locked] } @t{ @scheme['locked] }] + @list[@t{ @scheme['closed] } @t{ @scheme['closed] }] + @list[@t{ @scheme['open] } @t{ @scheme['closed] }] +] + +@(begin +#reader scribble/comment-reader +(schemeblock +;; automatic-closer : @tech{SD} -> @tech{SD} +;; closes an open door over the period of one tick + +(check-expect (automatic-closer 'locked) 'locked) +(check-expect (automatic-closer 'closed) 'closed) +(check-expect (automatic-closer 'open) 'closed) + +(define (automatic-closer state-of-door) ...) +)) + + The template step demands a conditional with three clauses: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (automatic-closer state-of-door) + (cond + [(symbol=? 'locked state-of-door) ...] + [(symbol=? 'closed state-of-door) ...] + [(symbol=? 'open state-of-door) ...])) +)) + + The examples basically dictate what the outcomes of the three cases must + be: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (automatic-closer state-of-door) + (cond + [(symbol=? 'locked state-of-door) 'locked] + [(symbol=? 'closed state-of-door) 'closed] + [(symbol=? 'open state-of-door) 'closed])) +)) + + Don't forget to run the example-tests. + +For the remaining three arrows of the diagram, we design a function that + reacts to the three chosen keyboard events. As mentioned, functions that + deal with keyboard events consume both a world and a keyevent: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; door-actions : @tech{SD} @tech{KeyEvent} -> @tech{SD} +;; key events simulate actions on the door +(define (door-actions s k) ...) +)) + +@table*[ + @list[@t{ given state } @t{ given keyevent } @t{ desired state }] + +@list[ @t{ @scheme['locked] } @t{ @scheme[#\u]} @t{@scheme['closed]}] +@list[ @t{ @scheme['closed] } @t{ @scheme[#\l]} @t{@scheme['locked]}] +@list[ @t{ @scheme['closed] } @t{ @scheme[#\space]} @t{@scheme['open] }] +@list[ @t{ @scheme['open] } @t{ --- } @t{@scheme['open] }]] + + The examples combine what the above picture shows and the choices we made + about mapping actions to keyboard events. + +From here, it is straightforward to turn this into a complete design: + +@schemeblock[ +(define (door-actions s k) + (cond + [(and (symbol=? 'locked s) (key=? #\u k)) 'closed] + [(and (symbol=? 'closed s) (key=? #\l k)) 'locked] + [(and (symbol=? 'closed s) (key=? #\space k)) 'open] + [else s])) + +(check-expect (door-actions 'locked #\u) 'closed) +(check-expect (door-actions 'closed #\l) 'locked) +(check-expect (door-actions 'closed #\space) 'open) +(check-expect (door-actions 'open 'any) 'open) +(check-expect (door-actions 'closed 'any) 'closed) +] + +Last but not least we need a function that renders the current state of the +world as a scene. For simplicity, let's just use a large text for this +purpose: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; render : @tech{SD} -> @tech{scene} +;; translate the current state of the door into a large text +(define (render s) + (text (symbol->string s) 40 'red)) + +(check-expect (render 'closed) (text "closed" 40 'red)) +)) + The function @scheme[symbol->string] translates a symbol into a string, + which is needed because @scheme[text] can deal only with the latter, not + the former. A look into the language documentation revealed that this + conversion function exists, and so we use it. + +Once everything is properly designed, it is time to @emph{run} the +program. In the case of the universe teachpack, this means we must specify +which function takes care of tick events, key events, and drawing: + +@schemeblock[ +(big-bang 'locked + (on-tick automatic-closer) + (on-key door-actions) + (on-draw render)) +] + +Now it's time for you to collect the pieces and run them in DrScheme to see +whether it all works. + +Exercise: Design a data representation that closes the door over two (or +three or more) clock ticks instead of one. + +@; ----------------------------------------------------------------------------- +@section[#:tag "world2"]{The World is not Enough} + +The library facilities covered so far are about designing individual + programs with interactive graphical user interfaces (simulations, + animations, games, etc.). In this section, we introduce capabilities for + designing a distributed program, which is really a number of programs that + coordinate their actions in some fashion. Each of the individual programs + may run on any computer in the world (as in our planet and the spacecrafts + that we sent out), as long as it is on the internet and as long as the + computer allows the program to send and receive messages (via TCP). We + call this arrangement a @tech{universe} and the program that coordinates + it all a @emph{universe server} or just @tech{server}. + +This section explains what messages are, how to send them from a + @tech{world} program, how to receive them, and how to connect a + @tech{world} program to a @tech{universe}. + +@; ----------------------------------------------------------------------------- + +@subsection{Messages} + +After a world program has become a part of a universe, it may send messages + and receive them. In terms of data, a message is just an + @tech{S-expression}. + +@deftech{S-expression} An S-expression is roughly a nested list of basic +data; to be precise, an S-expression is one of: + +@itemize[ + @item{a string,} + @item{a symbol,} + @item{a number,} + @item{a boolean,} + @item{a char, or} + @item{a list of S-expressions.} +] +Note the last clause includes @scheme[empty] of course. + +@defproc[(sexp? [x any/c]) boolean?]{ + determines whether @scheme[x] is an @tech{S-expression}.} + +@subsection{Sending Messages} + +Each world-producing callback in a world program---those for handling clock + tick events, keyboard events, and mouse events---may produce a + @tech{Package} in addition to just a @tech{World}. + +@deftech{Package} represents a pair consisting of a @tech{World} (state) + and a message from a @tech{world} program to the @tech{server}. Because + programs only send messages via @tech{Package}, the teachpack does not + provide the selectors for the structure, only the constructor and a + predicate. + +@defproc[(package? [x any/c]) boolean?]{ + determine whether @scheme[x] is a @deftech{Package}.} + +@defproc[(make-package [w any/c][m sexp?]) package?]{ + create a @tech{Package} from a @tech{World} and an @tech{S-expression}.} + +As mentioned, all event handlers may return @tech{World}s or @tech{Package}s; +here are the revised specifications: + +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{ +} + +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))] + [rate-expr natural-number/c])]{ +} + +@defform[(on-key + [change (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{ +} + +@defform[(on-mouse + [clack + (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) + (or/c (unsyntax @tech{World}) package?))])]{ +} + +If one of these event handlers produces a @tech{Package}, the content of the world + field becomes the next world and the message field specifies what the + world sends to the universe. This distinction also explains why the data + definition for @tech{World} may not include a @tech{Package}. + +@subsection{Connecting with the Universe} + +Messages are sent to the universe program, which runs on some computer in + the world. The next section is about constructs for creating such a universe + server. For now, we just need to know that it exists and that it is the recipient + of messages. + +@deftech{IP} @scheme[string?] + +Before a world program can send messages, it must register with the + server. Registration must specify the internet address of the computer on which + the server runs, also known as an @tech{IP} address or a host. Here a + @tech{IP} address is a string of the right shape, e.g., @scheme["192.168.1.1"] + or @scheme["www.google.com"]. + +@defthing[LOCALHOST string?]{the @tech{IP} of your computer. Use it while you + are developing a distributed program, especially while you are + investigating whether the participating world programs collaborate in an + appropriate manner. This is called @emph{integration testing} and differs + from unit testing quite a bit.} + +A @scheme[big-bang] description of a world program that wishes to communicate +with other programs must contain a @scheme[register] clause of one of the +following shapes: + +@itemize[ + +@item{ +@defform[(register [ip-expr string?])]{ + connect this world to a universe server at the specified @scheme[ip-expr] + address and set up capabilities for sending and receiving messages.} +} + +@item{ +@defform[(register [ip-expr string?] + [name-expr (or/c symbol? string?)])]{ + connect this world to a universe server @emph{under a specific} @scheme[name-expr].} +} + +] + +When a world program registers with a universe program and the universe program +stops working, the world program stops working, too. + +@subsection{Receiving Messages} + +Finally, the receipt of a message from the server is an event, just like + tick events, keyboard events, and mouse events. Dealing with the receipt of a + message works exactly like dealing with any other event. DrScheme + applies the event handler that the world program specifies; if there is no + clause, the message is discarded. + +The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handler + for message receipts. + +@defform[(on-receive + [receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{ + tell DrScheme to call @scheme[receive-expr] for every message receipt, on the current + @tech{World} and the received message. The result of the call becomes the current + @tech{World}. + + Because @scheme[receive-expr] is (or evaluates to) a world-transforming + function, it too can produce a @tech{Package} instead of just a + @tech{World}. If the result is a @tech{Package}, its message content is + sent to the @tech{server}.} + +The diagram below summarizes the extensions of this section in graphical form. + +@image["universe.png"] + +A registered world program may send a message to the universe server + at any time by returning a @tech{Package} from an event handler. The + message is transmitted to the server, which may forward it to some + other world program as given or in some massaged form. The arrival of a + message is just another event that a world program must deal with. Like + all other event handlers @emph{receive} accepts a @tech{World} and some + auxiliary arguments (a message in this case) and produces a + @tech{World} or a @tech{Package}. + +When messages are sent from any of the worlds to the universe or vice versa, + there is no need for the sender and receiver to synchronize. Indeed, a sender + may dispatch as many messages as needed without regard to whether the + receiver has processed them yet. The messages simply wait in queue until + the receiving @tech{server} or @tech{world} program take care of them. + +@; ----------------------------------------------------------------------------- + +@section[#:tag "universe-server"]{The Universe Server} + +A @deftech{server} is the central control program of a @tech{universe} and + deals with receiving and sending of messages between the world + programs that participate in the @tech{universe}. Like a @tech{world} + program, a server is a program that reacts to events, though to different + events. There are two primary kinds of events: when a new @tech{world} + program joins the @tech{universe} that the server controls and when a + @tech{world} sends a message. + +The teachpack provides a mechanism for designating event handlers for + servers that is quite similar to the mechanism for describing @tech{world} + programs. Depending on the designated event handlers, the server takes on + distinct roles: + +@itemize[ + +@item{A server may be a "pass through" channel between two worlds, in which case + it has no other function than to communicate whatever message it receives + from one world to the other, without any interference.} + +@item{A server may enforce a "back and forth" protocol, i.e., it may force two + (or more) worlds to engage in a civilized tit-for-tat exchange. Each + world is given a chance to send a message and must then wait + to get a reply before it sends anything again.} + +@item{A server may play the role of a special-purpose arbiter, e.g., the referee + or administrator of a game. It may check that each world "plays" by the rules, + and it administrate the resources of the game.} + +] + +As a matter of fact, a pass-through @tech{server} can become basically +invisible, making it appear as if all communication goes from peer +@tech{world} to peer in a @tech{universe}. + +This section first introduces some basic forms of data that the + @tech{server} uses to represent @tech{world}s and other matters. Second, + it explains how to describe a server program. + +@; ----------------------------------------------------------------------------- +@subsection{Worlds and Messages} + +Understanding the server's event handling functions demands three + concepts. + +@itemize[ + +@item{The @tech{server} and its event handlers must agree on a + data representation of the @tech{world}s that participate in the + universe. + +@defproc[(world? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @emph{world}. Because the universe server + represents worlds via structures that collect essential information about + the connections, the teachpack does not export any constructor or selector + functions on worlds.} + +@defproc[(world=? [u world?][v world?]) boolean?]{ + compares two @emph{world}s for equality.} + +@defthing[world1 world?]{a world for testing your programs} +@defthing[world2 world?]{another world for testing your programs} +@defthing[world3 world?]{and a third one} + +The three sample worlds are provided so that you can test your functions +for universe programs. For example: + +@schemeblock[ +(check-expect (world=? world1 world2) false) +(check-expect (world=? world2 world2) true) +] +} + +@item{A @emph{mail} represents a message from an event handler to a +world. The teachpack provides only a predicate and a constructor for these +structures: + +@defproc[(mail? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @emph{mail}.} + +@defproc[(make-mail [to world?] [content sexp?]) mail?]{ + creates a @emph{mail} from a @emph{world} and an @tech{S-expression}.} +} + +@item{Each event handler produces a @emph{bundle}, which is a structure +that contains the @tech{server}'s state and a list of mails to other +worlds. Again, the teachpack provides only the predicate and a constructor: + +@defproc[(bundle? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @emph{bundle}.} + +@defproc[(make-bundle [state any/c] [mails (listof mail?)]) bundle?]{ + creates a @emph{bundle} from a piece of data that represents a server + state and a list of mails.} + +} +] + +@; ----------------------------------------------------------------------------- +@subsection{Universe Descriptions} + +A @tech{server} keeps track of information about the @tech{universe} that + it manages. Of course, what kind of information it tracks and how it is + represented depends on the situation and the programmer, just as with + @tech{world} programs. + +@deftech{Universe} @scheme[any/c] represent the server's state For running +@tech{universe}s, the teachpack demands that you come up with a data +definition for (your state of the) @tech{server}. Any piece of data can +represent the state. We just assume that you introduce a data definition +for the possible states and that your transformation functions are designed +according to the design recipe for this data definition. + +The @tech{server} itself is created with a description that includes the + first state and a number of clauses that specify functions for dealing + with @tech{universe} events. + +@defform/subs[#:id universe + #:literals + (start stop max-worlds on-new on-msg on-tick + on-disconnect to-string) + (universe state-expr clause ...) + ([clause + (on-new new-expr) + (on-msg msg-expr) + (on-tick tick-expr) + (on-tick tick-expr rate-expr) + (on-disconnect dis-expr) + (to-string render-expr) + ])]{ + +creates a server with a given state, @scheme[state-expr]. The +behavior is specified via handler functions through mandatory and optional +@emph{clause}s. These functions govern how the server deals with the +registration of new worlds, how it disconnects worlds, how it sends +messages from one world to the rest of the registered worlds, and how it +renders its current state as a string.} + +A @scheme[universe] expression starts a server. Visually it opens + a console window on which you can see that worlds join, which messages are + received from which world, and which messages are sent to which world. For + convenience, the console also has two buttons: one for shutting down a + universe and another one for re-starting it. The latter functionality is + especially useful during the integration of the various pieces of a + distributed program. + + +Now it is possible to explain the clauses in a @scheme[universe] server +description. Two of them are mandatory: + +@itemize[ + +@item{ + @defform[(on-new + [new-expr (-> (unsyntax @tech{Universe}) world? + (cons (unsyntax @tech{Universe}) [listof mail?]))])]{ + tell DrScheme to call the function @scheme[new-expr] every time another world joins the + universe.}} + +@item{ + @defform[(on-msg + [msg-expr (-> (unsyntax @tech{Universe}) world? sexp? + (cons (unsyntax @tech{Universe}) [listof mail?]))])]{ + + tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world + that sent the message, and the message itself. The handler must produce a state of the + universe and a list of mails.} + } +] + +The following picture provides a graphical overview of the server's workings. + +@image["server2.png"] + +In addition to the mandatory handlers, a program may wish to add some +optional handlers: + +@itemize[ + +@item{ +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{ + tell DrScheme to apply @scheme[tick-expr] to the current state of the + universe. The handler is expected to produce a bundle of the new state of + the universe and a list of mails. + } + +@defform[(on-tick + [tick-expr (-> (unsyntax @tech{Universe}) bundle?)] + [rate-expr natural-number/c])]{ + tell DrScheme to apply @scheme[tick-expr] as above but use the specified + clock tick rate instead of the default. + } +} + +@item{ + @defform[(on-disconnect + [dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{ + tell DrScheme to invoke @scheme[dis-expr] every time a participating + @tech{world} drops its connection to the server. The first argument is the + current state of the universe; the second one is the world that got + disconnected. + } +} + +@item{ + @defform[(to-string + [render-expr (-> (unsyntax @tech{Universe}) string?)])]{ + tell DrScheme to render the state of the universe after each event and to + display this string in the universe console. + } +} + +] + +@; ----------------------------------------------------------------------------- +@section[#:tag "universe-sample"]{A First Sample Universe} + +This section uses a simple example to explain the design of a universe, + especially its server and some participating worlds. The first subsection + explains the example, the second introduces the general design plan for + such universes. The remaining sections present the full-fledged solution. + +@subsection{Two Ball Tossing Worlds} + +Say we want to represent a universe that consists of a number of worlds and + that gives each world a "turn" in a round-robin fashion. If a world is + given its turn, it displays a ball that ascends from the bottom of a + canvas to the top. It relinquishes its turn at that point and the server + gives the next world a turn. + +Here is an image that illustrates how this universe would work if two + worlds participated: + +@image["balls.gif"] + + The two @tech{world} programs could be located on two distinct computers + or on just one. A @tech{server} mediates between the two worlds, including + the initial start-up. + +@; ----------------------------------------------------------------------------- +@subsection{Hints on Designing Universes} + +The first step in designing a @tech{universe} is to understand the + coordination of the @tech{world}s from a global perspective. To some + extent, it is all about knowledge and the distribution of knowledge + throughout a system. We know that the @tech{universe} doesn't exist until + the server starts and the @tech{world}s are joining. Because of the nature + of computers and networks, however, we may assume little else. Our network + connections ensure that if some @tech{world} sends two messages in some + order, they arrive in the same order at the server. In contrast, it is + generally impossible to ensure whether one world joins before another or + whether a message from one world gets to the server before another world's + message gets there. It is therefore the designer's task to establish a + protocol that enforces a certain order onto a universe and this activity + is called @emph{protocol design}. + +From the perspective of the @tech{universe}, the design of a protocol is + about the design of data representations for tracking universe information + in the server and the participating worlds and the design of a data + representation for messages. As for the latter, we know that they must be + @tech{S-expression}s, but of course @tech{world} programs don't send all + kinds of @tech{S-expression}s. The data definitions for messages must + therefore select a subset of suitable @tech{S-expression}s. As for the + state of the server and the worlds, they must reflect how they currently + relate to the universe. Later, when we design their "local" behavior, we + may add more components to their state space. + +In summary, the first step of a protocol design is to introduce: + +@itemize[ + +@item{a data definition for the information about the universe that the +server tracks, call it @tech{Universe};} + +@item{a data definition for the world(s) about their current relationship +to the universe;} + +@item{data definitions for the messages that are sent from the server to +the worlds and vice versa. Let's call them @deftech{MsgS2W} for messages +from the server to the worlds and @deftech{MsgW2S} for the other direction; +in the most general case you may need one pair per world.} +] + +If all the worlds exhibit the same behavior over time, a single data +definition suffices for step 2. If they play different roles, we may need +one data definition per world. + +Of course, as you define these collections of data always keep in mind what +the pieces of data mean, what they represent from the universe's +perspective. + +The second step of a protocol design is to figure out which major + events---the addition of a world to the universe, the arrival of a message + at the server or at a world---to deal with and what they imply for the + exchange of messages. Conversely, when a server sends a message to a + world, this may have implications for both the state of the server and the + state of the world. A good tool for writing down these agreements is an + interaction diagram. + +(interaction diagrams: tbd) + +The design of the protocol, especially the data definitions, have direct +implications for the design of event handling functions. For example, in +the server we may wish to deal with two kinds of events: the joining of a +new world and the receipt of a message from one of the worlds. This +translates into the design of two functions with the following headers, + +@(begin +#reader scribble/comment-reader +(schemeblock +;; @tech{Universe} World -> (make-bundle @tech{Universe} [Listof mail?]) +;; create new @tech{Universe} when world w is joining the universe, +;; which is in state s; also send mails as needed +(define (add-world s w) ...) + +;; @tech{Universe} World MsgW2U -> (make-bundle @tech{Universe} [Listof mail?]) +;; create new @tech{Universe} when world w is sending message m +;; to universe in state s; also send mails as needed +(define (process s p m) ...) +)) + +Note how both functions return a bundle. + +Finally, we must also decide how the messages affect the states of the + worlds; which of their callback may send messages and when; and what to do + with the messages a world receives. Because this step is difficult to + explain in the abstract, we move on to the protocol design for the + universe of ball worlds. + +@; ----------------------------------------------------------------------------- +@subsection{Designing the Ball Universe} + +Running the ball @tech{universe} has a simple overall goal: to ensure that at any + point in time, one @tech{world} is active and all others are passive. The active + @tech{world} displays a moving ball, and the passive @tech{world}s should display + something, anything that indicates that it is some other @tech{world}'s turn. + +As for the server's state, it must obviously keep track of all @tech{world}s that + joined the @tech{universe}, and it must know which one is active and which ones + are passive. Of course, initially the @tech{universe} is empty, i.e., there are + no @tech{world}s and, at that point, the server has nothing to track. + +While there are many different useful ways of representing such a @tech{universe}, + we choose to introduce @tech{Universe} as a list of @tech{world}s, and we + interpret non-empty lists as those where the first @tech{world} is active and the + remainder are the passive @tech{world}s. As for the two possible events, +@itemize[ + +@item{it is natural to add new @tech{world}s to the end of the list; and} + +@item{it is natural to move an active @tech{world} that relinquishes its turn to +the end of the list, too.} +] + +The server should send messages to the first @tech{world} of its list as + long as it wishes this @tech{world} to remain active. In turn, it should + expect to receive messages only from this one active @tech{world} and no + other @tech{world}. The content of these two messages is nearly irrelevant + because a message from the server to a @tech{world} means that it is the + @tech{world}'s turn and a message from the @tech{world} to the server + means that the turn is over. Just so that we don't confuse ourselves, we + use two distinct symbols for these two messages: +@itemize[ +@item{A @defterm{GoMessage} is @scheme['it-is-your-turn].} +@item{A @defterm{StopMessage} is @scheme['done].} +] + +From the @tech{universe}'s perspective, each @tech{world} is in one of two states: +@itemize[ +@item{A passive @tech{world} is @emph{resting}. We use @scheme['resting] for this state.} +@item{An active @tech{world} is not resting. We delay choosing a representation +for this part of a @tech{world}'s state until we design its "local" behavior.} +] + It is also clear that an active @tech{world} may receive additional messages, + which it may ignore. When it is done with its turn, it will send a + message. + +@; ----------------------------------------------------------------------------- +@subsection{Designing the Ball Server} + +The preceding subsection dictates that our server program starts like this: + +@(begin +#reader scribble/comment-reader +[schemeblock +;; teachpack: universe.ss + +;; Universe is [Listof world?] +;; StopMessage is 'done. +;; GoMessage is 'it-is-your-turn. +]) + + The design of a protocol has immediate implications for the design of the + event handling functions of the server. Here we wish to deal with two + events: the appearance of a new world and the receipt of a message. Based + on our data definitions and based on the general contracts of the event + handling functions spelled out in this documentation, we get two functions + for our wish list: + +@(begin +#reader scribble/comment-reader +[schemeblock +;; Result is (make-bundle Universe (list (make-mail world? GoMessage))) + +;; Universe world? -> Result +;; add world w to the universe, when server is in state u +(define (add-world u w) ...) + +;; Universe world? StopMessage -> Result +;; world w sent message m when server is in state u +(define (switch u w m) ...) +]) + +Although we could have re-used the generic contracts from this +documentation, we also know from our protocol that our server sends a +message to exactly one world. For this reason, both functions return the +same kind of result: a bundle that contains the new state of the server +(@tech{Universe}) and a list that contains a single mail. These contracts +are just refinements of the generic ones. (A type-oriented programmer would +say that the contracts here are subtypes of the generic ones.) + +The second step of the design recipe calls for functional examples: + +@(begin +#reader scribble/comment-reader +[schemeblock +;; an obvious example for adding a world: +(check-expect + (add-world '() world1) + (make-bundle (list world1) + (list (make-mail world1 'it-is-your-turn)))) + +;; an example for receiving a message from the active world: +(check-expect + (switch (list world1 world2) world1 'it-is-your-turn) + (make-bundle (list world2 world1) + (list (make-mail world2 'it-is-your-turn)))) +]) + + Note that our protocol analysis dictates this behavior for the two + functions. Also note how we use @scheme[world1], @scheme[world2], and + @scheme[world3] because the teachpack applies these event handlers to real + worlds. + +Exercise: Create additional examples for the two functions based on our +protocol. + +The protocol tells us that @emph{add-world} just adds the given +@emph{world} structure---recall that this a data representation of the +actual @tech{world} program---to the @tech{Universe} and then sends a +message to the first world on this list to get things going: + +@(begin +#reader scribble/comment-reader +[schemeblock +(define (add-world univ wrld) + (local ((define univ* (append univ (list wrld)))) + (make-bundle univ* + (list (make-mail (first univ*) 'it-is-your-turn))))) +]) + +Because @emph{univ*} contains at least @emph{wrld}, it is acceptable to +create a mail to @scheme[(first univ*)]. Of course, this same reasoning +also implies that if @emph{univ} isn't empty, its first element is an +active world and has already received such a message. + +Similarly, the protocol says that when @emph{switch} is invoked because a + @tech{world} program sends a message, the data representation of the + corresponding world is moved to the end of the list and the next world on + the (resulting) list is sent a message: + +@(begin +#reader scribble/comment-reader +[schemeblock +(define (switch univ wrld m) + (local ((define univ* (append (rest univ) (list (first univ))))) + (make-bundle univ* (list (make-mail (first univ*) 'it-is-your-turn))))) +]) + + As before, appending the first world to the end of the list guarantees + that there is at least this one world on the next @tech{Universe} + (state). It is therefore acceptable to create a mail for this world. + +Exercise: The function definition simply assumes that @emph{wrld} is + @scheme[world=?] to @scheme[(first univ)] and that the received message + @emph{m} is @scheme['it-is-your-turn]. Modify the function definition so that it + checks these assumptions and raises an error signal if either of them is + wrong. Start with functional examples. If stuck, re-read the section on + checked functions from HtDP. (Note: in a @tech{universe} it is quite + possible that a program registers with a @tech{server} but fails to stick + to the agreed-upon protocol. How to deal with such situations properly + depends on the context. For now, stop the @tech{universe} at this point, + but consider alternative solutions, too.) + +@; ----------------------------------------------------------------------------- +@subsection{Designing the Ball World} + +The final step is to design the ball @tech{world}. Recall that each world + is in one of two possible states: active or passive. The second kind of + @tech{world} moves a ball upwards, decreasing the ball's @emph{y} + coordinate; the first kind of @tech{world} displays something that says + it's someone else's turn. Assuming the ball always moves along a vertical + line and that the vertical line is fixed, the state of the world is an + enumeration of two cases: + +@(begin #reader scribble/comment-reader +(schemeblock +;; teachpack: universe.ss + +;; World is one of +;; -- Number %% representing the @emph{y} coordinate +;; -- @scheme['resting] + +(define WORLD0 'resting) +)) + The definition says that initially a @tech{world} is passive. + +The communication protocol and the refined data definition of @tech{World} + imply a number of contract and purpose statements: + +@(begin +#reader scribble/comment-reader +(schemeblock + +;; World GoMessage -> World or (make-package World StopMessage) +;; make sure the ball is moving +(define (receive w n) ...) + +;; World -> World or (make-package World StopMessage) +;; move this ball upwards for each clock tick +;; or stay @scheme['resting] +(define (move w) ...) + +;; World -> Scene +;; render the world as a scene +(define (render w) ...) +)) + +Let's design one function at a time, starting with @emph{receive}. Since + the protocol doesn't spell out what @emph{receive} is to compute, let's + create a good set of functional examples, exploiting the structure of the + data organization of @tech{World}: + +@(begin +#reader scribble/comment-reader +(schemeblock +(check-expect (receive 'resting 'it-is-your-turn) HEIGHT) +(check-expect (receive (- HEIGHT 1) 'it-is-your-turn) ...) +)) + +Since there are two kinds of states, we make up at least two kinds of + examples: one for a @scheme['resting] state and another one for a numeric + state. The dots in the result part of the second unit test reveal the + first ambiguity; specifically it isn't clear what the result should be + when an active @tech{world} receives another message to activate itself. The + second ambiguity shows up when we study additional examples, which are + suggested by our approach to designing functions on numeric intervals + (HtDP, section 3). That is we should consider the following three inputs + to @emph{receive}: + +@itemize[ +@item{@scheme[HEIGHT] when the ball is at the bottom of the scene;} +@item{@scheme[(- HEIGHT 1)] when the ball is properly inside the scene; and} +@item{@scheme[0] when the ball has hit the top of the scene.} +] + + In the third case the function could produce three distinct results: + @scheme[0], @scheme['resting], or @scheme[(make-package 'resting + 'done)]. The first leaves things alone; the second turns the active @tech{world} + into a resting one; the third does so, too, and tells the universe about + this switch. + +We choose to design @emph{receive} so that it ignores the message and + returns the current state of an active @tech{world}. This ensures that the ball + moves in a continuous fashion and that the @tech{world} remains active. + +Exercise: One alternative design is to move the ball back to the bottom of +the scene every time @scheme['it-is-your-turn] is received. Design this function, too. + +@(begin +#reader scribble/comment-reader +(schemeblock + +(define (receive w m) + (cond + [(symbol=? 'resting w) HEIGHT] + [else w])) +)) + + Our second function to design is @emph{move}, the function that computes + the ball movement. We have the contract and the second step in the design + recipe calls for examples: + +@(begin +#reader scribble/comment-reader +(schemeblock +; World -> World or @scheme[(make-package 'resting 'done)] +; move the ball if it is flying + +(check-expect (move 'resting) 'resting) +(check-expect (move HEIGHT) (- HEIGHT 1)) +(check-expect (move (- HEIGHT 1)) (- HEIGHT 2)) +(check-expect (move 0) (make-package 'resting 'done)) + +(define (move x) ...) +)) + + Following HtDP again, the examples cover four typical situations: + @scheme['resting], two end points of the specified numeric interval, and + one interior point. They tell us that @emph{move} leaves a passive @tech{world} + alone and that it otherwise moves the ball until the @emph{y} coordinate + becomes @scheme[0]. In the latter case, the result is a package that + renders the @tech{world} passive and tells the server about it. + + Turning these thoughts into a complete definition is straightforward now: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (move x) + (cond + [(symbol? x) x] + [(number? x) (if (<= x 0) (make-package 'resting 'done) (sub1 x))])) +)) + + Exercise: what could happen if we had designed @emph{receive} so that it + produces @scheme['resting] when the state of the world is @scheme[0]? Use + your answer to explain why you think it is better to leave this kind of + state change to the tick event handler instead of the message receipt + handler? + +Finally, here is the third function, which renders the state as a scene: + +@(begin +#reader scribble/comment-reader +(schemeblock +; World -> Scene +; render the state of the world as a scene + +(check-expect (render HEIGHT) (place-image BALL 50 HEIGHT MT)) +(check-expect (render 'resting) + (place-image (text "resting" 11 'red) 10 10 MT)) + +(define (render name) + (place-image + (text name 11 'black) 5 85 + (cond + [(symbol? w) (place-image (text "resting" 11 'red) 10 10 MT)] + [(number? w) (place-image BALL 50 w MT)]))) + +)) + + Here is an improvement that adds a name to the scene and abstracts over + the name at the same time: + +@(begin +#reader scribble/comment-reader +(schemeblock +; String -> (World -> Scene) +; render the state of the world as a scene + +(check-expect + ((draw "Carl") 100) + (place-image (text "Carl" 11 'black) + 5 85 + (place-image BALL 50 100 MT))) + +(define (draw name) + (lambda (w) + (place-image + (text name 11 'black) 5 85 + (cond + [(symbol? w) (place-image (text "resting" 11 'red) 10 10 MT)] + [(number? w) (place-image BALL 50 w MT)])))) + +)) + + By doing so, we can use the same program to create many different + @tech{world}s that register with a @tech{server} on your computer: +@(begin +#reader scribble/comment-reader +(schemeblock + +; String -> World +; create and hook up a world with the @scheme[LOCALHOST] server +(define (create-world name) + (big-bang WORLD0 + (on-receive receive) + (on-draw (draw name)) + (on-tick move) + (register LOCALHOST name))) +)) + + Now you can use @scheme[(create-world 'carl)] and @scheme[(create-world 'same)], + respectively, to run two different worlds, after launching a @tech{server} + first. + +Exercise: Design a function that takes care of a world to which the + universe has lost its connection. Is @emph{Result} the proper contract for + the result of this function? + diff --git a/collects/teachpack/2htdp/scribblings/universe.ss b/collects/teachpack/2htdp/scribblings/universe.ss new file mode 100644 index 0000000000..f9c397e534 --- /dev/null +++ b/collects/teachpack/2htdp/scribblings/universe.ss @@ -0,0 +1,200 @@ +#lang slideshow + +(require slideshow/pict) + +(define DELTA 80) +(define FT 12) + +(define prgm + '("(big-bang World_0" + " (on-draw render WIDTH HEIGHT)" + " (on-tick tock RATE)" + " (on-mouse click)" + " (on-key react)" + " (on-receive receive)" + " (register LOCALHOST 'jimbob))")) + + +(define program + (apply vl-append (map (lambda (t) (text t '() (- FT 2))) prgm))) + +(define Program + (cc-superimpose + (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program))) + program)) + +(define (make-state txt) + (define t (text txt '() FT)) + (define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))) + (cc-superimpose t e)) + +(define False (text "FALSE" '() FT)) +(define True (text "TRUE" '() FT)) +(define BOOL (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False)))) + +;; String Boolean -> Pict +(define (make-state0 txt b) + ;; create the basic state + (define t (text txt '() FT)) + (define s (if b + (cc-superimpose + (rounded-rectangle (+ 5 (pict-width t)) (+ (- DELTA 5) (pict-height t))) + t) + t)) + (define w + (cc-superimpose + s + (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))) + ;; add the boolean + (define bb (cc-superimpose (if b True False) BOOL)) + (define ar (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done")) + (define scene (text "Scene" '() FT)) + (define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene))))) + (define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render")) + br) + +(define (add-labeled-arrow nx locked lb-find closed lt-find txt) + (define-values (x0 y0) (lb-find nx locked)) + (define-values (x1 y1) (lt-find nx closed)) + (define lbl (text txt '() (- FT 2))) + (define wlbl (pict-width lbl)) + (define hlbl (pict-height lbl)) + (define x (- x0 (/ wlbl 2))) + (define y (+ y0 (/ ( - y1 y0 hlbl) 2))) + (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl)) + +(define (h-labeled-arrow t) + (define tock (text t '() (- FT 2))) + (define blk (blank (+ DELTA 4) 2)) + (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find))) + +(define message (text "Message" '() FT)) +(define (make-Message) + (cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message))))) + +(define Message (vc-append (make-Message) (arrowhead 4 (* 1/2 pi)))) +(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message))) + +(define M (rb-superimpose Message (blank DELTA DELTA))) +(define K (rb-superimpose MessageK (blank DELTA DELTA))) + +(define (make-arrows M) + (define Tock (h-labeled-arrow "tock")) + (define Click (h-labeled-arrow "click")) + (define Clack (h-labeled-arrow "react")) + (define Receive (h-labeled-arrow "receive")) + (values Tock Click Clack Receive (vc-append (blank DELTA (/ DELTA 2)) Tock Click Clack Receive M))) + +(define-values (TockM ClickM ClackM ReceiveM arrowsR) (make-arrows M)) +(define-values (TockK ClickK ClackK ReceiveK arrowsL) (make-arrows K)) + +(define state0 (make-state0 "World_0" #f)) +(define state1 (make-state0 "World_1" #f)) +(define Server (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "SERVER" '() FT )))) +(define dots (vc-append + (cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT)) + Server)) +(define state2 (make-state0 "World_N-1" #f)) +(define stateN (make-state0 "World_N" #t)) +(define states (list state1 arrowsL dots arrowsR state2)) + +(define bg (blank (+ (apply + (map pict-width states)) DELTA) + (+ (pict-height state0) DELTA))) + +(define (center base state x) + (define w (pict-height state)) + (define d (quotient (- width w) 2)) + (pin-over base x d state)) + +(define width (pict-height bg)) + +(define x (* 1/2 DELTA)) +(define xx + (foldl (lambda (f ls s) + (define y (center s f x)) + (set! x (+ x ls)) + y) + bg + states + (map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states))) + +(define zz xx) + +(require mred/mred) + +(define the-image + (ct-superimpose Program + (lt-superimpose + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz MessageK)) + (define-values (tx ty) (ct-find zz MessageK)) + (define-values (sx sy) (lc-find zz Server)) + (define-values (tockx tocky) (lb-find zz TockK)) + (define-values (clickx clicky) (lb-find zz ClickK)) + (define-values (clackx clacky) (lb-find zz ClackK)) + (define-values (rx ry) (lb-find zz ReceiveK)) + (define (add-curve rx ry) + (set! dcp (make-object dc-path%)) + (set! cx (max rx tx)) + (set! cy (min ry ty)) + (send dcp move-to tx ty) + (send dcp curve-to tx ty cx cy rx ry) + (send dc draw-path dcp)) + (define dcp (make-object dc-path%)) + ;; --- draw arc from Message to Server + (define cx (min sx mx)) + (define cy (max sy my)) + (send dc set-smoothing 'aligned) + (send dcp move-to mx my) + (send dcp curve-to mx my cx cy sx sy) + (send dc draw-path dcp) + ;; --- draw arc from Message to Receiver + (add-curve tockx tocky) + (add-curve clickx clicky) + (add-curve clackx clacky) + (add-curve rx ry) + ;; --- + dc) + (pict-width zz) (pict-height zz)) + (lt-superimpose + zz + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz Message)) + (define-values (tx ty) (ct-find zz Message)) + (define-values (sx sy) (rc-find zz Server)) + (define-values (rx ry) (rb-find zz ReceiveM)) + (define dcp (make-object dc-path%)) + ;; --- draw arc from Message to Server + (define cx (max sx mx)) + (define cy (max sy my)) + (send dc set-smoothing 'aligned) + (send dcp move-to mx my) + (send dcp curve-to mx my cx cy sx sy) + (send dc draw-path dcp) + ;; --- draw arc from Message to Receiver + (set! dcp (make-object dc-path%)) + (set! cx (min rx tx)) + (set! cy (min ry ty)) + (send dcp move-to tx ty) + (send dcp curve-to tx ty cx cy rx ry) + (send dc draw-path dcp) + ;; --- + dc) + (pict-width zz) (pict-height zz)))))) + +(define image-bm + (make-object bitmap% + (inexact->exact (round (pict-width the-image))) + (inexact->exact (round (pict-height the-image))))) + +(send image-bm ok?) + +(define image-dc + (new bitmap-dc% [bitmap image-bm])) +(send image-dc clear) + +(draw-pict the-image image-dc 0.0 0.0) + +(send image-bm save-file "universe.png" 'png) + +the-image diff --git a/collects/teachpack/2htdp/universe.ss b/collects/teachpack/2htdp/universe.ss new file mode 100644 index 0000000000..34dd9d540e --- /dev/null +++ b/collects/teachpack/2htdp/universe.ss @@ -0,0 +1,3 @@ +(module universe mzscheme + (provide (all-from 2htdp/universe)) + (require 2htdp/universe)) diff --git a/collects/teachpack/balls.gif b/collects/teachpack/balls.gif new file mode 100644 index 0000000000..5f883d373d Binary files /dev/null and b/collects/teachpack/balls.gif differ diff --git a/collects/teachpack/nuworld.png b/collects/teachpack/nuworld.png new file mode 100644 index 0000000000..2b215663af Binary files /dev/null and b/collects/teachpack/nuworld.png differ diff --git a/collects/teachpack/server2.png b/collects/teachpack/server2.png new file mode 100644 index 0000000000..99f02cea21 Binary files /dev/null and b/collects/teachpack/server2.png differ diff --git a/collects/teachpack/universe.png b/collects/teachpack/universe.png new file mode 100644 index 0000000000..81cb2ef2db Binary files /dev/null and b/collects/teachpack/universe.png differ diff --git a/collects/teachpack/universe2.png b/collects/teachpack/universe2.png new file mode 100644 index 0000000000..8757563664 Binary files /dev/null and b/collects/teachpack/universe2.png differ