macro for callbacks! macros ueber alles!
svn: r5166
This commit is contained in:
Matthias Felleisen
parent
91ff7ee9b4
commit
ceae98a985
|
|
@ -3,13 +3,11 @@
|
|||
does it work when kids play games for several minutes?
|
||||
when the mouse is used a lot?
|
||||
it would mean tens of thousands of interactions or more.
|
||||
|
||||
- change documentation teachpack :: arbitary numbers for image funcs,
|
||||
add-line's cut-off, buttons.
|
||||
- image manipulation functions should accept plain numbers, not insist on nat
|
||||
- make scene distinct from image?
|
||||
|#
|
||||
|
||||
;; Fri Dec 22 11:51:53 EST 2006: cleaned up the callback code with macro
|
||||
;; Thu Dec 21 13:59:23 EST 2006: fixed add-line and place-image to accept numbers
|
||||
;; Wed Dec 20 18:17:03 EST 2060: recording events and creating images
|
||||
;; Sun Dec 09 23:17:41 EST 2006: add-line fixed so it cuts off lines before drawing
|
||||
|
|
@ -195,15 +193,13 @@
|
|||
|
||||
(define (end-of-time s)
|
||||
(printf "end of time: ~a~n" s)
|
||||
(stop-it)
|
||||
(callback-stop!)
|
||||
the-world)
|
||||
|
||||
(define (on-tick-event f)
|
||||
(check-proc 'on-tick-event f 1 "on-tick-event" "one argument")
|
||||
(check-world 'on-tick-event)
|
||||
(if (eq? timer-callback void)
|
||||
(set! timer-callback (make-timer-callback f))
|
||||
(error 'on-tick "the timing action has been set already"))
|
||||
(set-timer-callback f)
|
||||
(send the-time start
|
||||
(let* ([w (ceiling (* 1000 the-delta))])
|
||||
(if (exact? w) w (inexact->exact w))))
|
||||
|
|
@ -212,32 +208,21 @@
|
|||
(define (on-redraw f)
|
||||
(check-proc 'on-redraw f 1 "on-redraw" "one argument")
|
||||
(check-world 'on-redraw)
|
||||
(if (eq? redraw-callback void)
|
||||
(begin
|
||||
(set! redraw-callback (make-redraw-callback f))
|
||||
(set-redraw-callback f)
|
||||
(redraw-callback)
|
||||
#t)
|
||||
(error 'on-redraw "the redraw function has already been specified")))
|
||||
|
||||
(define (on-key-event f)
|
||||
(check-proc 'on-key-event f 2 "on-key-event" "two arguments")
|
||||
(check-world 'on-key-event)
|
||||
(let ([esp (current-eventspace)])
|
||||
(if (eq? key-callback void)
|
||||
(begin
|
||||
(set! key-callback (make-keyevent-callback f esp))
|
||||
(set-key-callback f (current-eventspace))
|
||||
#t)
|
||||
(error 'on-event "the event action has been set already"))))
|
||||
|
||||
(define (on-mouse-event f)
|
||||
(check-proc 'on-mouse-event f 4 "on-mouse-event" "four arguments")
|
||||
(check-world 'on-mouse-event)
|
||||
(let ([esp (current-eventspace)])
|
||||
(if (eq? mouse-callback void)
|
||||
(begin
|
||||
(set! mouse-callback (make-mouse-callback f esp))
|
||||
(set-mouse-callback f (current-eventspace))
|
||||
#t)
|
||||
(error 'on-mouse-event "the mouse event action has been set already"))))
|
||||
|
||||
(define (run-movie movie)
|
||||
(check-arg 'run-movie (list? movie) "list (of images)" "first" movie)
|
||||
|
|
@ -473,7 +458,7 @@
|
|||
(define the-delta 1000)
|
||||
|
||||
;; Text-- The One and Only Visible World
|
||||
(define visible-world void)
|
||||
(define visible-world #f)
|
||||
|
||||
;; -> Void
|
||||
(define (vw-setup)
|
||||
|
|
@ -482,7 +467,7 @@
|
|||
(send visible-world hide-caret #t))
|
||||
|
||||
;; -> Boolean
|
||||
(define (vw-init?) (not (eq? void visible-world)))
|
||||
(define (vw-init?) (procedure? visible-world))
|
||||
|
||||
;; Image -> Void
|
||||
;; show the image in the visible world
|
||||
|
|
@ -498,30 +483,29 @@
|
|||
;; effect: create, show and set the-frame
|
||||
;; assume: visible-world is a text%, i.e., install-world has been called.
|
||||
(define (set-and-show-frame w h)
|
||||
(define the-play-back-thread (box #f))
|
||||
(define frame (create-frame the-play-back-thread))
|
||||
(add-stop-and-image-buttons frame the-play-back-thread)
|
||||
(define the-play-back-custodian (make-custodian))
|
||||
(define frame (create-frame the-play-back-custodian))
|
||||
(add-stop-and-image-buttons frame the-play-back-custodian)
|
||||
(add-editor-canvas frame visible-world w h)
|
||||
(send frame show #t))
|
||||
|
||||
;; [Box (union false Thread)] -> Frame
|
||||
(define (create-frame the-play-back-thread)
|
||||
;; create a frame that shuts down the custodian on close
|
||||
(define (create-frame the-play-back-custodian)
|
||||
(new (class frame%
|
||||
(super-new)
|
||||
(define/augment (on-close)
|
||||
(define th (unbox the-play-back-thread))
|
||||
(when th
|
||||
(kill-thread th)
|
||||
(set-box! the-play-back-thread #f))
|
||||
(stop-it)
|
||||
(inner (void) on-close)))
|
||||
(custodian-shutdown-all the-play-back-custodian)
|
||||
(callback-stop!)))
|
||||
(label "DrScheme")
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
(style '(no-resize-border metal))))
|
||||
|
||||
;; Frame [Box (union false Thread)] -> Void
|
||||
(define (add-stop-and-image-buttons frame the-play-back-thread)
|
||||
;; adds the stop animation and image creation button,
|
||||
;; whose callbacks runs as a thread in the custodian
|
||||
(define (add-stop-and-image-buttons frame the-play-back-custodian)
|
||||
(define p (new horizontal-pane% [parent frame][alignment '(center center)]))
|
||||
(define l-stop ((bitmap-label-maker
|
||||
(string-constant break-button-label)
|
||||
|
|
@ -532,18 +516,19 @@
|
|||
(define stop-button
|
||||
(new button% [parent p] [label l-stop] [style '(border)]
|
||||
[callback (lambda (this-button e)
|
||||
(stop-it)
|
||||
(callback-stop!)
|
||||
(send this-button enable #f)
|
||||
(send image-button enable #t))]))
|
||||
(define image-button
|
||||
(new button% [parent p] [enabled #f] [label l-imgs] [style '(border)]
|
||||
[callback (lambda (b e)
|
||||
(parameterize ([current-custodian the-play-back-custodian])
|
||||
(define th (thread play-back))
|
||||
(send b enable #f)
|
||||
(set-box! the-play-back-thread th))]))
|
||||
(send b enable #f)))]))
|
||||
(void))
|
||||
|
||||
;; Frame Editor Nat Nat -> Void
|
||||
;; adds the visible wold to the frame and hooks it up with the callbacks
|
||||
(define (add-editor-canvas frame visible-world w h)
|
||||
(define c
|
||||
(new (class editor-canvas%
|
||||
|
|
@ -649,62 +634,91 @@
|
|||
(define a* (append (list "-delay" "5") files:pln (list "i-animated.gif")))
|
||||
(if convert (apply system* convert a*) (printf "can't find convert")))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; ;;; ;;; ;;; ; ;
|
||||
; ; ; ; ; ;
|
||||
; ; ; ; ; ;
|
||||
; ; ;;;; ; ; ; ;; ;;;; ;;;; ; ; ;;;
|
||||
; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ;;; ;
|
||||
; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ;
|
||||
; ;;; ;; ; ;;; ;;; ;;;; ;; ; ;;;; ; ; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
;; callbacks: timer, mouse, key, redraw
|
||||
|
||||
;; Definition = (define-callback Symbol String Symbol Expression ...)
|
||||
;; effect: (define-callback introduces three names: name, name0, set-name
|
||||
(define-syntax (define-callback stx)
|
||||
(syntax-case stx ()
|
||||
[(_ n msg (f esp ...) para body ...)
|
||||
(let* ([n:str (symbol->string (syntax-e (syntax n)))]
|
||||
[callback (lambda (before after)
|
||||
(string->symbol
|
||||
(string-append before n:str "-callback" after)))]
|
||||
[name (datum->syntax-object stx (callback "" ""))]
|
||||
[name0 (datum->syntax-object stx (callback "" "0"))]
|
||||
[set-name (datum->syntax-object stx (callback "set-" ""))])
|
||||
#`(define-values (#,name #,name0 #,set-name)
|
||||
(values
|
||||
void void
|
||||
(lambda (f esp ...)
|
||||
(when (callback-set? #,name)
|
||||
(error (format "the ~a has already been specified") msg))
|
||||
(set! #,name0 f)
|
||||
(set! #,name (lambda para body ...))))))]))
|
||||
|
||||
;; -> Void
|
||||
(define (callback-stop!)
|
||||
(send the-time stop)
|
||||
(set! timer-callback void)
|
||||
(set! mouse-callback void)
|
||||
(set! key-callback void)
|
||||
(set! redraw-callback void))
|
||||
|
||||
;; Any -> Boolean
|
||||
;; is the callback set to the default value
|
||||
(define (callback-set? cb) (not (eq? cb void)))
|
||||
|
||||
;; Timer
|
||||
(define the-time (new timer% [notify-callback (lambda () (timer-callback))]))
|
||||
|
||||
;; (World -> World)
|
||||
(define timer-callback void)
|
||||
(define timer-callback0 void)
|
||||
|
||||
;; [World -> World] -> [-> Void]
|
||||
(define (make-timer-callback f)
|
||||
(set! timer-callback0 f)
|
||||
(lambda ()
|
||||
;; f : [World -> World]
|
||||
(define-callback timer "tick-event hander" (f) ()
|
||||
(with-handlers ([exn:break? break-handler][exn? exn-handler])
|
||||
(set! the-world (f the-world))
|
||||
(add-event TICK)
|
||||
(redraw-callback))))
|
||||
(redraw-callback)))
|
||||
|
||||
;; [-> Void]
|
||||
(define redraw-callback void)
|
||||
(define redraw-callback0 void)
|
||||
|
||||
;; [World -> Image] -> [-> Void]
|
||||
(define (make-redraw-callback f)
|
||||
(set! redraw-callback0 f)
|
||||
(lambda ()
|
||||
;; f : [World -> Image]
|
||||
(define-callback redraw "redraw function" (f) ()
|
||||
(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))))
|
||||
(update-frame img)))
|
||||
|
||||
;; KeyEvent -> Void
|
||||
(define key-callback void)
|
||||
(define key-callback0 void)
|
||||
|
||||
;; [World KeyEvent] EventSpace -> [KeyEvent -> Void]
|
||||
(define (make-keyevent-callback f esp)
|
||||
(set! key-callback0 f)
|
||||
(lambda (e)
|
||||
(parameterize ([current-eventspace esp])
|
||||
;; f : [World KeyEvent -> World]
|
||||
;; esp : EventSpace
|
||||
;; e : KeyEvent
|
||||
(define-callback key "key-event handler" (f evt-space) (e)
|
||||
(parameterize ([current-eventspace evt-space])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(with-handlers ([exn:break? break-handler][exn? exn-handler])
|
||||
(set! the-world (f the-world e))
|
||||
(add-event KEY e)
|
||||
(redraw-callback)))))))
|
||||
(redraw-callback))))))
|
||||
|
||||
;; MouseEvent -> Void
|
||||
(define mouse-callback void)
|
||||
(define mouse-callback0 void)
|
||||
|
||||
;; [World Nat Nat MouseEventType -> World] EventSpace -> [MouseEvent -> Void]
|
||||
;; create a mouse event handler from the current event space
|
||||
;; and a user-supplied function
|
||||
(define (make-mouse-callback f esp)
|
||||
(set! mouse-callback0 f)
|
||||
(lambda (e)
|
||||
(parameterize ([current-eventspace esp])
|
||||
;; f : [World Nat Nat MouseEventType -> World]
|
||||
;; esp : EventSpace
|
||||
;; e : MouseEvent
|
||||
(define-callback mouse "mouse event handler" (f evt-space) (e)
|
||||
(parameterize ([current-eventspace evt-space])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(with-handlers ([exn:break? break-handler][exn? exn-handler])
|
||||
|
|
@ -713,7 +727,7 @@
|
|||
(define m (mouse-event->symbol e))
|
||||
(set! the-world (f the-world x y m))
|
||||
(add-event MOUSE x y m)
|
||||
(redraw-callback)))))))
|
||||
(redraw-callback))))))
|
||||
|
||||
;; MouseEvent -> MouseEventType
|
||||
(define (mouse-event->symbol e)
|
||||
|
|
@ -731,24 +745,15 @@
|
|||
|
||||
;; --- library
|
||||
(define (exn-handler e)
|
||||
(stop-it)
|
||||
(callback-stop!)
|
||||
(raise e))
|
||||
|
||||
(define (break-handler . _)
|
||||
(printf "animation stopped")
|
||||
(stop-it)
|
||||
(callback-stop!)
|
||||
the-world)
|
||||
|
||||
;; -> Void
|
||||
(define (stop-it)
|
||||
(send the-time stop)
|
||||
(set! mouse-callback void)
|
||||
(set! key-callback void)
|
||||
(set! redraw-callback void)
|
||||
(set! timer-callback void))
|
||||
|
||||
;; Number -> Integer
|
||||
(define (number->integer x)
|
||||
(inexact->exact (floor x)))
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user