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

htdp, testing

Browse Source 
svn: r6147
This commit is contained in:
Matthias Felleisen 2007-05-04 22:16:26 +00:00
parent 8661413b7f
commit 4744c559b0
3 changed files with 10 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/htdp/Test/world.ss
View File

@ -26,7 +26,7 @@
;; run world run ;; run world run
(big-bang 100 100 .1 world0) (big-bang 100 100 .1 world0 true) ;; get ready to create images
(on-redraw world->image) (on-redraw world->image)
(on-tick-event world->next) (on-tick-event world->next)

20
collects/htdp/world.ss
View File

@ -23,6 +23,7 @@ ones.)
Matthew Matthew
|# |#
;; Fri May 4 18:05:33 EDT 2007: define-run-time-path
;; Thu May 3 22:06:16 EDT 2007: scene # image; pasteboard% for text% ;; Thu May 3 22:06:16 EDT 2007: scene # image; pasteboard% for text%
;; Sat Apr 28 13:31:02 EDT 2007: fixed the image and animated-gif thing, using Matthew's lib ;; Sat Apr 28 13:31:02 EDT 2007: fixed the image and animated-gif thing, using Matthew's lib
;; Fri Dec 22 11:51:53 EST 2006: cleaned up the callback code with macro ;; Fri Dec 22 11:51:53 EST 2006: cleaned up the callback code with macro
@ -38,9 +39,6 @@ Matthew
(module world mzscheme (module world mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss")
(lib "process.ss")
(lib "port.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "error.ss" "htdp") (lib "error.ss" "htdp")
(lib "image.ss" "htdp") (lib "image.ss" "htdp")
@ -49,6 +47,7 @@ Matthew
(lib "prim.ss" "lang")) (lib "prim.ss" "lang"))
(require (lib "gif.ss" "mrlib")) (require (lib "gif.ss" "mrlib"))
(require (lib "runtime-path.ss"))
(require (lib "bitmap-label.ss" "mrlib") (require (lib "bitmap-label.ss" "mrlib")
(lib "string-constant.ss" "string-constants")) (lib "string-constant.ss" "string-constants"))
@ -578,22 +577,21 @@ Matthew
;; Frame [Box (union false Thread)] -> Void ;; Frame [Box (union false Thread)] -> Void
;; adds the stop animation and image creation button, ;; adds the stop animation and image creation button,
;; whose callbacks runs as a thread in the custodian ;; whose callbacks runs as a thread in the custodian
(define IMAGES "Images")
(define-runtime-path s:pth (build-path (collection-path "icons") "break.png"))
(define-runtime-path i:pth (build-path (collection-path "icons") "file.gif"))
(define (add-stop-and-image-buttons frame the-play-back-custodian) (define (add-stop-and-image-buttons frame the-play-back-custodian)
(define p (new horizontal-pane% [parent frame][alignment '(center center)])) (define p (new horizontal-pane% [parent frame][alignment '(center center)]))
(define l-stop ((bitmap-label-maker (define S ((bitmap-label-maker (string-constant break-button-label) s:pth) '_))
(string-constant break-button-label) (define I ((bitmap-label-maker IMAGES i:pth) '_))
(build-path (collection-path "icons") "break.png")) '___))
(define l-imgs ((bitmap-label-maker
"Images"
(build-path (collection-path "icons") "file.gif")) '___))
(define stop-button (define stop-button
(new button% [parent p] [label l-stop] [style '(border)] (new button% [parent p] [label S] [style '(border)]
[callback (lambda (this-button e) [callback (lambda (this-button e)
(callback-stop!) (callback-stop!)
(send this-button enable #f) (send this-button enable #f)
(send image-button enable #t))])) (send image-button enable #t))]))
(define image-button (define image-button
(new button% [parent p] [enabled #f] [label l-imgs] [style '(border)] (new button% [parent p] [enabled #f] [label I] [style '(border)]
[callback (lambda (b e) [callback (lambda (b e)
(parameterize ([current-custodian the-play-back-custodian]) (parameterize ([current-custodian the-play-back-custodian])
(define th (thread play-back)) (define th (thread play-back))

1
collects/teachpack/htdp/testing.ss
View File

@ -1,4 +1,3 @@
#cs
(module testing mzscheme (module testing mzscheme
(provide (all-from (lib "testing.ss" "htdp"))) (provide (all-from (lib "testing.ss" "htdp")))
(require (lib "testing.ss" "htdp"))) (require (lib "testing.ss" "htdp")))