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

adjusting big-bang and universe so that they call functions and don't expand into object construction

Browse Source
This commit is contained in:
Matthias Felleisen 2010-10-07 18:49:17 -04:00
parent db0046101c
commit 8ef896431a
8 changed files with 305 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/2htdp/private/check-aux.rkt
View File

@ -1,5 +1,4 @@
#lang scheme
#lang racket
(require htdp/error)

111
collects/2htdp/private/keywords.rkt
View File

@ -1,29 +1,40 @@
#lang racket
(require (for-syntax "syn-aux.ss") "syn-aux.ss"
(require (for-syntax "syn-aux.ss")
"syn-aux.ss"
"syn-aux-aux.ss"
"check-aux.rkt"
(only-in "universe.rkt" make-bundle)
(rename-in lang/prim (first-order->higher-order f2h)))
(provide (for-syntax AllSpec WldSpec UniSpec))
(provide [for-syntax WldSpec UniSpec])
(define-keywords AllSpec
(define-keywords AllSpec '() define-all
;; -- 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"))])]
[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 (expr-with-check bool> "expected a boolean (show state or not)")]
[state
DEFAULT #'#f
(expr-with-check bool> "expected a boolean (show state or not)")]
;; -- check-with must specify a predicate
[check-with (function-with-arity 1)])
[check-with
DEFAULT #'True
(function-with-arity 1)])
(define-keywords WldSpec
; (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
@ -32,32 +43,68 @@
(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-mouse
DEFAULT #'K
(function-with-arity 4)]
;; -- on-key must specify a key event handler
[on-key (function-with-arity 2)]
[on-key
DEFAULT #'K
(function-with-arity 2)]
;; -- on-release must specify a release event handler
[on-release (function-with-arity 2)]
[on-release
DEFAULT #'K
(function-with-arity 2)]
;; -- on-receive must specify a receive handler
[on-receive (function-with-arity 2)]
[on-receive
DEFAULT #'#f
(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))])]
[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? (expr-with-check bool> "expected a boolean (to record? or not)")]
[name (expr-with-check string> "expected a name (string) for the world")]
[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 (expr-with-check ip> "expected a host (ip address)")])
[register
DEFAULT #'#f
(expr-with-check ip> "expected a host (ip address)")])
(define-keywords UniSpec
; (create-universe universe0)
(define-keywords UniSpec AllSpec create-universe
;; -- on-new must specify what happens when a world joins the universe
[on-new (function-with-arity 2)]
[on-new
DEFAULT #'"my-bad"
(function-with-arity 2)]
;; -- on-msg must specify what happens to a message from a world
[on-msg (function-with-arity 3)]
[on-msg
DEFAULT #'"my-bad"
(function-with-arity 3)]
;; -- on-disconnect may specify what happens when a world drops out
[on-disconnect (function-with-arity 2)]
[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 (function-with-arity 1)])
[to-string
DEFAULT #'#f
(function-with-arity 1)])
(provide new-world)
(define new-world (create-world world0))
(provide new-universe)
(define new-universe (create-universe universe0))

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

@ -1,6 +1,6 @@
#lang scheme
#lang racket
(require htdp/error)
(require htdp/error "check-aux.rkt")
;
;

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

