From 10e0e08143570091f270fad7e14f2836ec824a8e Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Wed, 29 Apr 2009 03:08:40 +0000
Subject: [PATCH] strings for Universe callbacks

svn: r14644
---
 collects/2htdp/private/check-aux.ss | 31 ++++++++++++++++++-----------
 collects/2htdp/private/world.ss     |  2 +-
 collects/2htdp/universe.ss          | 16 +++++++--------
 3 files changed, 28 insertions(+), 21 deletions(-)

diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss
index 094849c8e2..0ff3e302f8 100644
--- a/collects/2htdp/private/check-aux.ss
+++ b/collects/2htdp/private/check-aux.ss
@@ -54,22 +54,29 @@
 
 ;; -----------------------------------------------------------------------------
 
-;; MouseEvent -> [List Nat Nat MouseEventType]
+;; MouseEvent% -> [List Nat Nat MouseEventType]
 ;; turn a mouse event into its pieces 
 (define (mouse-event->parts e)
   (define x (- (send e get-x) INSET))
   (define y (- (send e get-y) INSET))
-  (values x y (cond [(send e button-down?) 'button-down]
-                  [(send e button-up?)   'button-up]
-                  [(send e dragging?)    'drag]
-                  [(send e moving?)      'move]
-                  [(send e entering?)    'enter]
-                  [(send e leaving?)     'leave]
-                  [else ; (send e get-event-type)
-                   (error 'on-mouse-event
-                          (format 
-                           "Unknown event type: ~a"
-                           (send e get-event-type)))])))
+  (values x y 
+          (cond [(send e button-down?) "button-down"]
+                [(send e button-up?)   "button-up"]
+                [(send e dragging?)    "drag"]
+                [(send e moving?)      "move"]
+                [(send e entering?)    "enter"]
+                [(send e leaving?)     "leave"]
+                [else ; (send e get-event-type)
+                 (let ([m (send e get-event-type)])
+                   (error 'on-mouse (format "Unknown event: ~a" m)))])))
+
+;; KeyEvent% -> String
+(define (key-event->parts e)
+  (define x (send e get-key-code))
+  (cond
+    [(char? x) (string x)]
+    [(symbol? x) (symbol->string x)]
+    [else (error 'on-key (format "Unknown event: ~a" x))]))
 
 ;; -----------------------------------------------------------------------------
 ;; Any -> Symbol 
diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss
index 94ceb20d58..15aae304fe 100644
--- a/collects/2htdp/private/world.ss
+++ b/collects/2htdp/private/world.ss
@@ -170,7 +170,7 @@
                  (super-new)
                  ;; deal with keyboard events 
                  (define/override (on-char e) 
-                   (when live (pkey (send e get-key-code))))
+                   (when live (pkey (key-event->parts e))))
                  ;; deal with mouse events if live and within range 
                  (define/override (on-event e)
                    (define-values (x y me) (mouse-event->parts e))
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index de4f119734..df548d3f93 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -122,12 +122,12 @@
           (lambda (p)
             (syntax-case p ()
               [(n) #`(symbol> #,tag n)]
-              [_ (err tag p)])))]
+              [_ (err tag p "expected a string for the current world")])))]
   [record? (lambda (tag)
              (lambda (p)
                (syntax-case p ()
                  [(b) #`(bool> #,tag b)]
-                 [_ (err tag p)])))])
+                 [_ (err tag p "expected a boolean (to record or not to record?")])))])
 
 (define-syntax (big-bang stx)
   (syntax-case stx ()
@@ -195,21 +195,21 @@
      (on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m))))
      (stop-when empty?))))
 
-(define (mouse-event? a)
-  (pair? (member a '(button-down button-up drag move enter leave))))
+(define ME (map symbol->string '(button-down button-up drag move enter leave)))
+
+(define (mouse-event? a) (and (string? a) (pair? (member a ME))))
 
 (define (mouse=? k m)
   (check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
   (check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
-  (eq? k m))
+  (string=? k m))
 
-(define (key-event? k)
-  (or (char? k) (symbol? k)))
+(define (key-event? k) (string? k))
 
 (define (key=? k m)
   (check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
   (check-arg 'key=? (key-event? m) 'KeyEvent "second" m)
-  (eqv? k m))
+  (string=? k m))
 
 (define LOCALHOST "127.0.0.1")