From f9233bce4718bcc9dbb48fe352cada0698000dc3 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Mon, 16 Jan 2012 11:51:27 -0500
Subject: [PATCH] added pad-handler facility

---
 collects/2htdp/tests/pad1-handler.rkt | 26 ++++++++++++++
 collects/2htdp/tests/pad1.rkt         |  4 +--
 collects/2htdp/universe.rkt           | 49 +++++++++++++++++++--------
 collects/2htdp/xtest                  |  1 +
 4 files changed, 64 insertions(+), 16 deletions(-)
 create mode 100644 collects/2htdp/tests/pad1-handler.rkt

diff --git a/collects/2htdp/tests/pad1-handler.rkt b/collects/2htdp/tests/pad1-handler.rkt
new file mode 100644
index 0000000000..bb860f0a2e
--- /dev/null
+++ b/collects/2htdp/tests/pad1-handler.rkt
@@ -0,0 +1,26 @@
+#lang racket
+
+(require 2htdp/universe)
+
+;; -----------------------------------------------------------------------------
+;; test case 
+
+(define (i-sub1 x) (- x 0+1i))
+(define (i-add1 x) (+ x 0+1i))
+
+(define handler 
+  (pad-handler (left sub1) (right add1)
+               (up i-sub1) (down i-add1)
+               (shift (lambda (w) 0))
+               (space stop-with)))
+
+(define-syntax-rule 
+  (tst (=-fun (handler _1 s) _2))
+  (unless (=-fun (handler _1 s) _2) (error 'test "~a failed" s)))
+
+(tst (= (handler 9 "left")  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
diff --git a/collects/2htdp/tests/pad1.rkt b/collects/2htdp/tests/pad1.rkt
index d0e5944e84..5f39242c19 100644
--- a/collects/2htdp/tests/pad1.rkt
+++ b/collects/2htdp/tests/pad1.rkt
@@ -36,7 +36,7 @@
 (define transform-x (transform center-x))
 (define transform-y (transform center-y))
 
-(define (pad-handler x k)
+(define (phandler x k)
   (case (string->symbol k)
     [(up    w)      (- x 0+10i)]
     [(down  s)      (+ x 0+10i)]
@@ -53,7 +53,7 @@
 (define-syntax-rule 
   (run txt clause ...) 
   (begin (set! label (string-append txt label))
-         (big-bang x0 (to-draw render) (on-pad  pad-handler) clause ... )))
+         (big-bang x0 (to-draw render) (on-pad phandler) clause ... )))
 
 (= -10-10i (run ""))
 (= -10-10i (run "press l, " (on-key (key-handler 'key))))
diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt
index 45c206ff5c..c0d99389ed 100644
--- a/collects/2htdp/universe.rkt
+++ b/collects/2htdp/universe.rkt
@@ -41,15 +41,6 @@
  launch-many-worlds/proc
  )
 
-(provide
- ;; KeyEvent -> Boolean
-  ;; is the given key-event also a pad-event? 
-  pad-event? 
-  ;; PadEvent PadEvent -> Boolean 
-  ;; are the two pad-events equal? 
-  pad=?
-  )
-
 (provide-primitive
  sexp?  ;; Any -> Boolean 
  )
@@ -171,18 +162,24 @@
 ;                                     
 ;                                     
 
-(provide big-bang     ;; <syntax> : see below 
-         )
+(provide 
+ big-bang     ;; <syntax> : see below 
+ pad-handler  ;; <syntax> : see below 
+ )
 
 (provide-primitives
- make-package ;; World Sexp -> Package
- package?     ;; Any -> Boolean 
- run-movie    ;; [r Positive] [m [Listof Image]] -> true
+ make-package  ;; World Sexp -> Package
+ package?      ;; Any -> Boolean 
+ run-movie     ;; [r Positive] [m [Listof Image]] -> true
  ;; run movie m at rate r images per second 
  mouse-event?  ;; Any -> Boolean : MOUSE-EVTS
  mouse=?       ;; MOUSE-EVTS MOUSE-EVTS -> Boolean 
  key-event?    ;; Any -> Boolean : KEY-EVTS
  key=?         ;; KEY-EVTS KEY-EVTS -> Boolean
+ pad-event?    ;; KeyEvent -> Boolean
+ ;; is the given key-event also a pad-event? 
+ pad=?         ;; PadEvent PadEvent -> Boolean 
+ ;; ---
  ;; IP : a string that points to a machine on the net 
  )
 
@@ -264,6 +261,30 @@
 	       'stepper-skip-completely #t)
 	     'disappeared-use (map (lambda (x) (car (syntax->list x))) dom))]))]))
 
+(define-keywords Pad1Specs '() _init-not-needed
+  [up    DEFAULT #'(lambda (x) x) (function-with-arity 1)]
+  [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)]
+  [shift DEFAULT #'(lambda (x) x) (function-with-arity 1)])
+
+(define-syntax (pad-handler stx)
+  (syntax-case stx ()
+    [(pad1 clause ...)
+     (let* ([args (->args 'pad-one-player stx #'w #'(clause ...) Pad1Specs void)]
+            [keys (map (lambda (x) 
+                         (syntax-case x () [(proc> (quote s) _f _d) (symbol->string (syntax-e #'s))]))
+                       args)]
+            [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)))
+         'stepper-skip-completely #t)
+        'disappeared-use doms))]))
+
 (define (run-simulation f)
   (check-proc 'run-simulation f 1 "first" "one argument")
   (big-bang 0 (on-draw f) (on-tick add1)))
diff --git a/collects/2htdp/xtest b/collects/2htdp/xtest
index 499fc32811..ad6bcb1fec 100755
--- a/collects/2htdp/xtest
+++ b/collects/2htdp/xtest
@@ -40,3 +40,4 @@ run struct-universe.rkt
 run universe-receive.rkt
 run name.rkt
 run pad1.rkt
+run pad1-handler.rkt