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

interpolation for recorded animation; for David for now

Browse Source
This commit is contained in:
Matthias Felleisen 2014-09-01 16:42:31 +02:00
parent a0c984bd09
commit d6048fd7f1
2 changed files with 102 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

166
pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt
View File

@ -234,10 +234,10 @@
;; Image -> Void ;; Image -> Void
;; show the image in the visible world ;; show the image in the visible world
(define/public (show pict0) (define/public (show pict0)
(define pict* (define pict*
(if (is-a? pict0 bitmap%) (if (is-a? pict0 bitmap%)
(rotate 0 pict0) (rotate 0 pict0)
pict0)) pict0))
(define pict (add-game-pad pict*)) (define pict (add-game-pad pict*))
(send visible begin-edit-sequence) (send visible begin-edit-sequence)
(send visible lock #f) (send visible lock #f)
@ -279,63 +279,63 @@
(def/cback pub (name arg ...) transform (object-name transform))] (def/cback pub (name arg ...) transform (object-name transform))]
[(_ pub (name arg ...) transform tag) [(_ pub (name arg ...) transform tag)
;; Any ... -> Boolean ;; Any ... -> Boolean
(begin (begin
(pub name) (pub name)
(define (name arg ...) (define (name arg ...)
(queue-callback (queue-callback
(lambda () (lambda ()
(define H (handler #t)) (define H (handler #t))
(with-handlers ([exn? H]) (with-handlers ([exn? H])
; (define tag (object-name transform)) ; (define tag (object-name transform))
(define nw (transform (send world get) arg ...)) (define nw (transform (send world get) arg ...))
(define (d) (define (d)
(with-handlers ((exn? H)) (with-handlers ((exn? H))
(pdraw)) (pdraw))
(set-draw#!)) (set-draw#!))
;; --- ;; ---
;; [Listof (Box [d | void])] ;; [Listof (Box [d | void])]
(define w '()) (define w '())
;; set all to void, then w to null ;; set all to void, then w to null
;; when a high priority draw is scheduledd ;; when a high priority draw is scheduledd
;; --- ;; ---
(when (package? nw) (when (package? nw)
(broadcast (package-message nw)) (broadcast (package-message nw))
(set! nw (package-world nw))) (set! nw (package-world nw)))
(cond (cond
[(stop-the-world? nw) [(stop-the-world? nw)
(set! nw (stop-the-world-world nw)) (set! nw (stop-the-world-world nw))
(send world set tag nw) (send world set tag nw)
(last-draw) (last-draw)
(callback-stop! 'name) (callback-stop! 'name)
(enable-images-button)] (enable-images-button)]
[else [else
[define changed-world? (send world set tag nw)] [define changed-world? (send world set tag nw)]
[define stop? (stop (send world get))] [define stop? (stop (send world get))]
;; this is the old "Robby optimization" see checked-cell: ;; this is the old "Robby optimization" see checked-cell:
; unless changed-world? ; unless changed-world?
(cond (cond
[(and draw (not stop?)) [(and draw (not stop?))
(cond (cond
[(not drawing) [(not drawing)
(set! drawing #t) (set! drawing #t)
(let ([b (box d)]) (let ([b (box d)])
(set! w (cons b w)) (set! w (cons b w))
;; low priority, otherwise it's too fast ;; low priority, otherwise it's too fast
(queue-callback (lambda () ((unbox b))) #f))] (queue-callback (lambda () ((unbox b))) #f))]
[(< draw# 0) [(< draw# 0)
(set-draw#!) (set-draw#!)
(for-each (lambda (b) (set-box! b void)) w) (for-each (lambda (b) (set-box! b void)) w)
(set! w '()) (set! w '())
;; high!! the scheduled callback didn't fire ;; high!! the scheduled callback didn't fire
(queue-callback (lambda () (d)) #t)] (queue-callback (lambda () (d)) #t)]
[else [else
(set! draw# (- draw# 1))])] (set! draw# (- draw# 1))])]
[stop? [stop?
(last-draw) (last-draw)
(callback-stop! 'name) (callback-stop! 'name)
(enable-images-button)]) (enable-images-button)])
changed-world?]))))))])) changed-world?]))))))]))
;; tick, tock : deal with a tick event for this world ;; tick, tock : deal with a tick event for this world
(def/cback pubment (ptock) (lambda (w) (pptock w)) (name-of-tick-handler)) (def/cback pubment (ptock) (lambda (w) (pptock w)) (name-of-tick-handler))
@ -431,7 +431,10 @@
(define aworld% (define aworld%
(class world% (class world%
;; an argument-recording ppdraw ;; an argument-recording ppdraw
(field [image-history '()]) ;; [Listof Evt]
;; [Listof [List N Image]]
;; a list of the displayed images combined with a time stamp
(field [image-history '()])
(super-new) (super-new)
(inherit-field world0 draw rate width height record?) (inherit-field world0 draw rate width height record?)
@ -468,7 +471,7 @@
(define/override (ppdraw) (define/override (ppdraw)
(define image (super ppdraw)) (define image (super ppdraw))
(set! image-history (cons image image-history)) (set! image-history (cons (list (current-inexact-milliseconds) image) image-history))
image) image)
;; --> Void ;; --> Void
@ -498,14 +501,47 @@
(get-directory "image directory:" #f (current-directory)))) (get-directory "image directory:" #f (current-directory))))
(when img:dir (when img:dir
(parameterize ([current-directory img:dir]) (parameterize ([current-directory img:dir])
(define image-history-interpolated (interpolate-history image-history))
(define imageN (define imageN
(if (empty? image-history) (if (empty? image-history-interpolated)
(save-image (draw world0)) (save-image (draw world0))
(first (map save-image image-history)))) (first (map save-image image-history-interpolated))))
(show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red)) (show (text (format "creating ~a" ANIMATED-GIF-FILE) 18 'red))
(create-animated-gif rate bmps) (create-animated-gif rate bmps)
(show imageN)))))) (show imageN))))))
;; ---------------------------------------------------------------------------------------------------
;; [Listof [List Real Image]] -> [Listof Image]
;; for David's talk
(define (interpolate-history lox0)
(define lox (reverse lox0))
(cond
[(or (empty? lox) (empty? (rest lox))) (map second lox)]
[else
;; -----------------------------------------------------------------------------x
(define raw-times (map first lox))
(define intervals
(let loop ([l (rest raw-times)][last (first raw-times)])
(cond
[(empty? l) '()]
[else (cons (- (first l) last) (loop (rest l) (first l)))])))
(define delta (apply min intervals))
;; -----------------------------------------------------------------------------
(define image1 (second (first lox)))
(let loop ([last-image image1][t (first (first lox))][lox (rest lox)][images (list image1)])
(cond
[(empty? lox) images]
[else (define stamp+image (first lox))
(define stamp (first stamp+image))
(define image (second stamp+image))
(define new-t (+ delta t))
(if (< new-t stamp)
(loop last-image new-t lox (cons last-image images))
(loop image new-t (rest lox) (cons image images)))]))]))
;; ---------------------------------------------------------------------------------------------------
;; Number [Listof (-> bitmap)] -> Void ;; Number [Listof (-> bitmap)] -> Void
;; turn the list of thunks into animated gifs ;; turn the list of thunks into animated gifs
;; effect: overwrite the ANIMATED-GIF-FILE (in current directory) ;; effect: overwrite the ANIMATED-GIF-FILE (in current directory)

2
pkgs/htdp-pkgs/htdp-test/2htdp/tests/record.rkt
View File

@ -32,7 +32,7 @@
(length (length
(filter (lambda (f) (regexp-match "\\.png" (path->string f))) (filter (lambda (f) (regexp-match "\\.png" (path->string f)))
dlst)))) dlst))))
(unless (= expected-n number-of-png) (unless (<= expected-n number-of-png)
(error 'record? "(~s, ~s) didn't record proper number of images: ~s" n dir (error 'record? "(~s, ~s) didn't record proper number of images: ~s" n dir
number-of-png))) number-of-png)))