From 58684bbf4e675095d8dfdaed538f8b8af19ec9e6 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 8 Oct 2010 16:17:41 -0400 Subject: [PATCH] merged keywords back into universe --- collects/2htdp/private/syn-aux.rkt | 37 ++++++---- collects/2htdp/private/world.rkt | 13 ++-- collects/2htdp/tests/bad-draw.rkt | 4 +- collects/2htdp/universe.rkt | 112 ++++++++++++++++++++++++++--- 4 files changed, 132 insertions(+), 34 deletions(-) diff --git a/collects/2htdp/private/syn-aux.rkt b/collects/2htdp/private/syn-aux.rkt index 4300136f66..e91f9e31a4 100644 --- a/collects/2htdp/private/syn-aux.rkt +++ b/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,10 +31,9 @@ ;; define and create list of keywords and associated values (define-for-syntax the-list (append super-list - (list - (list #'kw #'kw (coerce ''kw) default) - #; - (list #'kw-alt #'kw (coerce ''kw-alt) default)) + (list (list #'kw #'kw-alt (coerce ''kw) default) + #; + (list #'kw-alt #'kw (coerce ''kw-alt) default)) ...)) ;; define and provide keywords (provide (rename-out (kw kw-alt) ...)) @@ -47,9 +46,22 @@ (define-syntax (define-create stx) (syntax-case stx () [(_ para (... ...)) - (let* [[kwds (map cadr the-list)] - [defs (map cadddr the-list)] - [args (lambda (para*) + (let*-values + ([(kwds defs) + (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*) - (map (lambda (x) `(,x ,x)) (append para* kwds)))]] + [(body) (lambda (para*) + (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 diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index 6a70974348..26be54e93b 100644 --- a/collects/2htdp/private/world.rkt +++ b/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] - [(pair? on-draw) (first on-draw)] - [else on-draw])) + [(procedure? to-draw) to-draw] + [(pair? to-draw) (first to-draw)] + [else to-draw])) (live (not (boolean? draw))) - (width (if (pair? on-draw) (second on-draw) #f)) - (height (if (pair? on-draw) (third on-draw) #f))) + (width (if (pair? to-draw) (second to-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 diff --git a/collects/2htdp/tests/bad-draw.rkt b/collects/2htdp/tests/bad-draw.rkt index a1c9730dd8..793cbdab91 100644 --- a/collects/2htdp/tests/bad-draw.rkt +++ b/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)))))) - \ No newline at end of file + (to-draw (lambda (w) (set! s (number->string w)))))) + diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index 83e61c614b..28ae05bdd6 100644 --- a/collects/2htdp/universe.rkt +++ b/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) - "private/keywords.rkt" +(require (for-syntax "private/syn-aux.ss") "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)))