1#lang slideshow
2
3(define DELTA 80)
4(define FT 12)
5
6(define prgm
7  '("(universe UniState_0"
8    "  (on-new sign-up)"
9    "  (on-msg process)"
10    "  (on-dis disconnect)"
11    "  (on-tick tock)"
12    "  (to-string render))"))
13
14(define program
15  (apply vl-append (map (lambda (t) (text t '() (- FT 2))) prgm)))
16
17(define Program
18  (cc-superimpose
19   (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
20   program))
21
22(define (make-state txt)
23  (define t (text txt '() FT))
24  (define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))
25  (cc-superimpose t e))
26
27(define False (text "FALSE" '() FT))
28(define True  (text "TRUE"  '() FT))
29(define BOOL  (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False))))
30
31;; String Boolean -> Pict
32(define (make-state0 txt b)
33  ;; create the basic state
34  (define t (text txt '() FT))
35  (define s (if b
36                (cc-superimpose
37                 (rounded-rectangle (+ 5 (pict-width t))  (+ (- DELTA 5) (pict-height t)))
38                 t)
39                t))
40  (define w
41    (cc-superimpose
42     s
43     (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
44  ;; add the boolean
45  (define bb (cc-superimpose (if b True False) BOOL))
46  (define ar0 (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done"))
47  ;; HIDE the arrow and done
48  (define ar (cb-superimpose w (blank (pict-width ar0) (pict-height ar0))))
49  (define scene (text "string" '() FT))
50  (define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene)))))
51  (define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render"))
52  br)
53
54(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
55  (define-values (x0 y0) (lb-find nx locked))
56  (define-values (x1 y1) (lt-find nx closed))
57  (define lbl (text txt '() (- FT 2)))
58  (define wlbl (pict-width lbl))
59  (define hlbl (pict-height lbl))
60  (define x (- x0 (/ wlbl 2)))
61  (define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
62  (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
63
64(define (h-labeled-arrow t)
65  (define tock (text t '() (- FT 2)))
66  (define blk (blank (+ DELTA 4) 2))
67  (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find)))
68
69(define message (text "Message" '() FT))
70(define (make-Message)
71  (cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message)))))
72
73(define Message  (vc-append (make-Message) (arrowhead 4 (* 1/2 pi))))
74(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
75
76(define M (rb-superimpose Message (blank DELTA  DELTA)))
77(define K (rb-superimpose MessageK (blank DELTA  DELTA)))
78
79(define (make-arrows M)
80  (define Tock (h-labeled-arrow "sign-up"))
81  (define Click (h-labeled-arrow "tock"))
82  (define Clack (h-labeled-arrow "disconnect"))
83  (define Receive (h-labeled-arrow "process"))
84  (values Tock Click Clack Receive (vc-append (blank DELTA (/ DELTA 2)) Tock Click Clack Receive M)))
85
86(define-values (TockM ClickM ClackM ReceiveM arrowsR) (make-arrows M))
87(define-values (TockK ClickK ClackK ReceiveK arrowsL) (make-arrows K))
88
89(define state0 (make-state0 "UniState_0" #f))
90(define state1 (make-state0 "UniState_1" #f))
91(define Server (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "UNIVERSE" '() FT ))))
92(define world  (cc-superimpose (cloud 80 40) (text "world" '() FT )))
93(define dots   (vc-append
94                (cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT))
95                world
96                Server))
97(define state2 (make-state0 "UniState_N-1" #f))
98(define stateN (make-state0 "UniState_N" #t))
99(define states (list state1 arrowsL dots arrowsR state2))
100
101(define bg (blank (+ (apply + (map pict-width states)) DELTA)
102                  (+ (pict-height state0) DELTA)))
103
104(define (center base state x)
105  (define w (pict-height state))
106  (define d (quotient (round (- width w)) 2))
107  (pin-over base x d state))
108
109(define width (pict-height bg))
110
111(define x (* 1/2 DELTA))
112(define xx
113  (foldl (lambda (f ls s)
114           (define y (center s f x))
115           (set! x (+ x ls))
116           y)
117         bg
118         states
119         (map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states)))
120
121(define zz xx)
122
123(require mred/mred)
124
125(define the-image
126  (ct-superimpose Program
127                  (lt-superimpose
128                   (dc (lambda (dc x y)
129                         (define-values (mx my) (cb-find zz MessageK))
130                         (define-values (tx ty) (ct-find zz MessageK))
131                         (define-values (sx sy) (lc-find zz Server))
132                         (define-values (tockx tocky) (lb-find zz TockK))
133                         (define-values (clickx clicky) (lb-find zz ClickK))
134                         (define-values (clackx clacky) (lb-find zz ClackK))
135                         (define-values (rx ry) (lb-find zz ReceiveK))
136                         (define (add-curve rx ry)
137                           (set! dcp (make-object dc-path%))
138                           (set! cx (max rx tx))
139                           (set! cy (min ry ty))
140                           (send dcp move-to tx ty)
141                           (send dcp curve-to tx ty cx cy rx ry)
142                           (send dc draw-path dcp))
143                         (define dcp (make-object dc-path%))
144                         ;; --- draw arc from Message to Server
145                         (define cx (min sx mx))
146                         (define cy (max sy my))
147                         (send dc set-smoothing 'aligned)
148                         (send dcp move-to mx my)
149                         (send dcp curve-to mx my cx cy sx sy)
150                         (send dc draw-path dcp)
151                         ;; --- draw arc from Message to Receiver
152                         (add-curve tockx tocky)
153                         (add-curve clickx clicky)
154                         (add-curve clackx clacky)
155                         (add-curve rx ry)
156                         ;; ---
157                         dc)
158                       (pict-width zz) (pict-height zz))
159                   (lt-superimpose
160                    (lt-superimpose
161                     zz
162                     (dc (lambda (dc x y)
163                           (define-values (mx my) (cb-find zz world))
164                           (define-values (tx ty) (ct-find zz world))
165                           (define-values (sx sy) (rc-find zz Server))
166                           (define-values (rx ry) (rb-find zz ReceiveM))
167                           (define dcp (make-object dc-path%))
168                           ;; --- draw arc from Message to Server
169                           (define cx (max sx mx))
170                           (define cy (max sy my))
171#|
172                           (send dc set-smoothing 'aligned)
173                           (send dcp move-to mx my)
174                           (send dcp curve-to mx my cx cy sx sy)
175                           (send dc draw-path dcp)
176|#
177                           ;; --- draw arc from Message to Receiver
178                           (set! dcp (make-object dc-path%))
179                           (set! cx (min rx tx))
180                           (set! cy (min ry ty))
181                           (send dcp move-to tx ty)
182                           (send dcp curve-to tx ty cx cy rx ry)
183                           (send dc draw-path dcp)
184                           ;; ---
185                           dc)
186                         (pict-width zz) (pict-height zz)))
187                    (dc (lambda (dc x y)
188                          (define-values (mx my) (cb-find zz Message))
189                          (define-values (tx ty) (ct-find zz Message))
190                          (define-values (sx sy) (rc-find zz Server))
191                          (define-values (rx ry) (rb-find zz ReceiveM))
192                          (define dcp (make-object dc-path%))
193                          ;; --- draw arc from Message to Server
194                          (define cx (max sx mx))
195                          (define cy (max sy my))
196                          (send dc set-smoothing 'aligned)
197                          (send dcp move-to mx my)
198                          (send dcp curve-to mx my cx cy sx sy)
199                          (send dc draw-path dcp)
200                          ;; --- draw arc from Message to Receiver
201                          (set! dcp (make-object dc-path%))
202                          (set! cx (min rx tx))
203                          (set! cy (min ry ty))
204                          (send dcp move-to tx ty)
205                          (send dcp curve-to tx ty cx cy rx ry)
206                          (send dc draw-path dcp)
207                          ;; ---
208                          dc)
209                        (pict-width zz) (pict-height zz))))))
210
211(define image-bm
212  (make-object bitmap%
213    (inexact->exact (round (pict-width the-image)))
214    (inexact->exact (round (pict-height the-image)))))
215
216(send image-bm ok?)
217
218(define image-dc
219  (new bitmap-dc% [bitmap image-bm]))
220(send image-dc clear)
221
222(draw-pict the-image image-dc 0.0 0.0)
223
224(send image-bm save-file "server.png" 'png)
225
226the-image
227