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

svn: r7834

Browse Source
This commit is contained in:
Matthias Felleisen 2007-11-26 02:20:40 +00:00
parent 2c6a894474
commit 0f3a841e58
1 changed files with 49 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
collects/htdp/world.ss
View File

@ -78,7 +78,7 @@ Matthew
(provide (all-from (lib "image.ss" "htdp"))) (provide (all-from (lib "image.ss" "htdp")))
(provide (provide
;; Scene is Image with pinhole in origin ;; Scene is Image with pinhole in origin
nw:rectangle ;; Number Number Mode Color -> Image nw:rectangle ;; Number Number Mode Color -> Image
place-image ;; Image Number Number Scene -> Scene place-image ;; Image Number Number Scene -> Scene
empty-scene ;; Number Number -> Scene empty-scene ;; Number Number -> Scene
@ -159,7 +159,7 @@ Matthew
(check-arg 'place-image (number? y) 'integer "third" y) (check-arg 'place-image (number? y) 'integer "third" y)
(check-scene 'place-image scene "fourth") (check-scene 'place-image scene "fourth")
(let ([x (number->integer x)] (let ([x (number->integer x)]
[y (number->integer y)]) [y (number->integer y)])
(place-image0 image x y scene))) (place-image0 image x y scene)))
(define (empty-scene width height) (define (empty-scene width height)
@ -212,7 +212,7 @@ Matthew
"-- (big-bang <width> <height> <rate> <world0>)\n" "-- (big-bang <width> <height> <rate> <world0>)\n"
"-- (big-bang <width> <height> <rate> <world0> <animated-gif>)\n" "-- (big-bang <width> <height> <rate> <world0> <animated-gif>)\n"
"see Help Desk.")) "see Help Desk."))
(define big-bang0 (define big-bang0
(case-lambda (case-lambda
[(w h delta world) (big-bang w h delta world #f)] [(w h delta world) (big-bang w h delta world #f)]
@ -233,17 +233,17 @@ Matthew
"fifth" "fifth"
animated-gif) animated-gif)
(let ([w (coerce w)] (let ([w (coerce w)]
[h (coerce h)]) [h (coerce h)])
(when (vw-init?) (error 'big-bang "big-bang already called once")) (when (vw-init?) (error 'big-bang "big-bang already called once"))
(install-world delta world) ;; call first to establish a visible world (install-world delta world) ;; call first to establish a visible world
(set-and-show-frame w h animated-gif) ;; now show it (set-and-show-frame w h animated-gif) ;; now show it
(unless animated-gif (set! add-event void)) ;; no recording if image undesired (unless animated-gif (set! add-event void)) ;; no recording if image undesired
(set! *the-delta* delta) (set! *the-delta* delta)
#t)])) #t)]))
;; Number -> Int ;; Number -> Int
(define (coerce x) (inexact->exact (floor x))) (define (coerce x) (inexact->exact (floor x)))
(define *the-delta* 0.0) (define *the-delta* 0.0)
(define (end-of-time s) (define (end-of-time s)
@ -285,17 +285,17 @@ Matthew
(check-image 'run-movie cand "first" "list of images")) (check-image 'run-movie cand "first" "list of images"))
movie) movie)
(let* ([fst (car movie)] (let* ([fst (car movie)]
[wdt (image-width fst)] [wdt (image-width fst)]
[hgt (image-height fst)] [hgt (image-height fst)]
[nxt (lambda (w) (if (null? w) (end-of-time "") (cdr w)))]) [nxt (lambda (w) (if (null? w) (end-of-time "") (cdr w)))])
(big-bang wdt hgt (/ 1 27) movie) (big-bang wdt hgt (/ 1 27) movie)
(let run-movie ([movie movie]) (let run-movie ([movie movie])
(cond (cond
[(null? movie) #t] [(null? movie) #t]
[(pair? movie) [(pair? movie)
(update-frame (car movie)) (update-frame (car movie))
(sleep/yield .05) (sleep/yield .05)
(run-movie (cdr movie))])))) (run-movie (cdr movie))]))))
(define run-simulation (define run-simulation
(lambda x (lambda x
@ -309,8 +309,8 @@ Matthew
"-- (run-simulation <width> <height> <rate> <world-to-world-function>)\n" "-- (run-simulation <width> <height> <rate> <world-to-world-function>)\n"
"-- (run-simulation <width> <height> <rate> <world-to-world-function> <create-animated-gif?>)\n" "-- (run-simulation <width> <height> <rate> <world-to-world-function> <create-animated-gif?>)\n"
"see Help Desk.")) "see Help Desk."))
(define run-simulation0 (define run-simulation0
(case-lambda (case-lambda
[(width height rate f record?) [(width height rate f record?)
@ -352,7 +352,7 @@ Matthew
(if (and (pair? other-message) (string? (car 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) (car other-message) rank i)
(check-arg tag (image? i) "image" rank i))) (check-arg tag (image? i) "image" rank i)))
;; Symbol Any String -> Void ;; Symbol Any String -> Void
(define (check-scene tag i rank) (define (check-scene tag i rank)
(if (image? i) (if (image? i)
@ -371,10 +371,10 @@ Matthew
;; Symbol (union Symbol String) Nat -> Void ;; Symbol (union Symbol String) Nat -> Void
(define (check-mode tag s rank) (define (check-mode tag s rank)
(check-arg tag (or (eq? s 'solid) (check-arg tag (or (eq? s 'solid)
(eq? s 'outline) (eq? s 'outline)
(string=? "solid" s) (string=? "solid" s)
(string=? "outline" s)) "mode (solid or outline)" rank s)) (string=? "outline" s)) "mode (solid or outline)" rank s))
; ;
; ;
; ;;;;; ;;;;; ; ;;;;; ;;;;;
@ -644,23 +644,21 @@ Matthew
;; Amount of space around the image in the world window: ;; Amount of space around the image in the world window:
(define INSET 5) (define INSET 5)
;
; ;
; ; ;;;;;; ;;;;; ;;
; ;;;;; ; ; ; ;;; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;;; ;;; ;;; ;; ;; ;;;;; ; ; ;;; ;;;; ;;; ;; ;; ;; ;
; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ;;
; ; ; ; ;;; ; ;; ;;;;; ; ; ;;;; ; ; ; ; ; ; ;;;;; ; ; ; ;;;; ;;;;; ; ; ; ; ; ;
; ;;;;; ; ; ; ; ;; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ;;;; ;;; ;;; ;;; ;;; ; ;;;; ;;; ;;; ;;;;; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ;; ; ;
; ;;;;; ; ;;;; ; ; ;; ; ; ;; ; ;;; ;
; ;
; ;
;
(define TICK 'tick) (define TICK 'tick)
(define MOUSE 'mouse) (define MOUSE 'mouse)
@ -718,7 +716,7 @@ Matthew
(create-animated-gif (reverse bitmap-list)) (create-animated-gif (reverse bitmap-list))
(update-frame img)] (update-frame img)]
[else (replay (cdr ev) (world-transition world (car ev)))])))) [else (replay (cdr ev) (world-transition world (car ev)))]))))
;; [Listof (-> bitmap)] -> Void ;; [Listof (-> bitmap)] -> Void
;; turn the list of thunks into animated gifs ;; turn the list of thunks into animated gifs
;; effect: overwrite the ANIMATED-GIF-FILE (in current directory) ;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)
@ -798,12 +796,12 @@ Matthew
(define fname (object-name f)) (define fname (object-name f))
(define tname (if fname fname 'your-redraw-function)) (define tname (if fname fname 'your-redraw-function))
(if (image? result) (if (image? result)
(check-result tname scene? "scene" result (check-result tname scene? "scene" result
(format "image with pinhole at (~s,~s)" (format "image with pinhole at (~s,~s)"
(pinhole-x result) (pinhole-y result))) (pinhole-x result) (pinhole-y result)))
(check-result tname (lambda (x) (image? x)) "scene" result)) (check-result tname (lambda (x) (image? x)) "scene" result))
(update-frame result))) (update-frame result)))
;; f : [World KeyEvent -> World] ;; f : [World KeyEvent -> World]
;; esp : EventSpace ;; esp : EventSpace
;; e : KeyEvent ;; e : KeyEvent