diff --git a/collects/2htdp/private/syn-aux-aux.rkt b/collects/2htdp/private/syn-aux-aux.rkt index 80a5e5ac66..fbd8face8a 100644 --- a/collects/2htdp/private/syn-aux-aux.rkt +++ b/collects/2htdp/private/syn-aux-aux.rkt @@ -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) diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index b10b5f3ca6..cb31063e18 100644 --- a/collects/2htdp/private/world.rkt +++ b/collects/2htdp/private/world.rkt @@ -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 diff --git a/collects/2htdp/tests/record.rkt b/collects/2htdp/tests/record.rkt new file mode 100644 index 0000000000..96989555a3 --- /dev/null +++ b/collects/2htdp/tests/record.rkt @@ -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 "")) + #: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/") \ No newline at end of file diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index 838941f28f..2ceae80a01 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -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")]