229 lines
9.0 KiB
Scheme
229 lines
9.0 KiB
Scheme
#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 (round (- 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
|