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

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

@ -234,10 +234,10 @@
;; Image -> Void
;; show the image in the visible world
(define/public (show pict0)
(define pict*
(if (is-a? pict0 bitmap%)
(rotate 0 pict0)
pict0))
(define pict*
(if (is-a? pict0 bitmap%)
(rotate 0 pict0)
pict0))
(define pict (add-game-pad pict*))
(send visible begin-edit-sequence)
(send visible lock #f)
@ -279,63 +279,63 @@
(def/cback pub (name arg ...) transform (object-name transform))]
[(_ pub (name arg ...) transform tag)
;; Any ... -> Boolean
(begin
(pub name)
(begin
(pub name)
(define (name arg ...)
(queue-callback
(lambda ()
(define H (handler #t))
(with-handlers ([exn? H])
; (define tag (object-name transform))
(define nw (transform (send world get) arg ...))
(define (d)
(with-handlers ((exn? H))
(pdraw))
(set-draw#!))
;; ---
;; [Listof (Box [d | void])]
(define w '())
;; set all to void, then w to null
;; when a high priority draw is scheduledd
;; ---
(when (package? nw)
(broadcast (package-message nw))
(set! nw (package-world nw)))
(cond
[(stop-the-world? nw)
(set! nw (stop-the-world-world nw))
(send world set tag nw)
(last-draw)
(callback-stop! 'name)
(enable-images-button)]
[else
[define changed-world? (send world set tag nw)]
[define stop? (stop (send world get))]
;; this is the old "Robby optimization" see checked-cell:
; unless changed-world?
(cond
[(and draw (not stop?))
(cond
[(not drawing)
(set! drawing #t)
(let ([b (box d)])
(set! w (cons b w))
;; low priority, otherwise it's too fast
(queue-callback (lambda () ((unbox b))) #f))]
[(< draw# 0)
(set-draw#!)
(for-each (lambda (b) (set-box! b void)) w)
(set! w '())
;; high!! the scheduled callback didn't fire
(queue-callback (lambda () (d)) #t)]
[else
(set! draw# (- draw# 1))])]
[stop?
(last-draw)
(callback-stop! 'name)
(enable-images-button)])
changed-world?]))))))]))
(define (name arg ...)
(queue-callback
(lambda ()
(define H (handler #t))
(with-handlers ([exn? H])
; (define tag (object-name transform))
(define nw (transform (send world get) arg ...))
(define (d)
(with-handlers ((exn? H))
(pdraw))
(set-draw#!))
;; ---
;; [Listof (Box [d | void])]
(define w '())
;; set all to void, then w to null
;; when a high priority draw is scheduledd
;; ---
(when (package? nw)
(broadcast (package-message nw))
(set! nw (package-world nw)))
(cond
[(stop-the-world? nw)
(set! nw (stop-the-world-world nw))
(send world set tag nw)
(last-draw)
(callback-stop! 'name)
(enable-images-button)]
[else
[define changed-world? (send world set tag nw)]
[define stop? (stop (send world get))]
;; this is the old "Robby optimization" see checked-cell:
; unless changed-world?
(cond
[(and draw (not stop?))
(cond
[(not drawing)
(set! drawing #t)
(let ([b (box d)])
(set! w (cons b w))
;; low priority, otherwise it's too fast
(queue-callback (lambda () ((unbox b))) #f))]
[(< draw# 0)
(set-draw#!)
(for-each (lambda (b) (set-box! b void)) w)
(set! w '())
;; high!! the scheduled callback didn't fire
(queue-callback (lambda () (d)) #t)]
[else
(set! draw# (- draw# 1))])]
[stop?
(last-draw)
(callback-stop! 'name)
(enable-images-button)])
changed-world?]))))))]))
;; tick, tock : deal with a tick event for this world
(def/cback pubment (ptock) (lambda (w) (pptock w)) (name-of-tick-handler))
@ -431,7 +431,10 @@
(define aworld%
(class world%
;; 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)
(inherit-field world0 draw rate width height record?)
@ -468,7 +471,7 @@
(define/override (ppdraw)
(define image (super ppdraw))
(set! image-history (cons image image-history))
(set! image-history (cons (list (current-inexact-milliseconds) image) image-history))
image)
;; --> Void
@ -498,14 +501,47 @@
(get-directory "image directory:" #f (current-directory))))
(when img:dir
(parameterize ([current-directory img:dir])
(define image-history-interpolated (interpolate-history image-history))
(define imageN
(if (empty? image-history)
(if (empty? image-history-interpolated)
(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))
(create-animated-gif rate bmps)
(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
;; turn the list of thunks into animated gifs
;; 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
(filter (lambda (f) (regexp-match "\\.png" (path->string f)))
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
number-of-png)))