@ -1,53 +1,82 @@
#lang scheme
#lang racket
(provide define-keywords
;; (define-keywords (name1:identifier ... spec:expr) ...)
;; constraint: the first name is the original name
DEFAULT
;; constraint: the first kw is the original one
;; and it is also the name of the field in the class
function-with-arity expr-with-check except err
->args
function-with-arity expr-with-check except err
->kwds-in
clauses-use-kwd)
(require
(for-template "syn-aux-aux.ss"
scheme
(for-syntax "syn-aux-aux.rkt" syntax/parse)
(for-template "syn-aux-aux.rkt"
racket
(rename-in lang/prim (first-order->higher-order f2h))))
(require (for-syntax syntax/parse))
(define-syntax (define-keywords stx)
(syntax-parse stx
[(define-keywords the-list (kw:identifier ... coerce:expr) ...)
#'(begin
(provide kw ...) ...
(define-syntaxes (kw ...)
(values (lambda (x)
(raise-syntax-error 'kw "used out of context" x))
...))
...
(define-for-syntax the-list
(apply append
(list
(let* ([x (list (list #'kw ''kw) ...)]
[f (caar x)])
(map (lambda (x)
(define clause-name (car x))
(define clause-spec (cadr x))
(list clause-name f (coerce clause-spec)))
x))
...))))]))
(define-syntax (DEFAULT stx)
(raise-syntax-error 'DEFAULT "used out of context" stx))
#;
(define-syntax-rule
(define-keywords the-list (kw coerce) ...)
(begin
(provide kw ...)
(define-syntax kw
(lambda (x)
(raise-syntax-error 'kw "used out of context" x)))
...
(define-for-syntax the-list
(list (list #'kw (coerce ''kw)) ...))))
(define-syntax (define-keywords stx)
(syntax-parse stx #:literals (DEFAULT)
[(_ the-list super-list define-create
(kw:identifier
(~optional kw-alt:identifier
#:defaults ((kw-alt (datum->syntax stx (gensym)))))
(~optional (~seq DEFAULT default:expr))
coerce:expr) ...)
(let* ([defs (attribute default)])
#`(begin
;; 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))
...))
;; define and provide keywords
(provide (rename-out (kw kw-alt) ...))
(provide kw ...)
(define-syntaxes (kw ...)
(values (lambda (x)
(raise-syntax-error 'kw "used out of context" x))
...))
(define-syntax (define-create stx)
(syntax-case stx ()
[(_ para (... ...))
(let* [[kwds (map cadr the-list)]
[defs (map cadddr the-list)]
[args (lambda (para*)
(append
para*
(foldr (lambda (x d rst)
(define k (string->keyword
(symbol->string
(syntax-e x))))
;; This 'if' doesn't work because
;; I don't know how to use 'attribute'
;; 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)))]]
(let ([para* (syntax->list #'(para (... ...)))])
#`(lambda (%)
(lambda #,(args para*)
(lambda ()
(define o (new % #,@(body para*)))
o)))))]))))]))
#|
transform the clauses into the initial arguments specification
@ -62,24 +91,26 @@
if anything fails, use the legal keyword to specialize the error message
|#
(define (->args tag stx state0 clauses AllSpec PartSpec ->rec? legal)
(define (->args tag stx state0 clauses Spec ->rec? legal)
(define msg (format "not a legal clause in a ~a description" legal))
(define Spec (append AllSpec PartSpec))
(define kwds (map (compose (curry datum->syntax stx) car) Spec))
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
(duplicates? tag spec)
(not-a-clause tag stx state0 kwds)
(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))
(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)))
(define (tee x) (displayln 'tee) (displayln x) x)
;; Syntax -> Syntax
;; eventually: convert syntax to keyword
@ -87,7 +118,7 @@
(define key:id (symbol->string (syntax-e key)))
(define key:wd (string->keyword key:id))
; (displayln key:wd)
key)
key:wd)
;; Symbol Syntax Syntax [Listof Kw] -> true
;; effect: if state0 looks like a clause, raise special error

33
collects/2htdp/private/timer.rkt
View File

@ -1,33 +1,32 @@
#lang scheme/gui
#lang racket/gui
;; The module provides a timer mixing for world and universe.
;; The interface ensures that super class provides start and stop method,
;; plus a call back for clock ticks. The super-init call provides the
;; on-tick parameter, which the super-class uses to define the callback.
;; The interface ensures that super class provides start and stop method,
;; BUT if fails to ensure that the class comes with a _tick_ field.
;; plus a call back for clock ticks. The super-init call sets the
;; tick field, which the super-class uses to define the callback.
(require "check-aux.ss")
(provide clock-mixin start-stop<%>)
(define start-stop<%> (interface () start! ptock stop!))
;; T = (U (World -> World) (list (World -> World) Nat))
;; X [(list (World -> World) Nat) -> X] [(World -> World) -> X] -> [T -> X]
(define (selector default lchoice pchoice)
(lambda (on-tick)
(cond
[(cons? on-tick) (lchoice on-tick)]
[(procedure? on-tick) (pchoice on-tick)]
[else default])))
(define start-stop<%> (interface () start! ptock pptock stop!))
(define clock-mixin
(mixin (start-stop<%>) ()
(inherit ptock)
(init-field [on-tick #f])
(field [rate ((selector 0 second (lambda _ RATE)) on-tick)]
(field [rate 0]
[tick void]
[timer (new timer% [notify-callback (lambda () (ptock))])])
(cond
[(cons? on-tick) (set! rate (second on-tick))
(set! tick (first on-tick))]
[(procedure? on-tick) (set! rate RATE)
(set! tick on-tick)]
[else (void)])
(define/override (start!)
(unless (<= rate 0)
(send timer start (number->integer (* 1000 rate) 'big-bang/universe 'clock-rate)))
@ -35,4 +34,6 @@
(define/override (stop! w)
(send timer stop)
(super stop! w))
(super-new [tick ((selector void first (lambda (x) x)) on-tick)])))
(define/override (pptock w)
(tick w))
(super-new)))

14
collects/2htdp/private/universe.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/gui
#lang racket/gui
(require (for-syntax "syn-aux.ss")
"checked-cell.ss"
@ -30,14 +30,16 @@
(define universe%
(last-mixin
(clock-mixin
(class* object% (start-stop<%>) (inspect #f) (super-new)
(class* object% (start-stop<%>)
(inspect #f)
(super-new)
(init-field ;; type Result
; = (make-bundle [Listof World] Universe [Listof Mail])
universe0 ;; the initial state of the universe
on-new ;; Universe World -> Result
on-msg ;; Universe World Message -> Result
tick ;; Universe -> Result
(state #f) ;; Boolean
;; tick ;; Universe -> Result
(state #f) ;; Boolean
(on-disconnect ;; Universe World -> Result
(lambda (u w) (make-bundle u '() '())))
(to-string #f) ;; Universe -> String
@ -98,7 +100,9 @@
(def/cback private (pdisconnect iworld) on-disconnect
(kill iworld))
(def/cback public (ptock) tick)
;; tick, tock : deal with a tick event for this world
(def/cback pubment (ptock) (lambda (w) (pptock w)))
(define/public (pptock w) (void))
;; IWorld -> Void
;; effect: remove from given iworld from iworlds

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

@ -6,7 +6,8 @@
"checked-cell.ss"
"stop.ss"
"universe-image.ss"
"utilities.rkt"
; "utilities.rkt"
"keywords.rkt"
htdp/error
mzlib/runtime-path
mrlib/bitmap-label
@ -58,7 +59,7 @@
(state #f) ;; Boolean
(register #f) ;; (U #f IP)
(check-with True) ;; Any -> Boolean
(tick K)) ;; (U (World -> World) (list (World -> World) Nat))
)
(init
(on-key K) ;; World KeyEvent -> World
@ -227,74 +228,77 @@
(define draw# 0)
(set-draw#!)
(define-syntax-rule (def/pub-cback (name arg ...) transform)
(define-syntax-rule
(def/cback pub (name arg ...) transform)
;; Any ... -> Boolean
(define/public (name arg ...)
(queue-callback
(lambda ()
(with-handlers ([exn? (handler #t)])
(define tag (format "~a callback" 'transform))
(define nw (transform (send world get) arg ...))
(define (d) (pdraw) (set-draw#!))
;; ---
;; [Listof (Box [d | void])]
(define w '())
;; set all to void, then w to null
;; when a high priority draw is scheduledd
;; ---
(when (package? nw)
(broadcast (package-message nw))
(set! nw (package-world nw)))
(if (stop-the-world? nw)
(begin
(set! nw (stop-the-world-world nw))
(send world set tag nw)
(when last-picture
(set! draw last-picture))
(when draw (pdraw))
(callback-stop! 'name)
(enable-images-button))
(let ([changed-world? (send world set tag nw)])
;; this is the old "Robby optimization" see checked-cell:
; unless changed-world?
(when draw
(cond
[(not drawing)
(set! drawing #t)
(let ([b (box d)])
(set! w (cons b w))
;; low priority, otherwise it's too fast
(queue-callback (lambda () ((unbox b))) #f))]
[(< draw# 0)
(set-draw#!)
(for-each (lambda (b) (set-box! b void)) w)
(set! w '())
;; high!! the scheduled callback didn't fire
(queue-callback (lambda () (d)) #t)]
[else
(set! draw# (- draw# 1))]))
(when (pstop)
(when last-picture
(set! draw last-picture)
(pdraw))
(begin
(define/public (name arg ...)
(queue-callback
(lambda ()
(with-handlers ([exn? (handler #t)])
(define tag (format "~a callback" 'transform))
(define nw (transform (send world get) arg ...))
(define (d) (pdraw) (set-draw#!))
;; ---
;; [Listof (Box [d | void])]
(define w '())
;; set all to void, then w to null
;; when a high priority draw is scheduledd
;; ---
(when (package? nw)
(broadcast (package-message nw))
(set! nw (package-world nw)))
(if (stop-the-world? nw)
(begin
(set! nw (stop-the-world-world nw))
(send world set tag nw)
(when last-picture
(set! draw last-picture))
(when draw (pdraw))
(callback-stop! 'name)
(enable-images-button))
changed-world?)))))))
(let ([changed-world? (send world set tag nw)])
;; this is the old "Robby optimization" see checked-cell:
; unless changed-world?
(when draw
(cond
[(not drawing)
(set! drawing #t)
(let ([b (box d)])
(set! w (cons b w))
;; low priority, otherwise it's too fast
(queue-callback (lambda () ((unbox b))) #f))]
[(< draw# 0)
(set-draw#!)
(for-each (lambda (b) (set-box! b void)) w)
(set! w '())
;; high!! the scheduled callback didn't fire
(queue-callback (lambda () (d)) #t)]
[else
(set! draw# (- draw# 1))]))
(when (pstop)
(when last-picture
(set! draw last-picture)
(pdraw))
(callback-stop! 'name)
(enable-images-button))
changed-world?))))))))
;; tick, tock : deal with a tick event for this world
(def/pub-cback (ptock) tick)
(def/cback pubment (ptock) (lambda (w) (pptock w)))
(define/public (pptock w) (void))
;; key events
(def/pub-cback (pkey ke) key)
(def/cback pubment (pkey ke) key)
;; release events
(def/pub-cback (prelease ke) release)
(def/cback pubment (prelease ke) release)
;; mouse events
(def/pub-cback (pmouse x y me) mouse)
(def/cback pubment (pmouse x y me) mouse)
;; receive revents
(def/pub-cback (prec msg) rec)
(def/cback pubment (prec msg) rec)
;; ----------------------------------------------------------------------
;; -> Void
@ -348,6 +352,8 @@
[(stop-the-world? w)
(stop! (stop-the-world-world (send world get)))]))))))
; (define make-new-world (new-world world%))
;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png"))
(define break-button:label
@ -391,15 +397,18 @@
(set! event-history (cons (cons type stuff) event-history)))
;; --- new callbacks ---
(define-syntax-rule (def/over-cb (pname name arg ...))
(define/override (pname arg ...)
(when (super pname arg ...) (add-event name arg ...))))
(define-syntax-rule
(def/cb ovr (pname name arg ...))
(begin
; (ovr pname)
(define/override (pname arg ...)
(when (super pname arg ...) (add-event 'name arg ...)))))
(def/over-cb (ptock tick))
(def/over-cb (pkey key e))
(def/over-cb (prelease release e))
(def/over-cb (pmouse mouse x y me))
(def/over-cb (prec rec m))
(def/cb augment (ptock tick))
(def/cb augment (pkey key e))
(def/cb augment (prelease release e))
(def/cb augment (pmouse mouse x y me))
(def/cb augment (prec rec m))
;; --> Void
;; re-play the history of events; create a png per step; create animated gif

54
collects/2htdp/universe.rkt
View File

@ -134,13 +134,15 @@
[(V) (set! rec? #'V)]
[_ (err '#'record? stx)])))]
[args
(->args 'big-bang stx (syntax w) (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
#`(let* ([esp (make-eventspace)]
[thd (eventspace-handler-thread esp)])
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
(parameterize ([current-eventspace esp])
(let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)])
(send o last))))))]))
(->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")
@ -215,23 +217,45 @@
)
(define-syntax (universe stx)
(define legal "not a legal clause in a universe description")
(syntax-case stx ()
[(universe) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u bind ...)
(let*
([args (->args 'universe stx (syntax u) (syntax (bind ...)) AllSpec UniSpec void "universe")]
[domain (map (compose syntax-e car) args)])
([args (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
[domain (map (lambda (x)
(if (keyword? x)
(string->symbol (keyword->string x))
x))
args)])
(cond
[(not (memq 'on-new domain))
(raise-syntax-error #f "missing on-new clause" stx)]
[(not (memq 'on-msg domain))
(raise-syntax-error #f "missing on-msg clause" stx)]
[else ; (and (memq #'on-new domain) (memq #'on-msg domain))
#`(let* ([esp (make-eventspace)]
[thd (eventspace-handler-thread esp)])
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
(parameterize ([current-eventspace esp])
(send (new universe% [universe0 u] #,@args) last))))]))]))
#`(run-it ((new-universe universe%) u #,@args))]))]))
;
;
;
; ; ;;;
; ;
; ;;; ;; ;; ;;;;;; ;; ;;; ;;;;
; ; ;; ; ; ;; ; ;
; ; ; ; ; ; ;;;;;
; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;;
; ;;;;; ;;; ;;; ;;;;;; ;;;;; ;;; ;;
;
;
;
;
;; (-> Object) -> Any
(define (run-it o)
(define esp (make-eventspace))
(define thd (eventspace-handler-thread esp))
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
(parameterize ([current-eventspace esp])
(send (o) last))))