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