From 4698e941270cecb963c141eb71182223c8205de5 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Wed, 6 Jul 2011 23:09:05 -0400 Subject: [PATCH] providing a name for tick handler, Closes PR 12027 --- collects/2htdp/private/timer.rkt | 4 +- collects/2htdp/private/universe.rkt | 2 + collects/2htdp/private/world.rkt | 127 +++++++++++++++------------- 3 files changed, 71 insertions(+), 62 deletions(-) diff --git a/collects/2htdp/private/timer.rkt b/collects/2htdp/private/timer.rkt index 459b242222..3c18ee8dfc 100644 --- a/collects/2htdp/private/timer.rkt +++ b/collects/2htdp/private/timer.rkt @@ -12,7 +12,7 @@ (provide clock-mixin start-stop<%>) -(define start-stop<%> (interface () start! ptock pptock stop!)) +(define start-stop<%> (interface () start! ptock pptock name-of-tick-handler stop!)) (define clock-mixin (mixin (start-stop<%>) () @@ -36,4 +36,6 @@ (super stop! w)) (define/override (pptock w) (tick w)) + (define/override (name-of-tick-handler) + (object-name tick)) (super-new))) diff --git a/collects/2htdp/private/universe.rkt b/collects/2htdp/private/universe.rkt index 1b614cb674..65bb27e6f0 100644 --- a/collects/2htdp/private/universe.rkt +++ b/collects/2htdp/private/universe.rkt @@ -122,6 +122,8 @@ ;; tick, tock : deal with a tick event for this world (def/cback pubment (ptock) (let ([on-tick (lambda (w) (pptock w))]) on-tick)) (define/public (pptock w) (void)) + (define/public (name-of-tick-handler) + "the on-tick-handler") ;; IWorld -> Void ;; effect: remove from given iworld from iworlds diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index 293b2c272e..bbe007b854 100644 --- a/collects/2htdp/private/world.rkt +++ b/collects/2htdp/private/world.rkt @@ -245,70 +245,75 @@ (define draw# 0) (set-draw#!) - (define-syntax-rule - (def/cback pub (name arg ...) transform) - ;; Any ... -> Boolean - (begin - (define/public (name arg ...) - (define (last-draw) - (set! draw last-picture) - (pdraw)) - (queue-callback - (lambda () - (with-handlers ([exn? (handler #t)]) - (define tag (object-name transform)) - (define nw (transform (send world get) arg ...)) - (define (d) (pdraw) (set-draw#!)) - ;; --- - ;; [Listof (Box [d | void])] - (define w '()) - ;; set all to void, then w to null - ;; when a high priority draw is scheduledd - ;; --- - (when (package? nw) - (broadcast (package-message nw)) - (set! nw (package-world nw))) - (if (stop-the-world? nw) - (begin - (set! nw (stop-the-world-world nw)) - (send world set tag nw) - (cond - [last-picture (last-draw)] - [draw (pdraw)]) - (callback-stop! 'name) - (enable-images-button)) - (let ([changed-world? (send world set tag nw)] - [stop? (pstop)]) - ;; this is the old "Robby optimization" see checked-cell: - ; unless changed-world? - (cond - [(and draw (not stop?)) - (cond - [(not drawing) - (set! drawing #t) - (let ([b (box d)]) - (set! w (cons b w)) - ;; low priority, otherwise it's too fast - (queue-callback (lambda () ((unbox b))) #f))] - [(< draw# 0) - (set-draw#!) - (for-each (lambda (b) (set-box! b void)) w) - (set! w '()) - ;; high!! the scheduled callback didn't fire - (queue-callback (lambda () (d)) #t)] - [else - (set! draw# (- draw# 1))])] - [stop? - (cond + (define-syntax def/cback + (syntax-rules () + [(_ pub (name arg ...) transform) + (def/cback pub (name arg ...) transform (object-name transform))] + [(_ pub (name arg ...) transform tag) + ;; Any ... -> Boolean + (begin + (define/public (name arg ...) + (define (last-draw) + (set! draw last-picture) + (pdraw)) + (queue-callback + (lambda () + (with-handlers ([exn? (handler #t)]) + ; (define tag (object-name transform)) + (define nw (transform (send world get) arg ...)) + (define (d) (pdraw) (set-draw#!)) + ;; --- + ;; [Listof (Box [d | void])] + (define w '()) + ;; set all to void, then w to null + ;; when a high priority draw is scheduledd + ;; --- + (when (package? nw) + (broadcast (package-message nw)) + (set! nw (package-world nw))) + (if (stop-the-world? nw) + (begin + (set! nw (stop-the-world-world nw)) + (send world set tag nw) + (cond [last-picture (last-draw)] [draw (pdraw)]) (callback-stop! 'name) - (enable-images-button)]) - changed-world?)))))))) + (enable-images-button)) + (let ([changed-world? (send world set tag nw)] + [stop? (pstop)]) + ;; this is the old "Robby optimization" see checked-cell: + ; unless changed-world? + (cond + [(and draw (not stop?)) + (cond + [(not drawing) + (set! drawing #t) + (let ([b (box d)]) + (set! w (cons b w)) + ;; low priority, otherwise it's too fast + (queue-callback (lambda () ((unbox b))) #f))] + [(< draw# 0) + (set-draw#!) + (for-each (lambda (b) (set-box! b void)) w) + (set! w '()) + ;; high!! the scheduled callback didn't fire + (queue-callback (lambda () (d)) #t)] + [else + (set! draw# (- draw# 1))])] + [stop? + (cond + [last-picture (last-draw)] + [draw (pdraw)]) + (callback-stop! 'name) + (enable-images-button)]) + changed-world?)))))))])) ;; tick, tock : deal with a tick event for this world - (def/cback pubment (ptock) (lambda (w) (pptock w))) + (def/cback pubment (ptock) (lambda (w) (pptock w)) (name-of-tick-handler)) (define/public (pptock w) (void)) + (define/public (name-of-tick-handler) + "the on-tick handler") ;; key events (def/cback pubment (pkey ke) key) @@ -388,10 +393,10 @@ (inherit-field world0 draw rate width height record?) (inherit show callback-stop!) - ;; -> String or false + ;; -> String or false (define/private (recordable-directory) (and (path-string? record?) (directory-exists? record?) record?)) - + ;; Frame Custodian ->* (-> Void) (-> Void) ;; adds the stop animation and image creation button, ;; whose callbacks runs as a thread in the custodian @@ -416,7 +421,7 @@ (btn image-button:label (b e) (pb))) (send image-button enable #f) (values switch stop)) - + ;; an argument-recording ppdraw (field [image-history '()]) ;; [Listof Evt] (define/override (ppdraw)