From 461c39b979b0d6ad88f1922cf0104037af252ec0 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Sun, 9 May 2010 19:33:25 -0400
Subject: [PATCH] universe in line with syntax-parse

---
 collects/2htdp/universe-syntax-parse.rkt | 96 ++++++++----------------
 1 file changed, 32 insertions(+), 64 deletions(-)

diff --git a/collects/2htdp/universe-syntax-parse.rkt b/collects/2htdp/universe-syntax-parse.rkt
index 1d279cf316..f3b8412310 100644
--- a/collects/2htdp/universe-syntax-parse.rkt
+++ b/collects/2htdp/universe-syntax-parse.rkt
@@ -9,32 +9,42 @@
     (printf "a positive number")
     rate0)
   
-  ;; String String Syntax[id] -> Syntax 
-  (define (pre-post-name pre post name)
+  ;; Syntax String String Syntax[id] -> Syntax 
+  (define (pre-post-name stx pre post name)
     (datum->syntax 
      name (string->symbol (string-append pre (symbol->string (syntax-e name)) post))))
   
-  (provide (all-defined-out)))
-
-(module clauses scheme 
+  (provide (all-defined-out))
   
-  (require syntax/parse (for-syntax scheme 'auxs unstable/syntax)
+  (define-syntax-rule 
+    (define-kwd name) 
+    (begin
+      (provide name)
+      (define-syntax (name . x) 
+        (raise-syntax-error 'name "used out of context" x))))
+  
+  (define-kwd on-tick)  
+  
+  (define-kwd on-mouse))
+
+(module clauses scheme
+  
+  (require syntax/parse 'auxs
+           (for-syntax scheme 'auxs unstable/syntax)
            (for-template scheme/base 'auxs))
   
+  (provide define-clause)
   
   (define-syntax (define-clause stx)
     (syntax-case stx ()
       [(_ name (proc p-ctc) (rate r-ctc) ...)
-       (with-syntax ([name-clause (pre-post-name "" "-clause" #'name)]
+       (with-syntax ([name-clause (pre-post-name stx "" "-clause" #'name)]
                      [(rate0 ...) (generate-temporaries #'(rate ...))])
          (with-syntax ([((thing ...) ...) #'((#:with rate #'(r-ctc rate0)) ...)])
            #`
            (begin
              (provide name name-clause)
              
-             (define-syntax (name . x)
-               (raise-syntax-error 'name "used out of context" x))
-             
              (define-syntax-class name-clause
                #:description (format "~a" 'name)
                #:literals (name)
@@ -43,75 +53,33 @@
                         #:with (rate0 ...) (map (lambda (x) #'0) '(rate0 ...))
                         #:with proc #'(world->world proc0)
                         thing ... ...)
-               (pattern (on-tick proc0:expr (~var rate0 expr) ...)
+               (pattern (name proc0:expr (~var rate0 expr) ...)
                         #:with proc #'(world->world> proc0)
                         thing ... ...))
              )))]))
   
   (define-clause on-mouse (proc world-nat-nat-mouse->world))
-  (define-clause on-tick (proc world->world) (rate (lambda (x) 1/28)))
-  
-  ;; --- on-tick --- 
-  #|
-  (define-syntax (on-tick . x)
-    (raise-syntax-error 'on-tick "used out of context" x))
-  
-  (define-syntax-class on-tick-clause 
-    #:description "on tick"
-    #:literals (on-tick)
-    #:attributes (proc rate)
-    (pattern (on-tick proc0:expr)
-             #:with proc #'(world->world proc0)
-             #:with rate #'1/28)
-    (pattern (on-tick proc0:expr rate0:expr)
-             #:with proc #'(world->world> proc0)
-             #:with rate #'(positive-number> rate0)))
-  
-  (provide on-tick on-tick-clause)
-  |#
-  ;; --- on-draw --- 
-  (define-syntax (on-draw . x)
-    (raise-syntax-error 'on-draw "used out of context" x))
-  
-  (define-syntax-class on-draw-clause 
-    #:description "on draw"
-    #:literals (on-draw)
-    #:attributes (proc width height)
-    (pattern (on-draw proc0:expr)
-             #:with proc #'(wrap worldxkey->world proc0)
-             #:with width #'#f
-             #:with height #'#f)
-    (pattern (on-draw proc0:expr width0:expr height0:expr)
-             #:with proc #'(worldxkey->world> proc0)
-             #:with width #'(natural-number> width0)
-             #:with height #'(natural-number> height0)))
-  
-  (provide on-draw on-draw-clause))
+  (define-clause on-tick (proc world->world))
+  )
 
 (module utest scheme 
-  (require (for-syntax syntax/parse 'clauses))
+  (require 'clauses (for-syntax 'clauses syntax/parse) (for-template 'clauses))
   
   (define-syntax (big-bang stx)
     (syntax-parse stx
       [(big-bang world0:expr 
-                 (~or (~optional otc:on-tick-clause)
-                      ; (~optional omc:on-mouse-clause)
-                      (~optional odc:on-draw-clause))
+                 (~or (~optional otk:on-tick-clause)
+                      (~optional omc:on-mouse-clause))                 
                  ...)
        #`(printf "~s\n"
                  '(bb world0
-                      #,(if (attribute otc)
-                            #'otc.rate 
-                            #'1/28)
-                      #,(if (attribute odc)
-                            #'odc.proc
-                            #''not-draw)))]))
+                      #,(if (attribute omc) "mouse" "no mouse")
+                      #,(if (attribute otk) "tick" "no tick")))]))
   
-  (big-bang 0)   
-  (big-bang 1 (on-tick add1))
-  (big-bang 2 (on-tick add1 1/2))
-  (big-bang 3 (on-draw add1 1/2 1/3))
-  ; (big-bang 4 (on-mouse add1 1 2))
+  (big-bang 0)
+  (big-bang 1 (on-tick +) (on-mouse -))
+  (big-bang 2 (on-tick +))
+  (big-bang 3 (on-mouse +))
   )
 
 (require 'utest)
\ No newline at end of file