svn: r13077
This commit is contained in:
Matthias Felleisen
parent
0b4a67fc21
commit
d871eeb91d
|
|
@ -1,59 +0,0 @@
|
|||
;; 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)
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
#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")
|
||||
|
|
@ -1,181 +0,0 @@
|
|||
#lang slideshow
|
||||
|
||||
(require slideshow/pict)
|
||||
|
||||
(define DELTA 80)
|
||||
(define FT 12)
|
||||
|
||||
(define initialize "register")
|
||||
(define proc-msg "process")
|
||||
|
||||
(define program
|
||||
(apply vl-append (map (lambda (t) (text t '() (- FT 2)))
|
||||
(list (format "(universe [on-new ~a] [on-msg ~a])" initialize proc-msg)))))
|
||||
|
||||
(define Program
|
||||
(cc-superimpose
|
||||
(rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
|
||||
program))
|
||||
|
||||
;; String Boolean -> Pict
|
||||
(define (make-state0 txt b)
|
||||
;; create the basic state
|
||||
(define t (text txt '() FT))
|
||||
(cc-superimpose t (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
|
||||
|
||||
(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 MessageI (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 I (rb-superimpose MessageI (blank DELTA DELTA)))
|
||||
|
||||
(define (make-arrows M lbl)
|
||||
(define Tock (h-labeled-arrow lbl))
|
||||
(values Tock (vc-append (blank DELTA (/ DELTA 2)) Tock M)))
|
||||
|
||||
(define-values (TockM arrowsR) (make-arrows M proc-msg))
|
||||
(define-values (TockK arrowsL) (make-arrows K proc-msg))
|
||||
(define-values (init arrows) (make-arrows I initialize))
|
||||
|
||||
(define state0 (make-state0 "Server_0" #f))
|
||||
(define state2 (make-state0 "Server_N-1" #f))
|
||||
(define Univrs (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "Universe" '() FT ))))
|
||||
(define dots (vc-append
|
||||
(blank (pict-width state2) (quotient (pict-height state2) 1))
|
||||
(text "..." '() FT)
|
||||
(blank (pict-width state2) (* (pict-height state2)))
|
||||
Univrs))
|
||||
|
||||
(define states (list arrows
|
||||
state0
|
||||
arrowsL
|
||||
dots
|
||||
arrowsR
|
||||
state2
|
||||
(h-labeled-arrow proc-msg)))
|
||||
|
||||
(define bg (blank (+ (apply + (map pict-width states)) DELTA) (pict-height dots)))
|
||||
|
||||
(define (center base state x)
|
||||
(define w (pict-height state))
|
||||
(define d (quotient (- (pict-height bg) w) 2))
|
||||
(pin-over base x d state))
|
||||
|
||||
(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 pict-width states)))
|
||||
|
||||
(define zz (ct-superimpose xx Program))
|
||||
|
||||
(require mred/mred)
|
||||
|
||||
(define the-image
|
||||
(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 (ix iy) (ct-find zz MessageI))
|
||||
(define-values (jx jy) (cb-find zz MessageI))
|
||||
(define-values (sx sy) (lc-find zz Univrs))
|
||||
(define-values (tockx tocky) (lb-find zz TockK))
|
||||
(define-values (initx inity) (lb-find zz init))
|
||||
(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)
|
||||
(set! dcp (make-object dc-path%))
|
||||
(set! cx (min sx jx))
|
||||
(set! cy (max sy jy))
|
||||
(send dc set-smoothing 'aligned)
|
||||
(send dcp move-to jx jy)
|
||||
(send dcp curve-to jx jy cx cy sx sy)
|
||||
(send dc draw-path dcp)
|
||||
;; --- draw arc from Message to Receiver
|
||||
(add-curve tockx tocky)
|
||||
(set! tx ix) (set! ty iy)
|
||||
(add-curve initx inity)
|
||||
;; ---
|
||||
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 Univrs))
|
||||
(define-values (tockx tocky) (rb-find zz TockM))
|
||||
(define (add-curve rx ry)
|
||||
(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))
|
||||
(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
|
||||
(add-curve tockx tocky)
|
||||
;; ---
|
||||
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 "server2.png" 'png)
|
||||
|
||||
the-image
|
||||
|
|
@ -1,200 +0,0 @@
|
|||
#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
|
||||
Loading…
Reference in New Issue
Block a user