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

stop the world and let me get off

Browse Source 
svn: r17111
This commit is contained in:
Matthias Felleisen 2009-11-30 16:52:01 +00:00
parent f18cc73dec
commit bb4c88338c
4 changed files with 30 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/2htdp/private/stop.ss Normal file
View File

@ -0,0 +1,5 @@
#lang scheme
(provide (struct-out stop-the-world))
(define-struct stop-the-world (world) #:transparent)

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

@ -4,6 +4,7 @@
"timer.ss" "timer.ss"
"last.ss" "last.ss"
"checked-cell.ss" "checked-cell.ss"
"stop.ss"
htdp/image htdp/image
htdp/error htdp/error
mzlib/runtime-path mzlib/runtime-path
@ -214,15 +215,20 @@
(queue-callback (queue-callback
(lambda () (lambda ()
(with-handlers ([exn? (handler #t)]) (with-handlers ([exn? (handler #t)])
(define stop-it #f)
(define tag (format "~a callback" 'transform)) (define tag (format "~a callback" 'transform))
(define nw (transform (send world get) arg ...)) (define nw (transform (send world get) arg ...))
(when (package? nw) (when (package? nw)
(broadcast (package-message nw)) (broadcast (package-message nw))
(set! nw (package-world nw))) (set! nw (package-world nw)))
(printf "~s\n" nw)
(when (stop-the-world? nw)
(set! nw (stop-the-world-world nw))
(set! stop-it #t))
(let ([changed-world? (send world set tag nw)]) (let ([changed-world? (send world set tag nw)])
(unless changed-world? (unless changed-world?
(when draw (pdraw)) (when draw (pdraw))
(when (pstop) (when (or stop-it (pstop))
(when last-picture (when last-picture
(set! draw last-picture) (set! draw last-picture)
(pdraw)) (pdraw))
@ -284,7 +290,11 @@
;; initialize the world and run ;; initialize the world and run
(super-new) (super-new)
(start!) (start!)
(when (stop (send world get)) (stop! (send world get))))))) (let ([w (send world get)])
(cond
[(stop w) (stop! (send world get))]
[(stop-the-world? w)
(stop! (stop-the-world-world (send world get)))]))))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png")) (define-runtime-path break-btn:path '(lib "icons/break.png"))

10
collects/2htdp/tests/world0-stops.ss
View File

@ -1,5 +1,13 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata ;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process. ;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp"))))) #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require 2htdp/universe)
"does big-bang stop when the initial world is already a final world?"
(big-bang 0 (stop-when zero?) (on-tick add1)) (big-bang 0 (stop-when zero?) (on-tick add1))
"does big bang stop when the initial world is a stop world?"
(big-bang (STOP! 0) (on-tick add1))
(define-struct stop (x))

4
collects/2htdp/universe.ss
View File

@ -17,11 +17,15 @@
"private/world.ss" "private/world.ss"
"private/universe.ss" "private/universe.ss"
"private/launch-many-worlds.ss" "private/launch-many-worlds.ss"
"private/stop.ss"
htdp/error htdp/error
(rename-in lang/prim (first-order->higher-order f2h))) (rename-in lang/prim (first-order->higher-order f2h)))
(provide (all-from-out "private/image.ss")) (provide (all-from-out "private/image.ss"))
(provide
(rename-out (make-stop-the-world STOP!))) ;; World -> STOP!
(provide (provide
launch-many-worlds launch-many-worlds
;; (launch-many-worlds e1 ... e2) ;; (launch-many-worlds e1 ... e2)