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

changed world.ss interface to accommodate stepper

Browse Source 
svn: r1578
This commit is contained in:
Matthias Felleisen 2005-12-10 15:15:18 +00:00
parent 08298352d3
commit 6b33960bb4
1 changed files with 90 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

182
collects/htdp/world.ss
View File

@ -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 <exp> produce <exp>)
)
(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 <image> produce <expression>)")]))
(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)