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

added last-picture option to stop-when

Browse Source 
svn: r15740
This commit is contained in:
Matthias Felleisen 2009-08-14 23:15:29 +00:00
parent 6514185518
commit fb206a23d5
3 changed files with 35 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/2htdp/batch-io.ss
View File

@ -8,9 +8,11 @@
(list->string
(with-input-from-file f
(lambda ()
(let loop ()
(let loop ([accu '()])
(define nxt (read-char))
(if (eof-object? nxt) '() (cons nxt (loop))))))))
(if (eof-object? nxt)
(reverse (if (char=? (car accu) #\newline) (cdr accu) accu))
(loop (cons nxt accu))))))))
(define (write-file f str)
(check-arg 'read-file (string? f) "string" "first" f)
@ -20,6 +22,8 @@
#:exists 'truncate)
result))
;; -----------------------------------------------------------------------------
(provide
read-file ;; String -> String
;; read the file f (in current-directory) as a string

37
collects/2htdp/private/world.ss
View File

@ -49,6 +49,7 @@
(clock-mixin
(class* object% (start-stop<%>)
(inspect #f)
(init-field
world0 ;; World
(name #f) ;; (U #f Symbol)
@ -62,8 +63,8 @@
(on-receive #f) ;; (U #f (World S-expression -> World))
(on-draw #f) ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
(stop-when False) ;; World -> Boolean
(record? #f) ;; Boolean
)
(record? #f)) ;; Boolean
;; -----------------------------------------------------------------------
(field
(world
@ -106,18 +107,18 @@
(parameterize ([current-custodian *rec*])
;; try to register with the server n times
(let try ([n TRIES])
(printf "trying to register with ~a ...\n" register)
(with-handlers ((tcp-eof? (lambda (x) (printf FMTcom register)))
(exn:fail:network?
(lambda (x)
(if (= n 1)
(printf FMTtry register TRIES)
(begin (sleep PAUSE) (try (- n 1)))))))
(define-values (in out) (tcp-connect register SQPORT))
(tcp-register in out name)
(printf "... successful registered and ready to receive\n")
(set! *out* out)
(thread (RECEIVE in))))))
(printf "trying to register with ~a ...\n" register)
(with-handlers ((tcp-eof? (lambda (x) (printf FMTcom register)))
(exn:fail:network?
(lambda (x)
(if (= n 1)
(printf FMTtry register TRIES)
(begin (sleep PAUSE) (try (- n 1)))))))
(define-values (in out) (tcp-connect register SQPORT))
(tcp-register in out name)
(printf "... successful registered and ready to receive\n")
(set! *out* out)
(thread (RECEIVE in))))))
(define/private (broadcast msg)
(when *out*
@ -219,6 +220,9 @@
(unless changed-world?
(when draw (pdraw))
(when (pstop)
(when last-picture
(set! draw last-picture)
(pdraw))
(callback-stop! 'name)
(enable-images-button)))
changed-world?))))))
@ -244,7 +248,8 @@
;; -----------------------------------------------------------------------
;; stop-when
(field [stop stop-when])
(field [stop (if (procedure? stop-when) stop-when (first stop-when))]
[last-picture (if (pair? stop-when) (second stop-when) #f)])
(define/private (pstop)
(define result (stop (send world get)))
@ -273,7 +278,7 @@
;; initialize the world and run
(super-new)
(start!)
(when (stop-when (send world get)) (stop! (send world get)))))))
(when (stop (send world get)) (stop! (send world get)))))))
;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png"))

10
collects/2htdp/universe.ss
View File

@ -103,7 +103,8 @@
;; | (on-mouse Expr)
;; -- on-mouse must specify a mouse event handler
;; | (stop-when Expr)
;; -- stop-when must specify a boolean-valued function
;; | (stop-when Expr Expr)
;; -- stop-when must specify a predicate; it may specify a rendering function
;; | (register Expr)
;; -- register must specify the internet address of a host (including LOCALHOST)
;; | (name Expr)
@ -124,7 +125,12 @@
[on-mouse (function-with-arity 4)]
[on-key (function-with-arity 2)]
[on-receive (function-with-arity 2)]
[stop-when (function-with-arity 1)]
[stop-when (function-with-arity
1
except
[(stop? last-picture)
#'(list (proc> 'stop-when (f2h stop?) 1)
(proc> 'stop-when (f2h last-picture) 1))])]
[register (lambda (tag)
(lambda (p)
(syntax-case p ()