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

record? is working as it used, plus ability to auto-save images so I can write a test case, Closes PR11348 and PR11349

Browse Source
This commit is contained in:
Matthias Felleisen 2010-10-26 19:01:56 -04:00
parent 7802f1deb7
commit 6457f1e4cc
4 changed files with 73 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -18,7 +18,7 @@
; ; ;
; ;;;
(provide nat> nat? proc> bool> num> ip> string> symbol>)
(provide nat> nat? proc> bool> num> ip> string> symbol> any>)
;; Any -> Boolean
(define (nat? x)
@ -58,3 +58,7 @@
(define (nat> tag x spec)
(check-arg tag (nat? x) spec "natural number" x)
x)
;; Symbol X String -> X
(define (any> tag x)
x)

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

@ -51,8 +51,8 @@
(class* object% (start-stop<%>)
(inspect #f)
(init-field world0)
(init-field name state register check-with on-key on-mouse)
(init on-release on-receive on-draw stop-when record?)
(init-field name state register check-with on-key on-mouse record?)
(init on-release on-receive on-draw stop-when)
;; -----------------------------------------------------------------------
(field
@ -341,9 +341,8 @@
(start!)
(let ([w (send world get)])
(cond
[(stop w) (stop! (send world get))]
[(stop-the-world? w)
(stop! (stop-the-world-world (send world get)))]))))))
[(stop w) (stop! w)]
[(stop-the-world? w) (stop! (stop-the-world-world w))]))))))
; (define make-new-world (new-world world%))
@ -357,7 +356,7 @@
(define aworld%
(class world% (super-new)
(inherit-field world0 tick key release mouse rec draw rate width height)
(inherit-field world0 tick key release mouse rec draw rate width height record?)
(inherit show callback-stop!)
;; Frame Custodian ->* (-> Void) (-> Void)
@ -365,9 +364,15 @@
;; whose callbacks runs as a thread in the custodian
(define/augment (create-frame frm play-back-custodian)
(define p (new horizontal-pane% [parent frm][alignment '(center center)]))
(define (pb)
(parameterize ([current-custodian play-back-custodian])
(thread (lambda () (play-back)))
(stop)))
(define (switch)
(send stop-button enable #f)
(send image-button enable #t))
(if (and (string? record?) (directory-exists? record?))
(pb)
(send image-button enable #t)))
(define (stop)
(send image-button enable #f)
(send stop-button enable #f))
@ -377,10 +382,7 @@
(define stop-button
(btn break-button:label (b e) (callback-stop! 'stop-images) (switch)))
(define image-button
(btn image-button:label (b e)
(parameterize ([current-custodian play-back-custodian])
(thread (lambda () (play-back)))
(stop))))
(btn image-button:label (b e) (pb)))
(send image-button enable #f)
(values switch stop))
@ -392,10 +394,8 @@
;; --- new callbacks ---
(define-syntax-rule
(def/cb ovr (pname name arg ...))
(begin
; (ovr pname)
(define/override (pname arg ...)
(when (super pname arg ...) (add-event 'name arg ...)))))
(define/override (pname arg ...)
(when (super pname arg ...) (add-event name arg ...))))
(def/cb augment (ptock tick))
(def/cb augment (pkey key e))
@ -424,19 +424,20 @@
(send bm save-file (format "i~a.png" (zero-fill imag# digt#)) 'png)
(set! bmps (cons bm bmps)))
;; --- choose place
(define img:dir (get-directory "image directory:" #f (current-directory)))
(define img:dir
(or (and (string? record?) (directory-exists? record?) record?)
(get-directory "image directory:" #f (current-directory))))
(when img:dir
(parameterize ([current-directory img:dir])
(define last
(foldr (lambda (event world)
(save-image (draw world))
(show (text (format "~a/~a created" imag# total) 18 'red))
(world-transition world event))
world0
event-history))
(define worldN
(let L ([history event-history][world world0])
(save-image (draw world))
(if (empty? history)
world
(L (rest history) (world-transition world (first history))))))
(show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
(create-animated-gif rate (reverse bmps))
(show (draw last)))))))
(show (draw worldN)))))))
;; Number [Listof (-> bitmap)] -> Void
;; turn the list of thunks into animated gifs

40
collects/2htdp/tests/record.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket
(require 2htdp/universe)
(require 2htdp/image)
(define (draw-number n)
(place-image (text (number->string n) 44 'red)
50 50
(empty-scene 100 100)))
;; Nat String -> Nat
;; create n images in ./images directory
;; ASSUME: dir exists
(define (create-n-images n dir)
(parameterize ([current-directory dir])
(for-each delete-file (directory-list)))
(with-output-to-file (format "./~a/index.html" dir)
(lambda ()
(displayln "<html><body><img src=\"i-animated.gif\" /></body></html>"))
#:exists 'replace)
(define final-world
(big-bang 0
(on-tick add1)
(stop-when (curry = (+ n 1)))
(on-draw draw-number)
(record? dir)))
(sleep 1)
(define number-of-png
(parameterize ([current-directory dir])
(define dlst (directory-list))
; (displayln dlst)
(length
(filter (lambda (f) (regexp-match "\\.png" (path->string f)))
dlst))))
(unless (= (+ n 2) number-of-png)
(error 'record? "(~s, ~s) didn't record proper number of images: ~s" n dir
number-of-png)))
(create-n-images 3 "images3/")
(create-n-images 0 "images0/")

5
collects/2htdp/universe.rkt
View File

@ -94,9 +94,10 @@
[(_ stop? last-picture)
#'(list (proc> 'stop-when (f2h stop?) 1)
(proc> 'stop-when (f2h last-picture) 1))])]
;; (U #f Boolean)
;; (U #f Any)
;; -- should the session be recorded and turned into PNGs and an animated GIF
[record? DEFAULT #'#f (expr-with-check bool> "expected a boolean")]
;; -- if the value is a string and is the name of a local directory, use it!
[record? DEFAULT #'#f (expr-with-check any> "")]
;; (U #f String)
;; -- name specifies one string
[name DEFAULT #'#f (expr-with-check string> "expected a string")]