diff --git a/collects/2htdp/private/keywords.rkt b/collects/2htdp/private/keywords.rkt new file mode 100644 index 0000000000..9d1cda4005 --- /dev/null +++ b/collects/2htdp/private/keywords.rkt @@ -0,0 +1,63 @@ +#lang racket + +(require (for-syntax "syn-aux.ss") "syn-aux.ss" + "syn-aux-aux.ss" + (rename-in lang/prim (first-order->higher-order f2h))) + +(provide (for-syntax AllSpec WldSpec UniSpec)) + +(define-keywords AllSpec + ;; -- on-tick must specify a tick handler; it may specify a clock-tick rate + [on-tick (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 (expr-with-check bool> "expected a boolean (show state or not)")] + ;; -- check-with must specify a predicate + [check-with (function-with-arity 1)]) + +(define-keywords WldSpec + ;; -- on-draw must specify a rendering function; it may specify dimensions + [on-draw to-draw + (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 (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 + [stop-when (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? (expr-with-check bool> "expected a boolean (to record? or not)")] + [name (expr-with-check string> "expected a name (string) for the world")] + ;; -- register must specify the internet address of a host (e.g., LOCALHOST) + [register (expr-with-check ip> "expected a host (ip address)")]) + +(define-keywords UniSpec + ;; -- on-new must specify what happens when a world joins the universe + [on-new (function-with-arity 2)] + ;; -- on-msg must specify what happens to a message from a world + [on-msg (function-with-arity 3)] + ;; -- on-disconnect may specify what happens when a world drops out + [on-disconnect (function-with-arity 2)] + ;; -- to-string specifies how to render the universe as a string for display + [to-string (function-with-arity 1)]) \ No newline at end of file diff --git a/collects/2htdp/private/syn-aux.rkt b/collects/2htdp/private/syn-aux.rkt index ef78916ece..30c569171c 100644 --- a/collects/2htdp/private/syn-aux.rkt +++ b/collects/2htdp/private/syn-aux.rkt @@ -78,9 +78,17 @@ ;; -- the coercion that comes with it (values (cadar Spec) (caddar Spec)) (loop (cdr kwds) (cdr Spec))))) - (list key (coercion (cdr x)))) + (list (mk-kwd key) (coercion (cdr x)))) spec)) +;; 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) + ;; Symbol Syntax Syntax [Listof Kw] -> true ;; effect: if state0 looks like a clause, raise special error (define (not-a-clause tag stx state0 kwds) diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index e652bee7be..1f53ab6a29 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -9,7 +9,8 @@ -- make window resizable :: why |# -(require (for-syntax "private/syn-aux.ss" scheme/function) +(require (only-in (for-syntax "private/syn-aux.ss") err ->args) + "private/keywords.rkt" "private/syn-aux-aux.ss" "private/syn-aux.ss" "private/check-aux.ss" @@ -35,21 +36,6 @@ sexp? ;; Any -> Boolean ) -(define-keywords AllSpec - ;; -- on-tick must specify a tick handler; it may specify a clock-tick rate - [on-tick (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 (expr-with-check bool> "expected a boolean (show state or not)")] - ;; -- check-with must specify a predicate - [check-with (function-with-arity 1)]) - ; ; ; @@ -133,37 +119,6 @@ "wheel-up" "wheel-down")) -(define-keywords WldSpec - ;; -- on-draw must specify a rendering function; it may specify dimensions - [on-draw to-draw - (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 (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 - [stop-when (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? (expr-with-check bool> "expected a boolean (to record? or not)")] - [name (expr-with-check string> "expected a name (string) for the world")] - ;; -- register must specify the internet address of a host (e.g., LOCALHOST) - [register (expr-with-check ip> "expected a host (ip address)")]) - (define-syntax (big-bang stx) (define world0 "big-bang needs at least an initial world") (syntax-case stx () @@ -257,16 +212,6 @@ universe ;; : see below ) -(define-keywords UniSpec - ;; -- on-new must specify what happens when a world joins the universe - [on-new (function-with-arity 2)] - ;; -- on-msg must specify what happens to a message from a world - [on-msg (function-with-arity 3)] - ;; -- on-disconnect may specify what happens when a world drops out - [on-disconnect (function-with-arity 2)] - ;; -- to-string specifies how to render the universe as a string for display - [to-string (function-with-arity 1)]) - (define-syntax (universe stx) (define legal "not a legal clause in a universe description") (syntax-case stx ()