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

optional limit for number of ticks

Browse Source
This commit is contained in:
Matthias Felleisen 2011-07-16 13:59:17 -04:00
parent 75c1aa5f4d
commit 59499b84bd
9 changed files with 104 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/2htdp/private/clauses-spec-and-process.rkt
View File

@ -36,12 +36,12 @@
(syntax-case p ()
[(_ x) #`(proc> #,tag (f2h x) arity)]
[_ (err tag p)])))]
[(_ arity except extra)
[(_ arity except extra ...)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(_ x) #`(proc> #,tag (f2h x) arity)]
extra
extra ...
[_ (err tag p)])))]))
(define (err spec p . xtras)

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

@ -8,7 +8,7 @@
;; tick field, which the super-class uses to define the callback.
(require "check-aux.rkt")
(require "check-aux.rkt" "stop.rkt")
(provide clock-mixin start-stop<%>)
@ -19,13 +19,21 @@
(inherit ptock)
(init-field [on-tick #f])
(field [rate 0]
[limit #f]
[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)]
[tick# 0]
[timer (new timer% [notify-callback (lambda () (set! tick# (+ tick# 1)) (ptock))])])
(match on-tick
[`(,handler ,r ,l)
(set! limit l)
(set! rate r)
(set! tick (first on-tick))]
[`(,handler ,r)
(set! rate r)
(set! tick handler)]
[(? procedure? handler)
(set! rate RATE)
(set! tick handler)]
[else (void)])
(define/override (start!)
(unless (<= rate 0)
@ -35,7 +43,9 @@
(send timer stop)
(super stop! w))
(define/override (pptock w)
(tick w))
(if (and limit (> tick# limit))
(make-stop-the-world w)
(tick w)))
(define/override (name-of-tick-handler)
(object-name tick))
(super-new)))

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

@ -8,6 +8,7 @@
"timer.rkt"
"last.rkt"
"clauses-spec-aux.rkt"
"stop.rkt"
htdp/error
(only-in mzlib/etc evcase)
string-constants)
@ -85,8 +86,11 @@
(with-handlers ([exn? handler])
(define ___ (begin 'dummy body ...))
(define n (if (object-name name) (object-name name) name))
(define-values (u mails bad)
(bundle> n (name (send universe get) a ...)))
(define nxt (name (send universe get) a ...))
(define-values (u mails bad)
(if (stop-the-world? nxt)
(error 'stop! "the universe stopped: ~e" (stop-the-world-world nxt))
(bundle> n nxt)))
(send universe set (format "value returned from ~a" 'name) u)
(unless (boolean? to-string) (send gui add (to-string u)))
(broadcast mails)

25
collects/2htdp/tests/mouse-evt.rkt
View File

@ -1,4 +1,4 @@
#lang scheme
#lang racket
(require 2htdp/universe)
(require htdp/image)
@ -17,25 +17,26 @@
(cond
[(equal? a-world world1)
(place-image (text "move mouse in to canvas" 11 'red) 10 10
(place-image sq (posn-x a-world) (posn-y a-world) mt))]
(place-image sq (posn-x a-world) (posn-y a-world) mt))]
[(equal? a-world world-in)
(place-image (text "move mouse out of canvas" 11 'red) 10 10
(place-image sq (posn-x a-world) (posn-y a-world) mt))]
(place-image sq (posn-x a-world) (posn-y a-world) mt))]
[else
(place-image sq (posn-x a-world) (posn-y a-world) mt)]))
(place-image sq (posn-x a-world) (posn-y a-world) mt)]))
(check-expect (mouse-handler 'w 100 100 "leave") (make-posn 250 250))
(define (mouse-handler w x y me)
(cond
[(string=? "button-down" me) w]
[(string=? "button-up" me) w]
[(string=? "drag" me) w]
[(string=? "move" me) w]
[(string=? "enter" me) world-in]
[(string=? "leave" me) world-out]))
(cond
[(string=? "button-down" me) w]
[(string=? "button-up" me) w]
[(string=? "drag" me) w]
[(string=? "move" me) w]
[(string=? "enter" me) world-in]
[(string=? "leave" me) world-out]))
(define (out? w) (equal? world-out w))
(define (out? w)
(equal? world-out w))
(define (main w)
(big-bang world1 (on-draw draw) (stop-when out?) (on-mouse mouse-handler)))

13
collects/2htdp/tests/on-tick-universe-with-limit.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang racket
(require 2htdp/universe 2htdp/image)
(with-handlers ((exn? (lambda (w)
(unless (string=? "stop!: the universe stopped: 3" (exn-message w))
(raise w)))))
(universe 0
(on-tick (lambda (w) (make-bundle (add1 w) '() '())) 1/28 3)
(on-msg void)
(on-new cons))
(error "the universe didn't stop properly"))

8
collects/2htdp/tests/on-tick-with-limit.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang racket
(require 2htdp/universe 2htdp/image)
(big-bang 0
(on-tick add1 1/28 3)
(to-draw (lambda (w) (circle (- 100 w) 'solid 'red))))

2
collects/2htdp/tests/xtest
View File

@ -30,3 +30,5 @@ run world0-stops.rkt
run record.rkt
run record-stop-when.rkt
run stop-when-crash.rkt
run on-tick-universe-with-limit.rkt
run on-tick-with-limit.rkt

9
collects/2htdp/universe.rkt
View File

@ -56,7 +56,14 @@
#'(list
(proc> 'on-tick (f2h f) 1)
(num> 'on-tick rate (lambda (x) (and (real? x) (positive? x)))
"positive number" "rate"))])]
"positive number" "rate"))]
[(_ f rate limit)
#'(list
(proc> 'on-tick (f2h f) 1)
(num> 'on-tick rate (lambda (x) (and (real? x) (positive? x)))
"positive number" "rate")
(num> 'on-tick limit (lambda (x) (and (integer? x) (positive? x)))
"positive integer" "limit"))])]
;; -- state specifies whether to display the current state
[state DEFAULT #'#f (expr-with-check any> "expected a boolean or a string")]
;; Any -> Boolean

35
collects/teachpack/2htdp/scribblings/universe.scrbl
View File

@ -167,6 +167,7 @@ The design of a world program demands that you come up with a data
([clause
(on-tick tick-expr)
(on-tick tick-expr rate-expr)
(on-tick tick-expr rate-expr limit-expr)
(on-key key-expr)
(on-release release-expr)
(on-mouse mouse-expr)
@ -251,6 +252,18 @@ tells DrRacket to call the @racket[tick-expr] function on the current
world every time the clock ticks. The result of the call becomes the
current world. The clock ticks every @racket[rate-expr] seconds.}}
@item{
@defform/none[#:literals(on-tick)
(on-tick tick-expr rate-expr limit-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))]
[rate-expr (and/c real? positive?)]
[limit-expr (and/c integer? positive?)])]{
tells DrRacket to call the @racket[tick-expr] function on the current
world every time the clock ticks. The result of the call becomes the
current world. The clock ticks every @racket[rate-expr] seconds.
The world ends when the clock has ticked more than @scheme[limit-expr] times.}}
@item{A @tech{KeyEvent} represents key board events.
@deftech{KeyEvent} : @racket[string?]
@ -714,6 +727,14 @@ As mentioned, all event handlers may return @tech{WorldState}s or
[rate-expr (and/c real? positive?)])]{
}
@defform/none[#:literals (on-tick)
(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{WorldState}) (or/c (unsyntax @tech{WorldState}) package?))]
[rate-expr (and/c real? positive?)]
[limit-expr (and/c integer? positive?)])]{
}
@defform/none[#:literals (on-key)
(on-key key-expr)
#:contracts
@ -955,6 +976,7 @@ The @tech{server} itself is created with a description that includes the
(on-msg msg-expr)
(on-tick tick-expr)
(on-tick tick-expr rate-expr)
(on-tick tick-expr rate-expr limit-expr)
(on-disconnect dis-expr)
(state boolean-expr)
(to-string render-expr)
@ -1034,7 +1056,18 @@ optional handlers:
[rate-expr (and/c real? positive?)])]{
tells DrRacket to apply @racket[tick-expr] as above; the clock ticks
every @racket[rate-expr] seconds.}
}
@defform/none[#:literals (on-tick)
(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{UniverseState}) bundle?)]
[rate-expr (and/c real? positive?)]
[limit-expr (and/c integer? positive?)])]{
tells DrRacket to apply @racket[tick-expr] as above; the clock ticks
every @racket[rate-expr] seconds. The universe stops when the clock has
ticked more than @scheme[limit-expr] times.}
}
@item{
@defform[(on-disconnect dis-expr)