suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merged keywords back into universe

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/2htdp/private/syn-aux.rkt
View File

@ -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

13
collects/2htdp/private/world.rkt
View File

@ -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

4
collects/2htdp/tests/bad-draw.rkt
View File

@ -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))))))

112
collects/2htdp/universe.rkt
View File

@ -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)))