merged keywords back into universe

collects/2htdp/private/syn-aux.rkt

@@ -23,7 +23,7 @@
     [(_ the-list super-list define-create
         (kw:identifier 
          (~optional kw-alt:identifier 
-                    #:defaults ((kw-alt (datum->syntax stx (gensym)))))
+                    #:defaults ((kw-alt #'kw #;(datum->syntax stx (gensym)))))
          (~optional (~seq DEFAULT default:expr))
          coerce:expr) ...)
      (let* ([defs (attribute default)])
@@ -31,8 +31,7 @@
            ;; define and create list of keywords and associated values 
            (define-for-syntax the-list
              (append super-list
-                     (list 
+                     (list (list #'kw     #'kw-alt (coerce ''kw) default)
-                      (list #'kw     #'kw (coerce ''kw) default)
                            #;
                            (list #'kw-alt #'kw (coerce ''kw-alt) default))
                      ...))
@@ -47,9 +46,22 @@
            (define-syntax (define-create stx)
              (syntax-case stx ()
                [(_ para (... ...))
-                (let* [[kwds (map cadr the-list)]
+                (let*-values
-                       [defs (map cadddr the-list)]
+                    ([(kwds defs) 
-                       [args (lambda (para*)
+                      (let L ([the-list the-list][kwds '()][defs '()])
+                        (if (null? the-list)
+                            (values kwds defs)
+                            (let* ([kw-alt-c-d (car the-list)]
+                                   [kw0 (car kw-alt-c-d)]
+                                   [kw1 (cadr kw-alt-c-d)]
+                                   [coe (caddr kw-alt-c-d)]
+                                   [def (cadddr kw-alt-c-d)])
+                              (if (eq? (syntax-e kw0) (syntax-e kw1))
+                                  (L (cdr the-list) (cons kw0 kwds) (cons def defs))
+                                  (L (cdr the-list)
+                                     (list* kw0 kw1 kwds)
+                                     (list* def def defs))))))]
+                     [(args) (lambda (para*)
                                (append 
                                 para*
                                 (foldr (lambda (x d rst)
@@ -61,16 +73,14 @@
                                          ;; properly here and have default values
                                          ;; for everything. big-bang and universe
                                          ;; check already that defaults are provided. 
-                                         ; (displayln x)
-                                         ; (displayln d)
                                          (if d
                                              (append (list k `(,x ,d)) rst)
                                              (append (list k x) rst)))
                                        '() 
                                        kwds
                                        defs)))]
-                       [body (lambda (para*)
+                     [(body) (lambda (para*)
-                               (map (lambda (x) `(,x ,x)) (append para* kwds)))]]
+                               (map (lambda (x) `(,x ,x)) (append para* kwds)))])
                   (let ([para* (syntax->list #'(para (... ...)))])
                     #`(lambda (%)
                         (lambda #,(args  para*)
@@ -110,14 +120,11 @@
                 (list (mk-kwd key) (coercion (cdr x))))
               spec)))
 
-(define (tee x) (displayln 'tee) (displayln x) x)
-
 ;; Syntax -> Syntax 
 ;; eventually: convert syntax to keyword
 (define (mk-kwd key)
   (define key:id (symbol->string (syntax-e key)))
   (define key:wd (string->keyword key:id))
-  ;  (displayln key:wd)
   key:wd)
 
 ;; Symbol Syntax Syntax [Listof Kw] -> true

collects/2htdp/private/world.rkt

@@ -66,7 +66,8 @@
        (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))
+       (on-draw #f)
+       (to-draw #f)      ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
        (stop-when False) ;; World -> Boolean 
        (record? #f))     ;; Boolean 
       
@@ -135,12 +136,12 @@
       ;; -----------------------------------------------------------------------
       (field
        (draw   (cond
-                 [(procedure? on-draw) on-draw]
+                 [(procedure? to-draw) to-draw]
-                 [(pair? on-draw)      (first on-draw)]
+                 [(pair? to-draw)      (first to-draw)]
-                 [else on-draw]))
+                 [else to-draw]))
        (live   (not (boolean? draw)))
-       (width  (if (pair? on-draw) (second on-draw) #f))
+       (width  (if (pair? to-draw) (second to-draw) #f))
-       (height (if (pair? on-draw) (third on-draw) #f)))
+       (height (if (pair? to-draw) (third to-draw) #f)))
       
       ;; the visible world 
       (field [enable-images-button void] ;; used if stop-when call produces #t

collects/2htdp/tests/bad-draw.rkt

@@ -8,5 +8,5 @@
 (with-handlers ((exn? (lambda _ "success!")))
   (big-bang 0
             (on-tick (lambda (w) (begin (set! x (+ x 1)) w)))
-            (on-draw (lambda (w) (set! s (number->string w))))))
+            (to-draw (lambda (w) (set! s (number->string w))))))
           

collects/2htdp/universe.rkt

@@ -1,5 +1,7 @@
 #lang racket/gui
 
+;; DONT USE to-draw IN THIS FILE 
+
 #| TODO: 
    -- yield instead of sync
    -- run callbacks in user eventspace
@@ -9,8 +11,7 @@
    -- make window resizable :: why
 |#
 
-(require (only-in (for-syntax "private/syn-aux.ss") err ->args)
+(require (for-syntax "private/syn-aux.ss")
-         "private/keywords.rkt"
          "private/syn-aux-aux.ss" 
          "private/syn-aux.ss"
          "private/check-aux.ss"
@@ -22,8 +23,6 @@
          htdp/error
          (rename-in lang/prim (first-order->higher-order f2h)))
 
-(provide (all-from-out "private/keywords.rkt"))
-
 (define-primitive stop-with make-stop-the-world)
 
 (provide stop-with) ;; World -> STOP
@@ -38,6 +37,104 @@
  sexp?  ;; Any -> Boolean 
  )
 
+(define new-world (create-world world0))
+(define new-universe (create-universe universe0))
+
+(define-keywords AllSpec '() define-all
+  ;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
+  [on-tick   
+   DEFAULT #'#f
+   (function-with-arity
+    1 
+    except
+    [(_ f rate) 
+     #'(list 
+        (proc> 'on-tick (f2h f) 1)
+        (num> 'on-tick rate (lambda (x) (and (real? x) (positive? x)))
+              "positive number" "rate"))])]
+  ;; -- state specifies whether to display the current state 
+  [state
+   DEFAULT #'#f
+   (expr-with-check bool> "expected a boolean (show state or not)")]
+  ;; -- check-with must specify a predicate 
+  [check-with
+   DEFAULT #'True
+   (function-with-arity 1)])
+
+;  (create-world world0)
+(define-keywords WldSpec AllSpec create-world
+  ;; -- on-draw must specify a rendering function; it may specify dimensions
+  [on-draw to-draw
+           DEFAULT #'#f
+           (function-with-arity 
+            1 
+            except
+            [(_ f width height)
+             #'(list (proc> 'to-draw (f2h f) 1) 
+                     (nat> 'to-draw width "width")
+                     (nat> 'to-draw height "height"))])]
+  ;; -- on-mouse must specify a mouse event handler 
+  [on-mouse
+   DEFAULT #'K
+   (function-with-arity 4)]
+  ;; -- on-key must specify a key event handler 
+  [on-key
+   DEFAULT #'K
+   (function-with-arity 2)]
+  ;; -- on-release must specify a release event handler 
+  [on-release
+   DEFAULT #'K
+   (function-with-arity 2)]
+  ;; -- on-receive must specify a receive handler 
+  [on-receive
+   DEFAULT #'#f
+   (function-with-arity 2)]
+  ;; -- stop-when must specify a predicate; it may specify a rendering function
+  [stop-when
+   DEFAULT #'False
+   (function-with-arity 
+    1
+    except
+    [(_ stop? last-picture)
+     #'(list (proc> 'stop-when (f2h stop?) 1)
+             (proc> 'stop-when (f2h last-picture) 1))])]
+  ;; -- should the session be recorded and turned into PNGs and an animated GIF
+  [record?
+   DEFAULT #'#f
+   (expr-with-check bool> "expected a boolean (to record? or not)")]
+  [name
+   DEFAULT #'#f
+   (expr-with-check string> "expected a name (string) for the world")]
+  ;; -- register must specify the internet address of a host (e.g., LOCALHOST)
+  [register
+   DEFAULT #'#f
+   (expr-with-check ip> "expected a host (ip address)")])
+
+;  (create-universe universe0)
+(define-keywords UniSpec AllSpec create-universe
+  ;; -- on-new must specify what happens when a world joins the universe
+  [on-new 
+   DEFAULT #'"my-bad"
+   (function-with-arity 2)]
+  ;; -- on-msg must specify what happens to a message from a world 
+  [on-msg
+   DEFAULT #'"my-bad"
+   (function-with-arity 3)]
+  ;; -- on-disconnect may specify what happens when a world drops out
+  [on-disconnect
+   ;; ******************************************************************
+   DEFAULT #'(lambda (u w) (make-bundle u '() '()))
+   ;; this is the wrong default function 
+   ;; instead of K there should be a function that produces a bundle 
+   (function-with-arity 2)
+   ;; ******************************************************************
+   ]
+  ;; -- to-string specifies how to render the universe as a string for display
+  [to-string
+   DEFAULT #'#f
+   (function-with-arity 1)])
+
+
 ;                                     
 ;                                     
 ;                                     
@@ -137,13 +234,6 @@
              (->args 'big-bang stx #'w #'(clause ...) WldSpec ->rec? "world")])
        #`(run-it ((new-world (if #,rec? aworld% world%)) w #,@args)))]))
 
-(require (only-in 2htdp/image circle))
-(define (main) 
-  (big-bang 10
-            (on-tick sub1)
-            (stop-when zero?)
-            (to-draw (lambda (x) (circle (+ 30 x) 'solid 'red)))))
-
 (define (run-simulation f)
   (check-proc 'run-simulation f 1 "first" "one argument")
   (big-bang 1 (on-draw f) (on-tick add1)))