diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index 61303b8f90..24b043bdb4 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -3,43 +3,43 @@ color? ;; Symbol -> Boolean |# ;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now -(module world mzscheme +(module world2 mzscheme (require ; (lib "unitsig.ss") - (lib "etc.ss") - (lib "class.ss") - (lib "mred.ss" "mred") - (lib "error.ss" "htdp") - (lib "image.ss" "htdp") - (prefix beg: (lib "htdp-beginner.ss" "lang")) - (lib "prim.ss" "lang")) + (lib "etc.ss") + (lib "class.ss") + (lib "mred.ss" "mred") + (lib "error.ss" "htdp") + (lib "image.ss" "htdp") + (prefix beg: (lib "htdp-beginner.ss" "lang")) + (lib "prim.ss" "lang")) ;; --- provide --------------------------------------------------------------- (provide (all-from (lib "image.ss" "htdp"))) (provide ;; forall(World): - big-bang ;; Number Number Number World -> true - end-of-time ;; -> World + big-bang ;; Number Number Number World -> true + end-of-time ;; -> World + + nw:rectangle ;; Number Number Mode Color -> Image + place-image ;; Image Number Number Scence -> Scene + empty-scene ;; Number Number -> Scene + run-movie ;; (Listof Image) -> true + ) - nw:rectangle ;; Number Number Mode Color -> Image - place-image ;; Image Number Number Scence -> Scene - empty-scene ;; Number Number -> Scene - run-movie ;; (Listof Image) -> true - ) - - (provide - update produce ;; (update produce ) - ) + (provide-higher-order-primitive + on-tick-event (tock) ;; (World -> World) -> true + ) (provide-higher-order-primitive - on-tick-event (tock) ;; (World -> World) -> true - ) + on-redraw (world-image) ;; (World -> Image) -> true + ) (provide-higher-order-primitive ;; (KeyEvent World -> World) -> true - on-key-event - (tock) - ) + on-key-event + (tock) + ) ;; --------------------------------------------------------------------------- - + ;; Symbol Any String -> Void (define (check-pos tag c rank) (check-arg tag (and (number? c) (integer? c) (>= c 0)) "positive integer" rank c)) @@ -56,7 +56,7 @@ (define (check-mode tag s rank) (check-arg tag (or (eq? s 'solid) (eq? s 'outline)) "'solid or 'outline" rank s)) - + (define (nw:rectangle width height mode color) (check-pos 'rectangle width "first") (check-pos 'rectangle height "second") @@ -83,21 +83,21 @@ (check-pos 'empty-scene width "first") (check-pos 'empty-scene height "second") (move-pinhole - (rectangle width height 'outline 'black) - (/ width -2) (/ height -2)) + (rectangle width height 'outline 'black) + (/ width -2) (/ height -2)) ) ;; display all images in list in the canvas (define (run-movie movie) (check-arg 'run-movie (list? movie) "list (of images)" "first" movie) (for-each (lambda (cand) (check-image 'run-movie cand "first" "list of images")) - movie) + movie) (let run-movie ([movie movie]) (cond [(null? movie) #t] - [(pair? movie) - (update (car movie) produce #t) - (sleep/yield .05) - (run-movie (cdr movie))]))) + [(pair? movie) + (update-frame (car movie)) + (sleep/yield .05) + (run-movie (cdr movie))]))) ;; --------------------------------------------------------------------------- @@ -114,40 +114,40 @@ ;; Number > 0 [define the-delta 1000] - + ;; Number Number Number World -> true ;; create the visible world (canvas) (define (big-bang w h delta world) (check-pos 'big-bang w "first") (check-pos 'big-bang h "second") (check-arg 'big-bang - (and (number? delta) (<= 0 delta 1000)) - "number [of seconds] between 0 and 1000" - "first" - delta) + (and (number? delta) (<= 0 delta 1000)) + "number [of seconds] between 0 and 1000" + "first" + delta) (when the-frame (error 'big-bang "big-bang already called once")) (set! the-delta delta) (set! the-world world) (set! the-frame - (new (class frame% - (super-new) - (define/augment (on-close) - ;; shut down the timer when the window is destroyed - (send the-time stop) - (inner (void) on-close))) - (label "DrScheme"))) + (new (class frame% + (super-new) + (define/augment (on-close) + ;; shut down the timer when the window is destroyed + (send the-time stop) + (inner (void) on-close))) + (label "DrScheme"))) (send - (new (class editor-canvas% - (super-new) - (define/override (on-char e) - (on-char-proc (send e get-key-code)))) - (parent the-frame) - (editor txt) - (style '(no-hscroll no-vscroll)) - ;; this 20 stuff is a hack, for now - (min-width (+ w 20)) - (min-height (+ h 20))) - focus) + (new (class editor-canvas% + (super-new) + (define/override (on-char e) + (on-char-proc (send e get-key-code)))) + (parent the-frame) + (editor txt) + (style '(no-hscroll no-vscroll)) + ;; this 20 stuff is a hack, for now + (min-width (+ w 20)) + (min-height (+ h 20))) + focus) (send txt hide-caret #t) (send the-frame show #t) #t) @@ -165,14 +165,15 @@ (check-world 'on-tick-event) (if (eq? timer-callback void) (set! timer-callback - (lambda () - (with-handlers ([exn:break? break-handler] - [exn? exn-handler]) - (set! the-world (f the-world))))) + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (set! the-world (f the-world)) + (on-redraw-proc)))) (error 'on-tick "the timing action has been set already")) (send the-time start - (let* ([w (ceiling (* 1000 the-delta))]) - (if (exact? w) w (inexact->exact w)))) + (let* ([w (ceiling (* 1000 the-delta))]) + (if (exact? w) w (inexact->exact w)))) #t] ;; --- key events @@ -190,14 +191,15 @@ (if (eq? on-char-proc void) (begin (set! on-char-proc - (lambda (e) - (parameterize ([current-eventspace esp]) - (queue-callback - (lambda () - (with-handlers ([exn:break? break-handler] - [exn? exn-handler]) - (set! the-world (f e the-world)))) - #t)))) + (lambda (e) + (parameterize ([current-eventspace esp]) + (queue-callback + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (set! the-world (f e the-world)) + (on-redraw-proc)))) + #t))) #t) (error 'on-event "the event action has been set already")))] @@ -223,31 +225,27 @@ (send the-time stop) (set! on-char-proc void) (set! timer-callback void)) + + (define on-redraw-proc void) - ;; --- putting images into the canvas - (define-syntax (produce stx) - (raise-syntax-error 'produce "produce must be inside a use of update" stx)) + (define (on-redraw f) + (check-proc 'on-redraw f 1 "on-redraw" "one argument") + (check-world 'on-redraw) + (if (eq? on-redraw-proc void) + (begin + (set! on-redraw-proc + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (define img (f the-world)) + (check-result 'on-redraw (lambda (x) (beg:image? x)) "image" img) + (update-frame img) + #t))) + #t) + (error 'on-redraw "the redraw function has already been specified")) + #t) - (define-syntax (update s) - (syntax-case s (produce) - [(_ pict produce exp) (syntax (update-frame/proc pict (lambda () exp)))] - [(_ pict pict2 ... produce exp) - (raise-syntax-error 'update "you can place only one picture in the canvas" s)] - [(_ stmt produce) - (raise-syntax-error 'update "produce must be followed by an expression" s)] - [(_ stmt produce exp exp2 ...) - (raise-syntax-error 'update "produce must be followed by exactly one expression" s)] - [_ - (raise-syntax-error 'update "use as (update produce )")])) - - (define (update-frame/proc pict thunk) - (begin - (update-frame pict) - (thunk))) - (define (update-frame pict) - (unless the-frame (error 'update SEQUENCE-ERROR)) - (check-result 'update (lambda (x) (beg:image? x)) "image" pict) (send txt begin-edit-sequence) (send txt lock #f) (send txt delete 0 (send txt last-position) #f)