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