diff --git a/collects/2htdp/tests/pad1-handler.rkt b/collects/2htdp/tests/pad1-handler.rkt index bb860f0a2e..c7a9cf2466 100644 --- a/collects/2htdp/tests/pad1-handler.rkt +++ b/collects/2htdp/tests/pad1-handler.rkt @@ -22,5 +22,8 @@ (tst (= (handler 8 "right") 9)) (tst (= (handler 8 "up") 8-i)) (tst (= (handler 8 "down") 8+i)) -(tst (= (handler 7 "shift") 0)) -(tst (equal? (handler 6 "space") (stop-with 6))) \ No newline at end of file + +(tst (= (handler 9 "a") 8)) +(tst (= (handler 8 "d") 9)) +(tst (= (handler 8 "w") 8-i)) +(tst (= (handler 8 "s") 8+i)) diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index c0d99389ed..91c9b944f6 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -266,7 +266,8 @@ [down DEFAULT #'(lambda (x) x) (function-with-arity 1)] [left DEFAULT #'(lambda (x) x) (function-with-arity 1)] [right DEFAULT #'(lambda (x) x) (function-with-arity 1)] - [space DEFAULT #'(lambda (x) x) (function-with-arity 1)] + ; [space DEFAULT #'(lambda (x) x) (function-with-arity 1)] + #; [shift DEFAULT #'(lambda (x) x) (function-with-arity 1)]) (define-syntax (pad-handler stx) @@ -279,12 +280,21 @@ [doms (map (lambda (x) (car (syntax->list x))) (syntax->list #'(clause ...)))]) (syntax-property (stepper-syntax-property - #`(let ((quasi-object (make-immutable-hash (map cons '#,keys (list #,@args))))) - (lambda (world key-event) - ((hash-ref quasi-object key-event) world))) + #`(produce-handler '#,keys (list #,@args)) 'stepper-skip-completely #t) 'disappeared-use doms))])) +;; let ((quasi-object )) +;; +;; (define-higher-order-primitive the-handler the-handler* (world key-event)) +;; the-handler + +(define (produce-handler keys args) + (define quasi-object (make-immutable-hash (map cons keys args))) + (define (the-handler* world key-event) + ((hash-ref quasi-object key-event (lambda (w) w)) world)) + the-handler*) + (define (run-simulation f) (check-proc 'run-simulation f 1 "first" "one argument") (big-bang 0 (on-draw f) (on-tick add1)))