merged keywords back into universe

This commit is contained in:
Matthias Felleisen 2010-10-08 16:17:41 -04:00
parent 995ce61434
commit 58684bbf4e
4 changed files with 132 additions and 34 deletions

View File

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

View File

@ -66,7 +66,8 @@
(on-release K) ;; World KeyEvent -> World (on-release K) ;; World KeyEvent -> World
(on-mouse K) ;; World Nat Nat MouseEvent -> World (on-mouse K) ;; World Nat Nat MouseEvent -> World
(on-receive #f) ;; (U #f (World S-expression -> 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 (stop-when False) ;; World -> Boolean
(record? #f)) ;; Boolean (record? #f)) ;; Boolean
@ -135,12 +136,12 @@
;; ----------------------------------------------------------------------- ;; -----------------------------------------------------------------------
(field (field
(draw (cond (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))) (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 ;; the visible world
(field [enable-images-button void] ;; used if stop-when call produces #t (field [enable-images-button void] ;; used if stop-when call produces #t

View File

@ -8,5 +8,5 @@
(with-handlers ((exn? (lambda _ "success!"))) (with-handlers ((exn? (lambda _ "success!")))
(big-bang 0 (big-bang 0
(on-tick (lambda (w) (begin (set! x (+ x 1)) w))) (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))))))

View File

@ -1,5 +1,7 @@
#lang racket/gui #lang racket/gui
;; DONT USE to-draw IN THIS FILE
#| TODO: #| TODO:
-- yield instead of sync -- yield instead of sync
-- run callbacks in user eventspace -- run callbacks in user eventspace
@ -9,8 +11,7 @@
-- make window resizable :: why -- 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-aux.ss"
"private/syn-aux.ss" "private/syn-aux.ss"
"private/check-aux.ss" "private/check-aux.ss"
@ -22,8 +23,6 @@
htdp/error htdp/error
(rename-in lang/prim (first-order->higher-order f2h))) (rename-in lang/prim (first-order->higher-order f2h)))
(provide (all-from-out "private/keywords.rkt"))
(define-primitive stop-with make-stop-the-world) (define-primitive stop-with make-stop-the-world)
(provide stop-with) ;; World -> STOP (provide stop-with) ;; World -> STOP
@ -38,6 +37,104 @@
sexp? ;; Any -> Boolean 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")]) (->args 'big-bang stx #'w #'(clause ...) WldSpec ->rec? "world")])
#`(run-it ((new-world (if #,rec? aworld% world%)) w #,@args)))])) #`(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) (define (run-simulation f)
(check-proc 'run-simulation f 1 "first" "one argument") (check-proc 'run-simulation f 1 "first" "one argument")
(big-bang 1 (on-draw f) (on-tick add1))) (big-bang 1 (on-draw f) (on-tick add1)))