suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added universe via a 2htdp teachpack

Browse Source 
svn: r12980
This commit is contained in:
Matthias Felleisen 2009-01-03 02:38:09 +00:00
parent b2d0a37f7b
commit f5714c2086
24 changed files with 3799 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

174
collects/2htdp/private/check-aux.ss Normal file
View File

@ -0,0 +1,174 @@
#lang scheme
(require htdp/image
htdp/error
(only-in lang/htdp-beginner image?))
(provide (all-defined-out))
(define INSET 5) ;; the space around the image in the canvas
(define RATE 1/30) ;; the clock tick rate
(define TRIES 3) ;; how many times should register try to connect to the server
(define PAUSE 1/2) ;; # secs to wait between attempts to connect to server
(define SQPORT 4567) ;; the port on which universe traffic flows
(define (K w . r) w)
(define (False w) #f)
;
;
;
; ;;; ;;;
; ; ; ; ;
; ; ; ; ;
; ; ;;; ;;;;; ;;;;; ;;; ;;;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;;
; ;;; ;;; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ;;
;
;
;
;; -----------------------------------------------------------------------------
;; Any -> Boolean
(define (scene? i)
(and (image? i) (internal-scene? i)))
;; Image -> Boolean
(define (internal-scene? i)
(and (= 0 (pinhole-x i)) (= 0 (pinhole-y i))))
;; Number -> Integer
(define (number->integer x)
(inexact->exact (floor x)))
;; -----------------------------------------------------------------------------
;; Nat Nat ->String
;; converts i to a string, adding leading zeros, make it at least as long as L
(define (zero-fill i L)
(let ([n (number->string i)])
(string-append (make-string (max (- L (string-length n)) 0) #\0) n)))
;; -----------------------------------------------------------------------------
;; MouseEvent -> [List Nat Nat MouseEventType]
;; turn a mouse event into its pieces
(define (mouse-event->parts e)
(define x (- (send e get-x) INSET))
(define y (- (send e get-y) INSET))
(list x y (cond [(send e button-down?) 'button-down]
[(send e button-up?) 'button-up]
[(send e dragging?) 'drag]
[(send e moving?) 'move]
[(send e entering?) 'enter]
[(send e leaving?) 'leave]
[else ; (send e get-event-type)
(error 'on-mouse-event
(format
"Unknown event type: ~a"
(send e get-event-type)))])))
;; -----------------------------------------------------------------------------
;; Any -> Symbol
(define (name-of draw tag)
(define fname (object-name draw))
(if fname fname tag))
;; -----------------------------------------------------------------------------
;; Any -> Boolean
(define (sexp? x)
(cond
[(empty? x) true]
[(string? x) true]
[(symbol? x) true]
[(number? x) true]
[(char? x) true]
[(pair? x) (and (list? x) (andmap sexp? x))]
[else false]))
(define (no-newline? x)
(not (member #\newline (string->list x))))
;; -----------------------------------------------------------------------------
;; exchange one-line messages between worlds and the server
(define tcp-eof (gensym 'tcp-eof))
;; Any -> Boolean
(define (tcp-eof? a) (eq? tcp-eof a))
;; OutPort Sexp -> Void
(define (tcp-send out msg)
(write msg out)
(newline out)
(flush-output out))
;; InPort -> Sexp
(define (tcp-receive in)
(with-handlers ((exn? (lambda (x) (raise tcp-eof))))
(define x (read in))
(if (eof-object? x)
(raise tcp-eof)
(begin
(read-line in) ;; read the newline
x))))
;
;
;
; ;;; ;;; ; ;
; ; ; ; ; ; ;
; ; ; ; ; ; ;
; ; ; ; ;; ;;;; ; ;;;; ; ;
; ;;;;; ;; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ;;;; ;;; ; ; ; ;
; ;
; ; ;
; ;;;
;; Symbol Any String -> Void
(define (check-pos t c r)
(check-arg
t (and (number? c) (> (number->integer c) 0)) "positive integer" r c))
;; Symbol Any String String *-> Void
(define (check-image tag i rank . other-message)
(if (and (pair? other-message) (string? (car other-message)))
(check-arg tag (image? i) (car other-message) rank i)
(check-arg tag (image? i) "image" rank i)))
;; Symbol Any String -> Void
(define (check-scene tag i rank)
(define error "image with pinhole at (~s,~s)")
(if (image? i)
(check-arg tag (internal-scene? i) "scene" rank (image-pins i))
(check-arg tag #f "scene" rank i)))
;; Symbol Any -> Void
(define (check-scene-result tname i)
(if (image? i)
(check-result tname internal-scene? "scene" i (image-pins i))
(check-result tname (lambda (x) (image? x)) "scene" i)))
(define (image-pins i)
(format "image with pinhole at (~s,~s)" (pinhole-x i) (pinhole-y i)))
;; Symbol Any String -> Void
(define (check-color tag width rank)
(check-arg tag (or (symbol? width) (string? width))
"color symbol or string" rank width))
;; Symbol (union Symbol String) Nat -> Void
(define (check-mode tag s rank)
(check-arg tag (or (eq? s 'solid)
(eq? s 'outline)
(string=? "solid" s)
(string=? "outline" s)) "mode (solid or outline)" rank s))

17
collects/2htdp/private/design.txt Normal file
View File

@ -0,0 +1,17 @@
Files for constructing universe.ss:
world.ss the old world
world% = (clock-mixin ...) -- the basic world
aworld% = (class world% ...) -- the world with recording
universe.ss the universe server
universe% = (clock-mixin ...) -- the basic universe
timer.ss the clock-mixin
check-aux.ss common primitives
image.ss the world image functions
syn-aux.ss syntactic auxiliaries
syn-aux-aux.ss auxiliaries to the syntactic auxiliaries

195
collects/2htdp/private/image.ss Normal file
View File

@ -0,0 +1,195 @@
#lang scheme
(require htdp/image
htdp/error
"check-aux.ss")
;
;
; ;;;;; ;;;;;
; ; ;
; ; ;
; ; ;;; ; ;;;; ;;;; ;;; ; ; ; ; ;; ;;;
; ; ; ;;; ; ; ; ; ; ; ;;;;; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;
; ;;;;; ; ; ; ;; ; ;; ; ;;;; ; ;; ; ; ; ;;;
; ;
; ;;;;
;
(provide (all-from-out htdp/image))
(provide
;; Scene is Image with pinhole in origin
nw:rectangle ;; Number Number Mode Color -> Image
place-image ;; Image Number Number Scene -> Scene
empty-scene ;; Number Number -> Scene
scene+line ;; Scene Number Number Number Number Color -> Scene
;; cut all pieces that are outside the given rectangle
)
(define (nw:rectangle width height mode color)
(check-pos 'rectangle width "first")
(check-pos 'rectangle height "second")
(check-mode 'rectangle mode "third")
(check-color 'rectangle color "fourth")
(put-pinhole (rectangle width height mode color) 0 0))
(define (place-image image x y scene)
(check-image 'place-image image "first")
(check-arg 'place-image (number? x) 'integer "second" x)
(check-arg 'place-image (number? y) 'integer "third" y)
(check-scene 'place-image scene "fourth")
(let ([x (number->integer x)]
[y (number->integer y)])
(place-image0 image x y scene)))
(define (empty-scene width height)
(check-pos 'empty-scene width "first")
(check-pos 'empty-scene height "second")
(put-pinhole
(overlay (rectangle width height 'solid 'white)
(rectangle width height 'outline 'black))
0 0))
(define (scene+line img x0 y0 x1 y1 c)
;; img and c are checked via calls to add-line from image.ss
(check-arg 'scene+line (scene? img) "scene" "first" "plain image")
(check-arg 'scene+line (number? x0) "number" "second" x0)
(check-arg 'scene+line (number? y0) "number" "third" y0)
(check-arg 'scene+line (number? x1) "number" "fourth" x1)
(check-arg 'scene+line (number? y1) "number" "fifth" y1)
(let ([x0 (number->integer x0)]
[x1 (number->integer x1)]
[y0 (number->integer y0)]
[y1 (number->integer y1)])
(add-line-to-scene0 img x0 y0 x1 y1 c)))
;; Image Number Number Image -> Image
(define (place-image0 image x y scene)
(define sw (image-width scene))
(define sh (image-height scene))
(define ns (overlay/xy scene x y image))
(define nw (image-width ns))
(define nh (image-height ns))
(if (and (= sw nw) (= sh nh)) ns (shrink ns 0 0 (- sw 1) (- sh 1))))
;; Image Number Number Number Number Color -> Image
(define (add-line-to-scene0 img x0 y0 x1 y1 c)
(define w (image-width img))
(define h (image-height img))
(cond
[(and (<= 0 x0) (< x0 w) (<= 0 x1) (< x1 w) (<= 0 y0) (< y0 w) (<= 0 y1) (< y1 w))
(add-line img x0 y0 x1 y1 c)]
[(= x0 x1) ;; vertical
(if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)]
[(= y0 y1) ;; horizontal
(if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)]
[else
(local ((define lin (points->line x0 y0 x1 y1))
(define dir (direction x0 y0 x1 y1))
(define-values (upp low lft rgt) (intersections lin w h))
(define (add x y) (add-line img x0 y0 x y c)))
(cond
[(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior
(case dir
[(upper-left) (if (number? upp) (add upp 0) (add 0 lft))]
[(lower-left) (if (number? low) (add low h) (add 0 lft))]
[(upper-right) (if (number? upp) (add upp 0) (add h rgt))]
[(lower-right) (if (number? low) (add low h) (add w rgt))]
[else (error 'dir "contract violation: ~e" dir)])]
[(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry!
(add-line-to-scene0 img x1 y1 x0 y0 c)]
[else
(cond
[(and (number? upp) (number? low)) (add-line img upp 0 low h c)]
[(and (number? upp) (number? lft)) (add-line img upp 0 0 lft c)]
[(and (number? upp) (number? rgt)) (add-line img upp 0 w rgt c)]
[(and (number? low) (number? lft)) (add-line img low h 0 lft c)]
[(and (number? low) (number? rgt)) (add-line img low h w rgt c)]
[(and (number? lft) (number? rgt)) (add-line img 0 lft w rgt c)]
[else img])]))]))
;; Nat Nat -> Nat
;; y if in [0,h], otherwise the closest boundary
(define (app y h)
(cond
[(and (<= 0 y) (< y h)) y]
[(< y 0) 0]
[else (- h 1)]))
;; Nat Nat Nat Nat -> (union 'upper-left 'upper-right 'lower-left 'lower-right)
;; how to get to (x1,y1) from (x0,y0)
(define (direction x0 y0 x1 y1)
(string->symbol
(string-append
(if (<= y0 y1) "lower" "upper") "-" (if (<= x0 x1) "right" "left"))))
#| TESTS
'direction
(equal? (direction 10 10 0 0) 'upper-left)
(equal? (direction 10 10 20 20) 'lower-right)
(equal? (direction 10 10 0 20) 'lower-left)
(equal? (direction 10 10 20 0) 'upper-right)
|#
;; -----------------------------------------------------------------------------
;; LINEs
;; Number Number -> LINE
;; create a line from a slope and the intersection with the y-axis
(define-struct lyne (slope y0))
;; Nat Nat Nat Nat -> LINE
;; determine the line function from the four points (or the attributes)
;; ASSUME: (not (= x0 x1))
(define (points->line x0 y0 x1 y1)
(local ((define slope (/ (- y1 y0) (- x1 x0))))
(make-lyne slope (- y0 (* slope x0)))))
;; LINE Number -> Number
(define (of ln x) (+ (* (lyne-slope ln) x) (lyne-y0 ln)))
;; LINE Nat Nat -> [Opt Number] [Opt Number] [Opt Number] [Opt Number]
;; where does the line intersect the rectangle [0,w] x [0,h]
;; (values UP LW LF RT) means the line intersects with
;; the rectangle [0,w] x [0,h] at (UP,0) or (LW,h) or (0,LF) or (w,RT)
;; when a field is false, the line doesn't interesect with that side
(define (intersections l w h)
(values
(opt (X l 0) w) (opt (X l h) w) (opt (lyne-y0 l) h) (opt (of l w) h)))
;; Number Number -> [Opt Number]
(define (opt z lft) (if (<= 0 z lft) z false))
;; LINE Number -> Number
;; the x0 where LINE crosses y(x) = h
;; assume: LINE is not a horizontal
(define (X ln h) (/ (- h (lyne-y0 ln)) (lyne-slope ln)))
;; --- TESTS ---
#|
(define line1 (points->line 0 0 100 100))
(= (of line1 0) 0)
(= (of line1 100) 100)
(= (of line1 50) 50)
(= (X (make-lyne 1 0) 0) 0)
(= (X (make-lyne 1 0) 100) 100)
(equal? (call-with-values
(lambda () (intersections (points->line -10 -10 110 110) 100 100))
list)
(list 0 100 0 100))
(equal? (call-with-values
(lambda () (intersections (points->line 0 10 100 80) 100 100))
list)
(list false false 10 80))
|#
;; -----------------------------------------------------------------------------
;
;

30
collects/2htdp/private/last.ss Normal file
View File

@ -0,0 +1,30 @@
#lang scheme/gui
(require "timer.ss")
(provide last-mixin)
(define last-mixin
(mixin (start-stop<%>) ()
(field [end:ch (make-channel)])
;; X -> Void
(define/override (stop! w)
(send-to-last w)
(super stop! w))
;; -> World
(define/public (last)
(define result (yield end:ch))
(if (exn? result) (raise result) result))
(field [dr:cust (current-custodian)])
;; X -> Void
;; send x to last method
(define/private (send-to-last x)
(parameterize ((current-custodian dr:cust))
(thread (lambda () (channel-put end:ch x)))))
(super-new)))

60
collects/2htdp/private/syn-aux-aux.ss Normal file
View File

@ -0,0 +1,60 @@
#lang scheme
(require htdp/error)
;
;
;
; ;;; ;;;
; ; ; ; ;
; ; ; ;
; ; ; ; ;;;; ; ; ; ; ; ;
; ;;; ; ; ; ; ;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;; ; ;
; ;;; ;;;; ; ; ; ; ;; ; ; ;
; ;
; ; ;
; ;;;
(provide nat> nat? proc> bool> num> ip> string> symbol>)
;; Any -> Boolean
(define (nat? x)
(and (number? x) (integer? x) (>= x 0)))
;; Symbol X -> X
(define (bool> tag x)
(check-arg tag (boolean? x) "boolean" "first" x)
x)
;; Symbol X -> X
(define (string> tag x)
(check-arg tag (string? x) "string" "first" x)
x)
(define ip> string>)
;; Symbol X -> X
(define (symbol> tag x)
(check-arg tag (symbol? x) "symbol" "second" x)
x)
;; Symbol X Nat -> X
(define (proc> tag f ar)
(check-proc tag f ar "first"
(if (> ar 1)
(format "~a arguments" ar)
"one argument"))
f)
;; Symbol X (Number -> Boolean) String String -> X
(define (num> tag x pred? spec which)
(check-arg tag (and (number? x) (pred? x)) spec which x)
x)
;; Symbol X String -> X
(define (nat> tag x spec)
(check-arg tag (nat? x) spec "natural number" x)
x)

43
collects/2htdp/private/syn-aux.ss Normal file
View File

@ -0,0 +1,43 @@
#lang scheme
(provide define-keywords function-with-arity except err check-flat-spec
(all-from-out "syn-aux-aux.ss"))
(require "syn-aux-aux.ss"
(for-template "syn-aux-aux.ss"
scheme
(rename-in lang/prim (first-order->higher-order f2h))))
(define-syntax-rule (define-keywords the-list (kw coerce) ...)
(begin
(provide kw ...)
(define-syntax (kw x)
(raise-syntax-error 'kw "used out of context" x))
...
(define-for-syntax the-list (list (list 'kw (coerce ''kw)) ...))))
(define-syntax function-with-arity
(syntax-rules (except)
[(_ arity)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(x) #`(proc> #,tag (f2h x) arity)]
[_ (err tag p)])))]
[(_ arity except extra)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(x) #`(proc> #,tag (f2h x) arity)]
extra
[_ (err tag p)])))]))
(define (err spec p)
(raise-syntax-error #f "illegal specification" #`(#,spec . #,p) p))
;; Symbol (Symbol X -> X) -> (X -> X)
(define (check-flat-spec tag coerce>)
(lambda (p)
(syntax-case p ()
[(b) #'(coerce> tag b)]
[_ (err tag p)])))

38
collects/2htdp/private/timer.ss Normal file
View File

@ -0,0 +1,38 @@
#lang scheme/gui
;; The module provides a timer mixing for world and universe.
;; The interface ensures that super class provides start and stop method,
;; plus a call back for clock ticks. The super-init call provides the
;; on-tick parameter, which the super-class uses to define the callback.
(require "check-aux.ss")
(provide clock-mixin start-stop<%>)
(define start-stop<%> (interface () start! ptock stop!))
;; T = (U (World -> World) (list (World -> World) Nat))
;; X [(list (World -> World) Nat) -> X] [(World -> World) -> X] -> [T -> X]
(define (selector default lchoice pchoice)
(lambda (on-tick)
(cond
[(cons? on-tick) (lchoice on-tick)]
[(procedure? on-tick) (pchoice on-tick)]
[else default])))
(define clock-mixin
(mixin (start-stop<%>) ()
(inherit ptock)
(init-field [on-tick #f])
(field [rate ((selector 0 second (lambda _ RATE)) on-tick)]
[timer (new timer% [notify-callback (lambda () (ptock))])])
(define/override (start!)
(unless (<= rate 0)
(send timer start (number->integer (* 1000 rate))))
(super start!))
(define/override (stop! w)
(send timer stop)
(super stop! w))
(super-new [tick ((selector void first (lambda (x) x)) on-tick)])))

363
collects/2htdp/private/universe.ss Normal file
View File

@ -0,0 +1,363 @@
#lang scheme/gui
(require (for-syntax "syn-aux.ss")
"check-aux.ss"
"timer.ss"
"last.ss"
scheme/match
htdp/error
(only-in mzlib/etc evcase)
string-constants)
(provide universe%)
;
;
;
; ; ; ;
; ; ; ;
; ; ;
; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;;
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ;;; ; ;;; ;;;
;
;
;
(define universe%
(last-mixin
(clock-mixin
(class* object% (start-stop<%>) (inspect #f) (super-new)
(init-field ;; type Result = (make-bundle Universe [Listof Mail])
universe0 ;; the initial state of the universe
on-new ;; Universe World -> Result
on-msg ;; Universe World Message -> Result
tick ;; Universe -> Result
(on-disconnect ;; Universe World -> Result
(lambda (u w) (list u)))
(to-string #f) ;; Universe -> String
)
(field [universe universe0])
;; -----------------------------------------------------------------------
;; dealing with events
(define-syntax-rule
;; A B ... -> Void
(def/cback pub (pname a ...)
;; Universe A B ... -> (cons Universe Mail)
;; effect: change server state, broadcast mails
name)
(begin
(pub pname)
(define (pname a ...)
(define (handler e) (stop! e))
(with-handlers ([exn? handler])
(define r (check-state-x-mail 'name (name universe a ...)))
(define u (bundle-state r))
(set! universe u)
(unless (boolean? to-string) (send gui add (to-string u)))
(broadcast (bundle-mails r))))))
(def/cback private (pmsg world received) on-msg)
(def/cback private (pdisconnect world) on-disconnect)
(def/cback private (pnew world) ppnew)
(define/private (ppnew uni p)
(world-send p 'okay)
(on-new uni p))
(def/cback public (ptock) tick)
;; Symbol Any -> Result
;; check that r is Result
;; effect: stop the server if the callbacks perform badly
(define/private (check-state-x-mail tag r)
(with-handlers ((exn? (lambda (x) (stop! x))))
(define s (format "expected from ~a, given: " tag))
(unless (bundle? r)
(error tag (format "(make-bundle Universe [Listof Mail]) ~a~e" s r)))
r))
;; -----------------------------------------------------------------------
;; start and stop server, start and stop the universe
(field [worlds '()] ;; [Listof World]
[gui (new gui%
[stop-server (lambda () (stop! universe))]
[stop-and-restart (lambda () (restart))])]
[dr:custodian (current-custodian)]
[the-custodian (make-custodian)])
;; start the universe, enable registrations and message exchanges
(define/public (start!)
(set! the-custodian (make-custodian))
(parameterize ([current-custodian the-custodian])
(define (loop)
(apply sync
(handle-evt (tcp-accept-evt tcp-listener) add-world)
(map world-wait-for-msg worlds)))
(define (add-world in-out)
(with-handlers ((tcp-eof? (lambda _ (loop))))
(define in (first in-out))
(define next (tcp-receive in))
(match next
[(cons 'REGISTER info)
(let* ([w (create-world in (second in-out) info)])
(set! worlds (cons w worlds))
(pnew w)
(send gui add (format "~a signed up" info))
(loop))]
[else (loop)])))
(define (world-wait-for-msg p)
(handle-evt (world-in p)
(lambda (in)
(with-handlers
((tcp-eof?
(lambda (e)
(handler p e
(lambda ()
(if (null? worlds)
(restart)
(loop)))))))
(define r (tcp-receive in))
(send gui add (format "~a ->: ~a" (world-name p) r))
(pmsg p r)
(loop)))))
(define tcp-listener
(with-handlers ((exn:fail:network? (lambda (x) (stop! x))))
(tcp-listen SQPORT 4 #t)))
;; --- go universe go ---
(set! worlds '())
(set! universe universe0)
(send gui add "a new universe is up and running")
(thread loop)))
;; World Exn (-> X) -> X
(define/private (handler p e cont)
(close-output-port (world-out p))
(close-input-port (world-in p))
(send gui add (format "~a !! closed port" (world-name p)))
(set! worlds (remq p worlds))
(pdisconnect p)
(cont))
;; [Listof Mail] -> Void
;; send payload of messages to designated worlds
(define/private (broadcast lm)
;;; --- why the heck is there no exception handler -------------
(for-each (lambda (p+m)
;; what exception should I catch
;; remove the world from the list
;; factor out from elsewhere
;; can this mean I perform a callback during a callback?
;; collect 'bad' worlds instead and disconnect them later?
;; (handler
(with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n"))))
(define w (mail-to p+m))
(define n (world-name w))
(define p (mail-content p+m))
(unless (memq w worlds)
(send gui add (format "~s not on list" n)))
(when (memq w worlds)
(world-send w p)
(send gui add (format "-> ~a: ~a" n p)))))
lm))
(define/private (restart)
;; I am running in a custodian that is about to be killed,
;; so let's switch to one up in the hierarchy
(let ([old-t (current-thread)]
[go (make-semaphore)])
(parameterize ([current-custodian dr:custodian])
(thread (lambda ()
(sync old-t go)
(start!))))
(send gui add "stopping the universe")
(send gui add "----------------------------------")
(for-each (lambda (w)
(close-input-port (world-in w))
(close-output-port (world-out w)))
worlds)
(custodian-shutdown-all the-custodian)
(semaphore-post go)))
(define/public (stop! msg)
(send gui show #f)
(custodian-shutdown-all the-custodian))
;; -----------------------------------------------------------------------
;; initialize the universe and run
(send gui show #t)
(start!)))))
;
;
;
; ; ; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ; ;;; ; ;; ; ;;;; ;;;
; ; ; ; ; ;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;;
; ;; ;; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ;;; ; ;; ;;;; ;;;
;
;
;
(provide
world? ;; Any -> Boolean
world=? ;; World World -> Boolean
world1 ;; sample worlds
world2
world3)
;; --- the server representation of a world ---
(define-struct world (in out name info) #:transparent)
;; World = (make-world IPort OPort Symbol [Listof Sexp])
(define world1 (make-world (current-input-port) (current-output-port) 'sk '()))
(define world2 (make-world (current-input-port) (current-output-port) 'mf '()))
(define world3 (make-world (current-input-port) (current-output-port) 'rf '()))
(define (world=? u v)
(check-arg 'world=? (world? u) 'world "first" u)
(check-arg 'world=? (world? v) 'world "second" v)
(eq? u v))
;; IPort OPort Sexp -> Player
(define (create-world i o info)
(if (and (pair? info) (symbol? (car info)))
(make-world i o (car info) (cdr info))
(make-world i o (gensym 'world) info)))
;; Player S-exp -> Void
(define (world-send p sexp)
(tcp-send (world-out p) sexp))
;
;
;
; ;;; ; ; ;
; ; ; ; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ;; ; ; ;
; ; ; ; ; ;
; ; ; ; ; ;
; ; ; ; ; ;
; ;;; ;;; ;
;
;
;
;; effect: create and show a gui with two buttons and an editor for logging
(define gui%
(class frame%
(init stop-server stop-and-restart)
(inherit show)
(define/augment (on-close) (end))
(super-new [label "Universe"][width 500][height 300][style '(metal)])
(field
[end (lambda _ (show #f) (stop-server))]
[panel (new horizontal-panel% [parent this] [stretchable-height #f]
[alignment '(center center)])]
[stop (new button% [parent panel] [label "stop"] [callback end])]
[s&re (new button% [parent panel] [label "stop and restart"]
[callback (lambda (but evt) (stop-and-restart))])]
[text (new text%)]
[edit (new editor-canvas% [parent this] [editor text]
[style '(no-border combo no-hscroll auto-vscroll)])])
;; add lines to the end of the text
(define/public (add str)
(queue-callback
(lambda ()
(send text lock #f)
(send text insert (format "~a\n" str) (send text last-position))
(send text lock #t))))
;; -------------------------------------------------------------------------
;; add menu, lock, and show
(copy-and-paste this)
(send text lock #t)))
;; -----------------------------------------------------------------------------
;; Frame Text -> Void
;; add menu bar to frame for copying all of the text
(require string-constants)
(define (copy-and-paste frame)
(define mb (new menu-bar% [parent frame]))
(define edit (new menu%
[label (string-constant edit-menu-label)]
[parent mb]))
(new menu-item%
[label (string-constant copy-menu-item)]
[parent edit]
[shortcut #\c]
[callback (lambda (m e)
(define t (send frame get-focus-object))
(when (is-a? t editor<%>)
(send t copy)))])
(new menu-item%
[label (string-constant select-all-menu-item)]
[parent edit]
[shortcut #\a]
[callback (lambda (m e)
(define t (send frame get-focus-object))
(when (is-a? t text%)
(send t set-position 0 (send t last-position))))])
(void))
;
;
; ;;; ;;; ; ;;
; ;; ;; ;
; ;; ;; ;;; ;;; ;
; ; ; ; ; ; ; ;
; ; ; ; ;;;; ; ;
; ; ; ; ; ; ;
; ; ; ; ; ; ;
; ;;; ;;; ;;;;; ;;;;; ;;;;;
;
;
;
;
(provide
;; type Bundle = (make-bundle Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
)
(define-struct bundle (state mails) #:transparent)
(set! make-bundle
(let ([make-bundle make-bundle])
(lambda (state mails)
(check-arg 'make-bundle (list? mails) "list [of mails]" "second" mails)
(for-each (lambda (c)
(check-arg 'make-bundle (mail? c) "mail" "(elements of) second" c))
mails)
(make-bundle state mails))))
(define-struct mail (to content) #:transparent)
(set! make-mail
(let ([make-mail make-mail])
(lambda (to content)
(check-arg 'make-mail (world? to) 'world "first" to)
(check-arg 'make-mail (sexp? content) 'S-expression "second" content)
(make-mail to content))))

382
collects/2htdp/private/world.ss Normal file
View File

@ -0,0 +1,382 @@
#lang scheme/gui
(require "check-aux.ss"
"timer.ss"
"last.ss"
htdp/image
htdp/error
mzlib/runtime-path
mrlib/bitmap-label
string-constants
mrlib/gif)
(provide world% aworld%)
;
;
;
; ; ; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ; ;;; ; ;; ; ;;;;
; ; ; ; ; ;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ;; ;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;
; ; ; ;;; ; ;; ;;;;
;
;
;
;; -----------------------------------------------------------------------------
;; packages for broadcasting information to the universe
(define-struct package (world message) #:transparent)
;; World Sexp -> Package
(define (create-package w m)
(check-arg 'make-package (sexp? m) 'sexp "second" m)
(make-package w m))
(provide
(rename-out (create-package make-package)) ;; World S-expression -> Package
package? ;; Any -> Package
)
(define world%
(last-mixin
(clock-mixin
(class* object% (start-stop<%>)
(inspect #f)
(init-field
world0 ;; World
(tick K)) ;; (U (World -> World) (list (World -> World) Nat))
(init
(on-key K) ;; World KeyEvent -> World
(on-mouse K) ;; World Nat Nat MouseEvent -> World
(on-receive #f) ;; (U #f (World S-expression -> World))
(on-draw #f) ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
(stop-when False) ;; World -> Boolean
(record? #f) ;; Boolean
(register #f)) ;; (U #f String (list String Symbol))
;; -----------------------------------------------------------------------
(field (world world0))
;; (U World Package) -> Boolean
;; does the new world differ from the old?
;; effect: if so, set world
(define/private (set-world new-world)
(when (package? new-world)
(broadcast (package-message new-world))
(set! new-world (package-world new-world)))
(if (equal? world new-world)
#t
(begin
(set! world new-world)
#f)))
;; -----------------------------------------------------------------------
(field [*out* #f] ;; (U #f OutputPort), where to send messages to
[*rec* (make-custodian)] ;; Custodian, monitor traffic
[host (cond
[(string? register) register]
[(pair? register) (car register)]
[else register])]
[name (cond
[(string? register) (gensym 'world)]
[(pair? register) (second register)]
[else register])])
(define/private (register-with-host)
(define FMTtry "unable to register with ~a after ~s tries")
(define FMTcom "unable to register with ~a due to protocol problems")
;; try to register with the server n times
(define (register n)
(printf "trying to register with ~a ...\n" host)
(with-handlers ((tcp-eof?
(lambda (x)
(error 'register FMTcom host)))
(exn:fail:network?
(lambda (x)
(if (= n 1)
(error 'register FMTtry host TRIES)
(begin (sleep PAUSE)
(register (- n 1)))))))
(define-values (in out) (tcp-connect host SQPORT))
(tcp-send out `(REGISTER ,(if name name (gensym 'world))))
(if (eq? (tcp-receive in) 'okay)
(values in out)
(raise tcp-eof))))
;; --- now register, obtain connection, and spawn a thread for receiving
(parameterize ([current-custodian *rec*])
(define-values (in out) (register TRIES))
(define dis (text "the universe disappeared" 11 'red))
(define (RECEIVE)
(sync
(handle-evt
in
(lambda (in)
(with-handlers ((tcp-eof? (compose (handler #f)
(lambda (e)
(set! draw (lambda (w) dis))
(pdraw)
e))))
;; --- "the universe disconnected" should come from here ---
(define msg (tcp-receive in))
(cond
[(sexp? msg) (prec msg) (RECEIVE)] ;; break loop if EOF
[#t (error 'RECEIVE "sexp expected, received: ~e" msg)]))))))
(printf "... successful registered and ready to receive\n")
(set! *out* out)
(thread RECEIVE)))
(define/private (broadcast msg)
(when *out*
(check-result 'send sexp? "Sexp expected; given ~e\n" msg)
(tcp-send *out* msg)))
;; -----------------------------------------------------------------------
(field
(draw (cond
[(procedure? on-draw) on-draw]
[(pair? on-draw) (first on-draw)]
[else on-draw]))
(live (not (boolean? draw)))
(width (if (pair? on-draw) (second on-draw) #f))
(height (if (pair? on-draw) (third on-draw) #f)))
;; the visible world
(field [enable-images-button void] ;; used if stop-when call produces #t
[disable-images-button void]
[visible (new pasteboard%)])
(define (show-canvas)
(send visible set-cursor (make-object cursor% 'arrow))
(let ([fst-scene (ppdraw)])
(set! width (if width width (image-width fst-scene)))
(set! height (if height height (image-height fst-scene)))
(create-frame)
(show fst-scene)))
;; effect: create, show and set the-frame
(define/pubment (create-frame)
(define play-back:cust (make-custodian))
(define frame (new (class frame%
(super-new)
(define/augment (on-close)
(callback-stop! 'frame-stop)
(custodian-shutdown-all play-back:cust)))
(label (if name (format "~a's World" name) "World"))
(stretchable-width #f)
(stretchable-height #f)
(style '(no-resize-border metal))))
(define editor-canvas
(new (class editor-canvas%
(super-new)
;; deal with keyboard events
(define/override (on-char e)
(when live (pkey (send e get-key-code))))
;; deal with mouse events if live and within range
(define/override (on-event e)
(define l (mouse-event->parts e))
(when live
(when (and (<= 0 (first l) width) (<= 0 (second l) height))
(pmouse . l)))))
(parent frame)
(editor visible)
(style '(no-hscroll no-vscroll))
(horizontal-inset INSET)
(vertical-inset INSET)))
(send editor-canvas min-client-width (+ width INSET INSET))
(send editor-canvas min-client-height (+ height INSET INSET))
(set!-values (enable-images-button disable-images-button)
(inner (values void void) create-frame frame play-back:cust))
(send editor-canvas focus)
(send frame show #t))
;; Image -> Void
;; show the image in the visible world
(define/public (show pict)
(send visible begin-edit-sequence)
(send visible lock #f)
(let ([s (send visible find-first-snip)]
[c (send visible get-canvas)])
(when s (send visible delete s))
(send visible insert (send pict copy) 0 0))
(send visible lock #t)
(send visible end-edit-sequence))
;; -----------------------------------------------------------------------
;; callbacks
(field
(key on-key)
(mouse on-mouse)
(rec on-receive))
(define-syntax-rule (def/pub-cback (name arg ...) transform)
;; Any ... -> Boolean
(define/public (name arg ...)
(queue-callback
(lambda ()
(with-handlers ([exn:break? (handler #f)][exn? (handler #t)])
(define changed-world? (set-world (transform world arg ...)))
(unless changed-world?
(when draw (pdraw))
(when (pstop)
(callback-stop! 'name)
(enable-images-button)))
changed-world?)))))
;; tick, tock : deal with a tick event for this world
(def/pub-cback (ptock) tick)
;; key events
(def/pub-cback (pkey ke) key)
;; mouse events
(def/pub-cback (pmouse x y me) mouse)
;; receive revents
(def/pub-cback (prec msg) rec)
;; -----------------------------------------------------------------------
;; draw : render this world
(define/private (pdraw) (show (ppdraw)))
(define/private (ppdraw)
(check-scene-result (name-of draw 'your-draw) (draw world)))
;; -----------------------------------------------------------------------
;; stop-when
(field [stop stop-when])
(define/private (pstop)
(define result (stop world))
(check-result (name-of stop 'your-stop-when) boolean? "boolean" result)
result)
;; -----------------------------------------------------------------------
;; start & stop
(define/public (callback-stop! msg)
(stop! world))
(define (handler re-raise)
(lambda (e)
(disable-images-button)
(stop! (if re-raise e world))))
(define/public (start!)
(when draw (show-canvas))
(when host (register-with-host)))
(define/public (stop! w)
(set! live #f)
(custodian-shutdown-all *rec*))
;; -------------------------------------------------------------------------
;; initialize the world and run
(super-new)
(start!)))))
;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png"))
(define break-button:label
((bitmap-label-maker (string-constant break-button-label) break-btn:path) '_))
(define-runtime-path image-button:path '(lib "icons/file.gif"))
(define image-button:label ((bitmap-label-maker "Images" image-button:path) '_))
(define aworld%
(class world% (super-new)
(inherit-field world0 tick key mouse rec draw rate width height)
(inherit show callback-stop!)
;; Frame Custodian -> (-> Void)
;; adds the stop animation and image creation button,
;; whose callbacks runs as a thread in the custodian
;; provide a function for switching button enabling
(define/augment (create-frame frm play-back-custodian)
(define p (new horizontal-pane% [parent frm][alignment '(center center)]))
(define (switch)
(send stop-button enable #f)
(send image-button enable #t))
(define (stop) (send stop-button enable #f))
(define-syntax-rule (btn l a y ...)
(new button% [parent p] [label l] [style '(border)]
[callback (lambda a y ...)]))
(define stop-button
(btn break-button:label (b e) (callback-stop! 'stop-images) (switch)))
(define image-button
(btn image-button:label (b e)
(parameterize ([current-custodian play-back-custodian])
(thread (lambda () (play-back)))
(stop))))
(send image-button enable #f)
(values switch stop))
(field [event-history '()]) ;; [Listof Evt]
;; Symbol Any *-> Void
(define/private (add-event type . stuff)
(set! event-history (cons (cons type stuff) event-history)))
;; --- new callbacks ---
(define-syntax-rule (def/over-cb (pname name arg ...))
(define/override (pname arg ...)
(when (super pname arg ...) (add-event name arg ...))))
(def/over-cb (ptock tick))
(def/over-cb (pkey key e))
(def/over-cb (pmouse mouse x y me))
(def/over-cb (prec rec m))
;; --> Void
;; re-play the history of events; create a png per step; create animated gif
;; effect: write to user-chosen directory
(define/private (play-back)
;; World EventRecord -> World
(define (world-transition world fst) (apply (car fst) world (cdr fst)))
;; --- creating images
(define total (+ (length event-history) 1))
(define digt# (string-length (number->string total)))
(define imag# 0)
(define bmps '())
;; Image -> Void
(define (save-image img)
(define bm (make-object bitmap% width height))
(define dc (make-object bitmap-dc% bm))
(send dc clear)
(send img draw dc 0 0 0 0 width height 0 0 #f)
(set! imag# (+ imag# 1))
(send bm save-file (format "i~a.png" (zero-fill imag# digt#)) 'png)
(set! bmps (cons bm bmps)))
;; --- choose place
(define img:dir (get-directory "image directory:" #f (current-directory)))
(when img:dir
(parameterize ([current-directory img:dir])
(define last
(foldr (lambda (event world)
(save-image (draw world))
(show (text (format "~a/~a created" imag# total) 18 'red))
(world-transition world event))
world0
event-history))
(show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
(create-animated-gif rate (reverse bmps))
(show (draw last)))))))
;; Number [Listof (-> bitmap)] -> Void
;; turn the list of thunks into animated gifs
;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
;; [Listof (-> bitmap)] -> Void
;; turn the list of thunks into animated gifs
;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
(define (create-animated-gif R bitmap-list)
(when (file-exists? ANIMATED-GIF-FILE) (delete-file ANIMATED-GIF-FILE))
(write-animated-gif bitmap-list (if (> +inf.0 R 0) (number->integer R) 5)
ANIMATED-GIF-FILE
#:one-at-a-time? #t
#:loop? #f))
(define ANIMATED-GIF-FILE "i-animated.gif")

311
collects/2htdp/universe.ss Executable file
View File

@ -0,0 +1,311 @@
#lang scheme/gui
#| TODO:
-- make window resizable :: why?
|#
(require (for-syntax "private/syn-aux.ss")
"private/syn-aux-aux.ss"
"private/syn-aux.ss"
"private/check-aux.ss"
"private/image.ss"
"private/world.ss"
"private/universe.ss"
htdp/error
(rename-in lang/prim (first-order->higher-order f2h))
(only-in mzlib/etc evcase))
(provide (all-from-out "private/image.ss"))
(provide
sexp? ;; Any -> Boolean
scene? ;; Any -> Boolean
)
;; Spec = (on-tick Expr)
;; | (on-tick Expr Expr)
;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
(define-keywords AllSpec
[on-tick (function-with-arity
1
except
[(x rate)
#'(list (proc> 'on-tick (f2h x) 1)
(num> 'on-tick rate positive? "pos. number" "rate"))])])
;
;
;
; ; ; ; ;
; ; ; ; ;
; ; ; ; ;
; ; ; ;;; ; ;; ; ;;;;
; ; ; ; ; ;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ;; ;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;
; ; ; ;;; ; ;; ;;;;
;
;
;
(provide big-bang ;; <syntax> : see below
make-package ;; World Sexp -> Package
package? ;; Any -> Boolean
run-movie ;; [Listof Image] -> true
;; A MouseEventType is one of:
;; - 'button-down
;; - 'button-up
;; - 'drag
;; - 'move
;; - 'enter
;; - 'leave
mouse-event? ;; Any -> Boolean
mouse=? ;; MouseEventType MouseEventType -> Boolean
;; KeyEvent is one of:
;; -- Char
;; -- Symbol
key-event? ;; Any -> Boolean
key=? ;; KeyEvent KeyEvent -> Boolean
;; IP : a string that points to a machine on the net
LOCALHOST ;; IP
)
(provide-higher-order-primitive
run-simulation (create-scene) ; (Number Number Number (Nat -> Scene) -> true)
)
;; Expr = (big-bang Expr WorldSpec ...)
;; WorldSpec = AllSpec
;; | (on-draw Expr)
;; | (on-draw Expr Expr Expr)
;; -- on-draw must specify a rendering function; it may specify canvas dimensions
;; | (on-key Expr)
;; -- on-key must specify a key event handler
;; | (on-mouse Expr)
;; -- on-mouse must specify a mouse event handler
;; | (stop-when Expr)
;; -- stop-when must specify a boolean-valued function
;; | (register Expr)
;; | (register Expr Expr)
;; -- register must specify the internet address of a host (including LOCALHOST)
;; -- it may specify a world's name
;; | (record? Expr)
;; -- should the session be recorded and turned into PNGs and an animated GIF
;; | (on-receive Expr)
;; -- on-receive must specify a receive handler
(define-keywords WldSpec
[on-draw (function-with-arity
1
except
[(f width height)
#'(list (proc> 'on-draw (f2h f) 1)
(nat> 'on-draw width "width")
(nat> 'on-draw height "height"))])]
[on-mouse (function-with-arity 4)]
[on-key (function-with-arity 2)]
[on-receive (function-with-arity 2)]
[stop-when (function-with-arity 1)]
[register (lambda (tag)
(lambda (p)
(syntax-case p ()
[(host) #`(ip> #,tag host)]
[(ip name) #`(list (ip> #,tag ip) (symbol> #,tag name))]
[_ (err tag p)])))]
[record? (lambda (tag)
(lambda (p)
(syntax-case p ()
[(b) #`(bool> #,tag b)]
[_ (err tag p)])))])
(define-syntax (big-bang stx)
(syntax-case stx ()
[(big-bang) (raise-syntax-error #f "bad world description" stx)]
[(big-bang w s ...)
(let* ([Spec (append AllSpec WldSpec)]
[kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
[rec? #'#f]
[spec (map (lambda (stx)
(syntax-case stx ()
[(kw . E)
(and (identifier? #'kw)
(for/or ([n kwds]) (free-identifier=? #'kw n)))
(begin
(when (free-identifier=? #'kw #'record?)
(syntax-case #'E ()
[(V) (set! rec? #'V)]
[_ (err 'record? stx)]))
(cons (syntax-e #'kw) (syntax E)))]
[_ (raise-syntax-error
'big-bang "not a legal big-bang clause" stx)]))
(syntax->list (syntax (s ...))))]
;; assert: all bind = (kw . E) and kw is constrained via Bind
[args (map (lambda (x)
(define kw (car x))
(define co (assq kw Spec))
(list kw ((cadr co) (cdr x))))
spec)])
#`(send (new (if #,rec? aworld% world%) [world0 w] #,@args) last))]))
;
;
;
; ; ; ; ; ;;;
; ; ; ; ; ; ;
; ; ; ; ; ; ;
; ; ; ;;; ; ;; ; ;;;; ; ; ; ; ; ;
; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ;; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
; ; ; ;;; ; ;; ;;;; ; ; ;; ; ; ;
;
;
;
(define (run-simulation f)
(check-proc 'run-simulation f 1 "first" "one argument")
(big-bang 1 (on-tick add1) (on-draw f)))
(define (run-movie r m*)
(check-arg 'run-movie (positive? r) "positive number" "first" r)
(check-arg 'run-movie (list? m*) "list (of images)" "second" m*)
(for-each (lambda (m) (check-image 'run-movie m "first" "list of images")) m*)
(let* ([fst (car m*)]
[wdt (image-width fst)]
[hgt (image-height fst)])
(big-bang
m*
(on-tick rest r)
(on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m))))
(stop-when empty?))))
(define (mouse-event? a)
(pair? (member a '(button-down button-up drag move enter leave))))
(define (mouse=? k m)
(check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
(check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
(eq? k m))
(define (key-event? k)
(or (char? k) (symbol? k)))
(define (key=? k m)
(check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
(check-arg 'key=? (key-event? m) 'KeyEvent "second" m)
(eqv? k m))
(define LOCALHOST "127.0.0.1")
;; -----------------------------------------------------------------------------
;
;
;
; ; ; ;
; ; ; ;
; ; ;
; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;;
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ;;; ; ;;; ;;;
;
;
;
(provide
;; type World
world? ;; Any -> Boolean
world=? ;; World World -> Boolean
world1 ;; sample worlds
world2
world3
;; type Bundle = (make-bundle Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
universe ;; <syntax> : see below
universe2 ;; (World World -> U) (U World Message) -> U
)
;; Expr = (universe Expr UniSpec)
;; UniSpec = AllSepc
;; | (on-new Expr)
;; -- on-new must specify a 'new world" handler; what happens when a world joins
;; | (on-msg Expr)
;; -- on-msg must specify a 'message' handler
;; | (on-disconnect Expr)
;; -- on-disconnect may specify a handler for the event that a world is leaving
;; | (to-string Expr)
;; -- to-string specifies how to render the universe as a string for display
;; in the console
(define-keywords UniSpec
[on-new (function-with-arity 2)]
[on-msg (function-with-arity 3)]
[on-disconnect (function-with-arity 2)]
[to-string (function-with-arity 1)])
(define-syntax (universe stx)
(syntax-case stx ()
[(universe) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u bind ...)
(let* ([Spec (append AllSpec UniSpec)]
[kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
[spec (map (lambda (stx)
(syntax-case stx ()
[(kw . E)
(and (identifier? #'kw)
(for/or ([n kwds]) (free-identifier=? #'kw n)))
(cons (syntax-e #'kw) (syntax E))]
[(kw E)
(and (identifier? #'kw)
(for/or ([n kwds]) (free-identifier=? #'kw n)))
(list (syntax-e #'kw) (syntax E))]
[_ (raise-syntax-error
'universe "not a legal universe clause" stx)]))
(syntax->list (syntax (bind ...))))]
;; assert: all bind = (kw . E) and kw is constrained via Bind
[args (map (lambda (x)
(define kw (car x))
(define co (assq kw Spec))
(list kw ((cadr co) (cdr x))))
spec)]
[domain (map car args)])
(cond
[(not (memq 'on-new domain))
(raise-syntax-error #f "missing on-new clause" stx)]
[(not (memq 'on-msg domain))
(raise-syntax-error #f "missing on-msg clause" stx)]
[else ; (and (memq #'on-new domain) (memq #'on-msg domain))
#`(send (new universe% [universe0 u] #,@args) last)]))]))
;; (World World -> U) (U World Msg) -> U
(define (universe2 create process)
;; UniState = '() | (list World) | Universe
;; UniState World -> (cons UniState [Listof (list World S-expression)])
(define (nu s p)
(cond
[(null? s) (make-bundle (list p) '())]
[(not (pair? s)) (make-bundle s '())]
[(null? (rest s)) (create (first s) p)]
[else (error 'create "a third world is signing up!")]))
(universe '()
(on-new nu)
(on-msg process)
#;
(on-tick (lambda (u) (printf "hello!\n") (list u)) 1)))

27
collects/lang/htdp-langs.ss
View File

@ -662,11 +662,16 @@
data-class-names)))))))))
(define (get-teachpack-from-user parent)
(define tp-dir (collection-path "teachpack" "htdp"))
(define tp-dirs (list (collection-path "teachpack" "htdp")
(collection-path "teachpack" "2htdp")))
(define columns 2)
(define tps (filter
(λ (x) (file-exists? (build-path tp-dir x)))
(directory-list tp-dir)))
(define tps (apply
append
(map (λ (tp-dir)
(filter
(λ (x) (file-exists? (build-path tp-dir x)))
(directory-list tp-dir)))
tp-dirs)))
(define sort-order (λ (x y) (string<=? (path->string x) (path->string y))))
(define pre-installed-tps (sort tps sort-order))
(define dlg (new dialog% [parent parent] [label (string-constant drscheme)]))
@ -826,7 +831,7 @@
(define compiling-message (new message% [parent button-panel] [label ""] [stretchable-width #t]))
(define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons button-panel
(λ (b e)
(λ (b e)
(set! answer (figure-out-answer))
(send dlg show #f))
(λ (b e)
@ -837,9 +842,15 @@
(cond
[(send pre-installed-lb get-selection)
=>
(λ (i) `(lib ,(send pre-installed-lb get-string i)
"teachpack"
"htdp"))]
(λ (i)
(define f (send pre-installed-lb get-string i))
(cond
[(file-exists? (build-path (collection-path "teachpack" "htdp") f))
`(lib ,f "teachpack" "htdp")]
[(file-exists? (build-path (collection-path "teachpack" "2htdp") f))
`(lib ,f "teachpack" "2htdp")]
[else (error 'figuer-out-answer "argh: ~a ~a"
(collection-path "teachpack" "htdp") f)]))]
[(send user-installed-lb get-selection)
=>
(λ (i) `(lib ,(send user-installed-lb get-string i)

59
collects/teachpack/2htdp/scribblings/balls.ss Normal file
View File

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

59
collects/teachpack/2htdp/scribblings/fsa.ss Normal file
View File

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

119
collects/teachpack/2htdp/scribblings/nuworld.ss Normal file
View File

@ -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 "nuworld.png" 'png)
the-image

181
collects/teachpack/2htdp/scribblings/server2.ss Normal file
View File

@ -0,0 +1,181 @@
#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 ~a ~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

10
collects/teachpack/2htdp/scribblings/shared.ss Normal file
View File

@ -0,0 +1,10 @@
#lang scheme/base
(require scribble/manual)
(provide teachpack)
(define (teachpack tp . name)
(apply title #:tag tp
`(,@name ": " ,(filepath (format "~a.ss" tp))
,(index (format "~a teachpack" tp)))))

1536
collects/teachpack/2htdp/scribblings/universe.scrbl Normal file
View File

File diff suppressed because it is too large Load Diff

200
collects/teachpack/2htdp/scribblings/universe.ss Normal file
View File

@ -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

3
collects/teachpack/2htdp/universe.ss Normal file
View File

@ -0,0 +1,3 @@
(module universe mzscheme
(provide (all-from 2htdp/universe))
(require 2htdp/universe))

BIN
collects/teachpack/balls.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 211 KiB

BIN
collects/teachpack/nuworld.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 15 KiB

BIN
collects/teachpack/server2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 17 KiB

BIN
collects/teachpack/universe.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 28 KiB

BIN
collects/teachpack/universe2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 19 KiB