svn: r13076

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))))
 ])
 
@@ -1336,22 +1384,23 @@ 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
+ 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}
 

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)

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")

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

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

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