From 9a6e94903e618148a43054fd6b975783b4039c28 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Fri, 12 Mar 2010 01:36:02 +0000
Subject: [PATCH] added release handler

svn: r18515
---
 collects/2htdp/private/check-aux.ss |  8 ++++++++
 collects/2htdp/private/world.ss     | 14 ++++++++++++--
 collects/2htdp/universe.ss          |  3 ++-
 3 files changed, 22 insertions(+), 3 deletions(-)

diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss
index a5b7a665b4..90fbf697da 100644
--- a/collects/2htdp/private/check-aux.ss
+++ b/collects/2htdp/private/check-aux.ss
@@ -71,6 +71,14 @@
     [(symbol? x) (symbol->string x)]
     [else (error 'on-key (format "Unknown event: ~a" x))]))
 
+;; KeyEvent% -> String
+(define (key-release->parts e)
+  (define x (send e get-key-release-code))
+  (cond
+    [(char? x) (string x)]
+    [(symbol? x) (symbol->string x)]
+    [else (error 'on-key (format "Unknown event: ~a" x))]))
+
 ;; -----------------------------------------------------------------------------
 ;; Any -> Symbol 
 (define (name-of draw tag)
diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss
index c80468939f..7c2b768e33 100644
--- a/collects/2htdp/private/world.ss
+++ b/collects/2htdp/private/world.ss
@@ -61,6 +61,7 @@
       
       (init
        (on-key K)        ;; World KeyEvent -> World 
+       (on-release K)    ;; World KeyEvent -> World 
        (on-mouse K)      ;; World Nat Nat MouseEvent -> World 
        (on-receive #f)   ;; (U #f (World S-expression -> World))
        (on-draw #f)      ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
@@ -174,7 +175,11 @@
                  (super-new)
                  ;; deal with keyboard events 
                  (define/override (on-char e) 
-                   (when live (pkey (key-event->parts e))))
+                   (when live
+                     (let ([e:str (key-event->parts e)])
+                       (if (string=? e:str "release")
+                           (prelease (key-release->parts e))
+                           (pkey e:str)))))
                  ;; deal with mouse events if live and within range 
                  (define/override (on-event e)
                    (define-values (x y me) (mouse-event->parts e))
@@ -211,6 +216,7 @@
       ;; callbacks 
       (field
        (key    on-key)
+       (release on-release)
        (mouse  on-mouse)
        (rec    on-receive))
       
@@ -279,6 +285,9 @@
       ;; key events 
       (def/pub-cback (pkey ke) key)
       
+      ;; release events 
+      (def/pub-cback (prelease ke) release)
+      
       ;; mouse events 
       (def/pub-cback (pmouse x y me) mouse)
       
@@ -348,7 +357,7 @@
 
 (define aworld%
   (class world% (super-new)
-    (inherit-field world0 tick key mouse rec draw rate width height)
+    (inherit-field world0 tick key release mouse rec draw rate width height)
     (inherit show callback-stop!)
     
     ;; Frame Custodian ->* (-> Void) (-> Void)
@@ -387,6 +396,7 @@
     
     (def/over-cb (ptock tick))
     (def/over-cb (pkey key e))
+    (def/over-cb (prelease release e))
     (def/over-cb (pmouse mouse x y me))
     (def/over-cb (prec rec m))
     
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index b59b195ae5..2b217ca393 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -103,7 +103,6 @@
     "right"
     "up"
     "down"
-    "release"
     "start"
     "cancel"
     "clear"
@@ -146,6 +145,8 @@
   [on-mouse (function-with-arity 4)]
   ;; -- on-key must specify a key event handler 
   [on-key (function-with-arity 2)]
+  ;; -- on-release must specify a release event handler 
+  [on-release (function-with-arity 2)]
   ;; -- on-receive must specify a receive handler 
   [on-receive (function-with-arity 2)]
   ;; -- stop-when must specify a predicate; it may specify a rendering function