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

70
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)
@ -233,13 +233,13 @@ 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)))
@ -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
@ -371,9 +371,9 @@ 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))
;
;
@ -645,22 +645,20 @@ Matthew
;; Amount of space around the image in the world window:
(define INSET 5)
;
;
; ;;;;; ; ; ; ;;;
; ; ; ; ; ; ;
; ; ; ; ; ; ;
; ; ; ; ;;; ; ;; ;;;;; ; ; ;;;; ;
; ;;;;; ; ; ; ; ;; ; ; ;;;;; ; ; ;
; ; ; ; ;;;;; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;; ;
; ;;;;; ; ;;;; ; ; ;; ; ; ;; ; ;;;
; ;;;;;; ;;;;; ;;
; ; ; ; ; ; ;
; ; ; ;;; ;;; ;;; ;; ;; ;;;;; ; ; ;;; ;;;; ;;; ;; ;; ;; ;
; ;;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ;;
; ; ; ; ; ;;;;; ; ; ; ;;;; ;;;;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;;;; ; ;;;; ;;; ;;; ;;; ;;; ; ;;;; ;;; ;;; ;;;;; ;;;;;
;
;
;
;
(define TICK 'tick)
(define MOUSE 'mouse)
@ -798,10 +796,10 @@ 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]