diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index d16ed79e53..3547e2a548 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -1146,7 +1146,7 @@ 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 + @tech{S-expression}s, but usually @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 @@ -1164,8 +1164,8 @@ server tracks, call it @tech{UniverseState};} 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; +the worlds and vice versa. Let's call them @deftech{S2W} for messages +from the server to the worlds and @deftech{W2S} for the other direction; in the most general case you may need one pair per world.} ] @@ -1185,7 +1185,22 @@ The second step of a protocol design is to figure out which major state of the world. A good tool for writing down these agreements is an interaction diagram. -(interaction diagrams: tbd) + +@verbatim{ + + Server World1 World2 + | | | + | 'go | | + |<------------------| | + | 'go | | + |------------------------------------------>| + | | | + | | | +} + + Each vertical line is the life line of a @tech{world} program or the + @tech{server}. Each horizontal arrow denotes a message sent from one + @tech{universe} participant to another. The design of the protocol, especially the data definitions, have direct implications for the design of event handling functions. For example, in @@ -1196,19 +1211,20 @@ translates into the design of two functions with the following headers, @(begin #reader scribble/comment-reader (schemeblock -;; @tech{UniverseState} world? -> (make-bundle [Listof world?] @tech{UniverseState} [Listof mail?]) -;; create new @tech{UniverseState} when world w is joining the universe, -;; which is in state s; also send mails as needed +;; Bundle is +;; (make-bundle [Listof world?] UniverseState [Listof mail?]) + +;; [Listof world?] UniverseState world? -> Bundle +;; compute next list of worlds and new @tech{UniverseState} +;; when world w is joining the universe, which is in state s; (define (add-world s w) ...) -;; @tech{UniverseState} world? MsgW2U -> (make-bundle [Listof world?] @tech{UniverseState} [Listof mail?]) -;; create new @tech{UniverseState} when world w is sending message m -;; to universe in state s; also send mails as needed +;; [Listof world?] UniverseState world? W2U -> Bundle +;; compute next list of worlds and new @tech{UniverseState} +;; when world w is sending message m to universe in state s (define (process s p m) ...) )) -Note how both functions return a @emph{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 @@ -1228,10 +1244,14 @@ As for the server's state, it must obviously keep track of all @tech{world}s tha 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{UniverseState} 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, +While there are many different useful ways of representing such a + @tech{universe}, we just use the list of @emph{worlds} that is handed to + each handler and that handlers return via their bundles. The + @tech{UniverseState} itself is useless for this trivial example. 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} @@ -1263,6 +1283,34 @@ for this part of a @tech{world}'s state until we design its ``local'' behavior.} which it may ignore. When it is done with its turn, it will send a message. +@verbatim{ + Server + | World1 + |<==================| + | 'it-is-your-turn | + |------------------>| + | | World2 + |<==========================================| + | 'done | | + |<------------------| | + | 'it-is-your-turn | | + |------------------------------------------>| + | | | + | | | + | 'done | | + |<------------------------------------------| + | 'it-is-your-turn | | + |------------------>| | + | | | + | | | +} + +Here the double-lines (horizontal) denote the registration step, the others + are message exchanges. The diagram thus shows how the @tech{server} + decides to make the first registered world the active one and to enlist + all others as they join. + + @; ----------------------------------------------------------------------------- @subsection{Designing the Ball Server} @@ -1273,7 +1321,7 @@ The preceding subsection dictates that our server program starts like this: [schemeblock ;; teachpack: universe.ss -;; UniverseState is [Listof world?] +;; UniverseState is '* ;; StopMessage is 'done. ;; GoMessage is 'it-is-your-turn. ]) @@ -1289,24 +1337,22 @@ The preceding subsection dictates that our server program starts like this: #reader scribble/comment-reader [schemeblock ;; Result is -;; (make-bundle [Listof world?] UniverseState (list (make-mail world? GoMessage))) +;; (make-bundle [Listof world?] '* (list (make-mail world? GoMessage))) -;; UniverseState world? -> Result +;; [Listof world?] UniverseState world? -> Result ;; add world w to the universe, when server is in state u (define (add-world u w) ...) -;; UniverseState world? StopMessage -> Result +;; [Listof world?] UniverseState 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{UniverseState}) 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.) +message to exactly one world. Note how 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: @@ -1316,13 +1362,15 @@ The second step of the design recipe calls for functional examples: ;; an obvious example for adding a world: (check-expect (add-world '() '* world1) - (make-bundle (list 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) '* + (make-bundle (list world2 world1) + '* (list (make-mail world2 'it-is-your-turn)))) ]) @@ -1335,23 +1383,24 @@ 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{UniverseState} and then sends a -message to the first world on this list to get things going: + @emph{world} structure---recall that this a data representation of the + actual @tech{world} program---to the given list of worlds. It 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) +(define (add-world univ state wrld) (local ((define univ* (append univ (list wrld)))) - (make-bundle univ* '* + (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. +active world and is about to receive a second @scheme['it-is-your-turn] message. Similarly, the protocol says that when @emph{switch} is invoked because a @tech{world} program sends a message, the data representation of the @@ -1361,15 +1410,16 @@ Similarly, the protocol says that when @emph{switch} is invoked because a @(begin #reader scribble/comment-reader [schemeblock -(define (switch univ wrld m) +(define (switch univ state wrld m) (local ((define univ* (append (rest univ) (list (first univ))))) - (make-bundle 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{UniverseState} - (state). It is therefore acceptable to create a mail for this world. + that there is at least this one world on this list. 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 @@ -1382,6 +1432,12 @@ Exercise: The function definition simply assumes that @emph{wrld} is depends on the context. For now, stop the @tech{universe} at this point, but consider alternative solutions, too.) +Exercise: An alternative state representation would equate + @tech{UniverseState} with @emph{world} structures, keeping track of the + active world. The list of world in the server would track the passive + worlds only. Design appropriate @scheme[add-world] and @scheme[switch] + functions. + @; ----------------------------------------------------------------------------- @subsection{Designing the Ball World} diff --git a/collects/teachpack/balls.ss b/collects/teachpack/balls.ss new file mode 100644 index 0000000000..a0e3bda180 --- /dev/null +++ b/collects/teachpack/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/door.ss b/collects/teachpack/door.ss new file mode 100644 index 0000000000..6fd029e6a5 --- /dev/null +++ b/collects/teachpack/door.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/nuworld.ss b/collects/teachpack/nuworld.ss new file mode 100644 index 0000000000..cbda2823b6 --- /dev/null +++ b/collects/teachpack/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 "world.png" 'png) + +the-image diff --git a/collects/teachpack/server.ss b/collects/teachpack/server.ss new file mode 100644 index 0000000000..b8d3d790e4 --- /dev/null +++ b/collects/teachpack/server.ss @@ -0,0 +1,228 @@ +#lang slideshow + +(require slideshow/pict) + +(define DELTA 80) +(define FT 12) + +(define prgm + '("(universe UniState_0" + " (on-new register)" + " (on-msg process)" + " (on-dis disconnect)" + " (on-tick tock)" + " (to-string render))")) + +(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 ar0 (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done")) + ;; HIDE the arrow and done + (define ar (cb-superimpose w (blank (pict-width ar0) (pict-height ar0)))) + (define scene (text "string" '() 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 "register")) + (define Click (h-labeled-arrow "tock")) + (define Clack (h-labeled-arrow "disconnect")) + (define Receive (h-labeled-arrow "process")) + (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 "UniState_0" #f)) +(define state1 (make-state0 "UniState_1" #f)) +(define Server (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "UNIVERSE" '() FT )))) +(define world (cc-superimpose (cloud 80 40) (text "world" '() FT ))) +(define dots (vc-append + (cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT)) + world + Server)) +(define state2 (make-state0 "UniState_N-1" #f)) +(define stateN (make-state0 "UniState_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 + (lt-superimpose + zz + (dc (lambda (dc x y) + (define-values (mx my) (cb-find zz world)) + (define-values (tx ty) (ct-find zz world)) + (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))) + (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 "server.png" 'png) + +the-image diff --git a/collects/teachpack/server2.png b/collects/teachpack/server2.png deleted file mode 100644 index 99f02cea21..0000000000 Binary files a/collects/teachpack/server2.png and /dev/null differ diff --git a/collects/teachpack/universe2.png b/collects/teachpack/universe2.png deleted file mode 100644 index 8757563664..0000000000 Binary files a/collects/teachpack/universe2.png and /dev/null differ diff --git a/collects/teachpack/world.png b/collects/teachpack/world.png index 81cb2ef2db..2b215663af 100644 Binary files a/collects/teachpack/world.png and b/collects/teachpack/world.png differ diff --git a/collects/teachpack/world.ss b/collects/teachpack/world.ss new file mode 100644 index 0000000000..f9c397e534 --- /dev/null +++ b/collects/teachpack/world.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