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

universe in line with syntax-parse

Browse Source
This commit is contained in:
Matthias Felleisen 2010-05-09 19:33:25 -04:00
parent ed1d7f81c9
commit 461c39b979
1 changed files with 32 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
collects/2htdp/universe-syntax-parse.rkt
View File

@ -9,32 +9,42 @@
(printf "a positive number")
rate0)
;; String String Syntax[id] -> Syntax
(define (pre-post-name pre post name)
;; Syntax String String Syntax[id] -> Syntax
(define (pre-post-name stx pre post name)
(datum->syntax
name (string->symbol (string-append pre (symbol->string (syntax-e name)) post))))
(provide (all-defined-out)))
(module clauses scheme
(provide (all-defined-out))
(require syntax/parse (for-syntax scheme 'auxs unstable/syntax)
(define-syntax-rule
(define-kwd name)
(begin
(provide name)
(define-syntax (name . x)
(raise-syntax-error 'name "used out of context" x))))
(define-kwd on-tick)
(define-kwd on-mouse))
(module clauses scheme
(require syntax/parse 'auxs
(for-syntax scheme 'auxs unstable/syntax)
(for-template scheme/base 'auxs))
(provide define-clause)
(define-syntax (define-clause stx)
(syntax-case stx ()
[(_ name (proc p-ctc) (rate r-ctc) ...)
(with-syntax ([name-clause (pre-post-name "" "-clause" #'name)]
(with-syntax ([name-clause (pre-post-name stx "" "-clause" #'name)]
[(rate0 ...) (generate-temporaries #'(rate ...))])
(with-syntax ([((thing ...) ...) #'((#:with rate #'(r-ctc rate0)) ...)])
#`
(begin
(provide name name-clause)
(define-syntax (name . x)
(raise-syntax-error 'name "used out of context" x))
(define-syntax-class name-clause
#:description (format "~a" 'name)
#:literals (name)
@ -43,75 +53,33 @@
#:with (rate0 ...) (map (lambda (x) #'0) '(rate0 ...))
#:with proc #'(world->world proc0)
thing ... ...)
(pattern (on-tick proc0:expr (~var rate0 expr) ...)
(pattern (name proc0:expr (~var rate0 expr) ...)
#:with proc #'(world->world> proc0)
thing ... ...))
)))]))
(define-clause on-mouse (proc world-nat-nat-mouse->world))
(define-clause on-tick (proc world->world) (rate (lambda (x) 1/28)))
;; --- on-tick ---
#|
(define-syntax (on-tick . x)
(raise-syntax-error 'on-tick "used out of context" x))
(define-syntax-class on-tick-clause
#:description "on tick"
#:literals (on-tick)
#:attributes (proc rate)
(pattern (on-tick proc0:expr)
#:with proc #'(world->world proc0)
#:with rate #'1/28)
(pattern (on-tick proc0:expr rate0:expr)
#:with proc #'(world->world> proc0)
#:with rate #'(positive-number> rate0)))
(provide on-tick on-tick-clause)
|#
;; --- on-draw ---
(define-syntax (on-draw . x)
(raise-syntax-error 'on-draw "used out of context" x))
(define-syntax-class on-draw-clause
#:description "on draw"
#:literals (on-draw)
#:attributes (proc width height)
(pattern (on-draw proc0:expr)
#:with proc #'(wrap worldxkey->world proc0)
#:with width #'#f
#:with height #'#f)
(pattern (on-draw proc0:expr width0:expr height0:expr)
#:with proc #'(worldxkey->world> proc0)
#:with width #'(natural-number> width0)
#:with height #'(natural-number> height0)))
(provide on-draw on-draw-clause))
(define-clause on-tick (proc world->world))
)
(module utest scheme
(require (for-syntax syntax/parse 'clauses))
(require 'clauses (for-syntax 'clauses syntax/parse) (for-template 'clauses))
(define-syntax (big-bang stx)
(syntax-parse stx
[(big-bang world0:expr
(~or (~optional otc:on-tick-clause)
; (~optional omc:on-mouse-clause)
(~optional odc:on-draw-clause))
(~or (~optional otk:on-tick-clause)
(~optional omc:on-mouse-clause))
...)
#`(printf "~s\n"
'(bb world0
#,(if (attribute otc)
#'otc.rate
#'1/28)
#,(if (attribute odc)
#'odc.proc
#''not-draw)))]))
#,(if (attribute omc) "mouse" "no mouse")
#,(if (attribute otk) "tick" "no tick")))]))
(big-bang 0)
(big-bang 1 (on-tick add1))
(big-bang 2 (on-tick add1 1/2))
(big-bang 3 (on-draw add1 1/2 1/3))
; (big-bang 4 (on-mouse add1 1 2))
(big-bang 0)
(big-bang 1 (on-tick +) (on-mouse -))
(big-bang 2 (on-tick +))
(big-bang 3 (on-mouse +))
)
(require 'utest)