From 0f3a841e58f60d76a94affb3a46243da4e123cd0 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 26 Nov 2007 02:20:40 +0000 Subject: [PATCH] svn: r7834 --- collects/htdp/world.ss | 100 ++++++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 51 deletions(-) diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index de724f54e2..9b6aa37286 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -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 )\n" "-- (big-bang )\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 )\n" "-- (run-simulation )\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