From 814a847323262813cd2382a020aaa152089b1501 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sat, 22 Jan 2011 12:06:18 -0500 Subject: [PATCH] made to-draw/on-draw in big-bang mandatory; Closes PR 11663 --- collects/2htdp/private/syn-aux.rkt | 40 +++--------- collects/2htdp/tests/server-rename.rkt | 8 +++ collects/2htdp/tests/world0-stops.rkt | 7 ++- collects/2htdp/tests/xtest | 2 + collects/2htdp/universe.rkt | 19 +++--- .../2htdp/scribblings/universe.scrbl | 61 +++++++++++-------- 6 files changed, 70 insertions(+), 67 deletions(-) create mode 100644 collects/2htdp/tests/server-rename.rkt diff --git a/collects/2htdp/private/syn-aux.rkt b/collects/2htdp/private/syn-aux.rkt index 8cf43796fe..36afb81c5f 100644 --- a/collects/2htdp/private/syn-aux.rkt +++ b/collects/2htdp/private/syn-aux.rkt @@ -7,7 +7,8 @@ ->args function-with-arity expr-with-check except err ->kwds-in - clauses-use-kwd) + clauses-use-kwd + contains-clause?) (require (for-syntax "syn-aux-aux.rkt" syntax/parse) @@ -45,21 +46,7 @@ [(_ para (... ...)) (let*-values ([(kwds defs) - (values (map car the-list) '()) - #; - (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))))))] + (values (map car the-list) '())] ;; the defaults list defs is no longer needed [(args) (lambda (para*) (append para* (foldr cons '() kwds)))] @@ -102,20 +89,11 @@ (syntax->list (cdar spec))] [else (loop (cdr spec))]))) (if r ((third s) r) (fourth s))) - Spec) - #; - (apply append - (map (lambda (x) - (define kw (car x)) - (define-values (key coercion) - (let loop ([kwds kwds][Spec Spec]) - (if (free-identifier=? (car kwds) kw) - ;; -- the original keyword, which is also the init-field name - ;; -- the coercion that comes with it - (values (cadar Spec) (caddar Spec)) - (loop (cdr kwds) (cdr Spec))))) - (list (mk-kwd key) (coercion (cdr x)))) - spec))) + Spec)) + +(define (contains-clause? kw clause-list) + (memf (lambda (clause) (free-identifier=? kw (car (syntax->list clause)))) clause-list)) + ;; Syntax -> Syntax ;; eventually: convert syntax to keyword @@ -147,7 +125,7 @@ (raise-syntax-error tag (format "duplicate ~a clause" id) (cdar x)) (duplicates? (rest lox))))]))) -;; check whether rec? occurs, produce list of keywords +;; check whether rec? occurs, produce list of keyword x clause pairs (define (clauses-use-kwd stx:list ->rec? legal-clause kwds) (define kwd-in? (->kwds-in kwds)) (define double (string-append legal-clause ", ~a has been redefined")) diff --git a/collects/2htdp/tests/server-rename.rkt b/collects/2htdp/tests/server-rename.rkt new file mode 100644 index 0000000000..34ddb6e47c --- /dev/null +++ b/collects/2htdp/tests/server-rename.rkt @@ -0,0 +1,8 @@ +#lang racket +(require (prefix-in uni: 2htdp/universe)) + +(define (server) + (uni:universe 0 + (uni:on-new cons) + (uni:on-msg list) + (uni:on-tick add1))) diff --git a/collects/2htdp/tests/world0-stops.rkt b/collects/2htdp/tests/world0-stops.rkt index 828a602cf5..51749bc7e0 100644 --- a/collects/2htdp/tests/world0-stops.rkt +++ b/collects/2htdp/tests/world0-stops.rkt @@ -3,11 +3,14 @@ #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) (require 2htdp/universe) +(require 2htdp/image) + +(define draw (lambda (x) (circle 3 'solid 'red))) "does big-bang stop when the initial world is already a final world?" -(big-bang 0 (stop-when zero?) (on-tick add1)) +(big-bang 0 (stop-when zero?) (on-tick add1) (to-draw draw)) "does big bang stop when the initial world is a stop world?" -(big-bang (stop-with 0) (on-tick add1)) +(big-bang (stop-with 0) (on-tick add1) (to-draw draw)) (define-struct stop (x)) diff --git a/collects/2htdp/tests/xtest b/collects/2htdp/tests/xtest index ca0208589e..2e9da1fb54 100755 --- a/collects/2htdp/tests/xtest +++ b/collects/2htdp/tests/xtest @@ -28,6 +28,8 @@ gracket test-image.rkt echo "done:--- test-image.rkt ---" echo "" gracket ufo-rename.rkt echo "done:--- ufo-rename.rkt ---" echo "" +gracket server-rename.rkt +echo "done:--- server-rename.rkt ---" echo "" gracket world0-stops.rkt echo "done:--- world0-stops.rkt ---" echo "" gracket record.rkt diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index 9c7b47815e..e9514bf968 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -226,10 +226,15 @@ [(V) (set! rec? #'V)] [_ (err '#'record? stx)])))] [args - (->args 'big-bang stx #'w #'(clause ...) WldSpec ->rec? "world")]) - (stepper-syntax-property - #`(run-it ((new-world (if #,rec? aworld% world%)) w #,@args)) - 'stepper-skip-completely #t))])) + (->args 'big-bang stx #'w #'(clause ...) WldSpec ->rec? "world")] + [dom (syntax->list #'(clause ...))]) + (cond + [(and (not (contains-clause? #'to-draw dom)) (not (contains-clause? #'on-draw dom))) + (raise-syntax-error #f "missing to-draw clause" stx)] + [else + (stepper-syntax-property + #`(run-it ((new-world (if #,rec? aworld% world%)) w #,@args)) + 'stepper-skip-completely #t)]))])) (define (run-simulation f) (check-proc 'run-simulation f 1 "first" "one argument") @@ -310,11 +315,11 @@ [(universe u bind ...) (let* ([args (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")] - [dom (map (compose car syntax->datum) (syntax->list #'(bind ...)))]) + [dom (syntax->list #'(bind ...))]) (cond - [(not (memq 'on-new dom)) + [(not (contains-clause? #'on-new dom)) (raise-syntax-error #f "missing on-new clause" stx)] - [(not (memq 'on-msg dom)) + [(not (contains-clause? #'on-msg dom)) (raise-syntax-error #f "missing on-msg clause" stx)] [else ; (and (memq #'on-new dom) (memq #'on-msg dom)) #`(run-it ((new-universe universe%) u #,@args))]))])) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 91a58c897e..3e1493215c 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -189,6 +189,40 @@ The design of a world program demands that you come up with a data closes the canvas. } +The only mandatory clause of a @scheme[big-bang] description is +@scheme[to-draw] (or @scheme[on-draw] for backwards compatibility): +@itemize[ + +@item{ + +@defform[(to-draw render-expr) + #:contracts + ([render-expr (-> (unsyntax @tech{WorldState}) scene?)])]{ + + tells DrRacket to call the function @scheme[render-expr] whenever the + canvas must be drawn. The external canvas is usually re-drawn after DrRacket has + dealt with an event. Its size is determined by the size of the first + generated @tech{scene}.} + +@defform/none[#:literals (to-draw) + (to-draw render-expr width-expr height-expr) + #:contracts + ([render-expr (-> (unsyntax @tech{WorldState}) scene?)] + [width-expr natural-number/c] + [height-expr natural-number/c])]{ + + tells DrRacket to use a @scheme[width-expr] by @scheme[height-expr] + canvas instead of one determine by the first generated @tech{scene}. +} + +For compatibility reasons, the teachpack also supports the keyword +@defidform/inline[on-draw] in lieu of @scheme[to-draw] but the latter is preferred +now. +} + +] + +All remaining clauses are optional: @itemize[ @item{ @@ -393,33 +427,6 @@ All @tech{MouseEvent}s are represented via strings: signals most of them.} } -@item{ - -@defform[(to-draw render-expr) - #:contracts - ([render-expr (-> (unsyntax @tech{WorldState}) scene?)])]{ - - tells DrRacket to call the function @scheme[render-expr] whenever the - canvas must be drawn. The external canvas is usually re-drawn after DrRacket has - dealt with an event. Its size is determined by the size of the first - generated @tech{scene}.} - -@defform/none[#:literals (to-draw) - (to-draw render-expr width-expr height-expr) - #:contracts - ([render-expr (-> (unsyntax @tech{WorldState}) scene?)] - [width-expr natural-number/c] - [height-expr natural-number/c])]{ - - tells DrRacket to use a @scheme[width-expr] by @scheme[height-expr] - canvas instead of one determine by the first generated @tech{scene}. -} - -For compatibility reasons, the teachpack also supports the keyword -@defidform/inline[on-draw] in lieu of @scheme[to-draw] but the latter is preferred -now. -} - @item{ @defform[(stop-when last-world?)