From d6048fd7f1186b7510cd7ceab2946955040a52c0 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 1 Sep 2014 16:42:31 +0200 Subject: [PATCH] interpolation for recorded animation; for David for now --- .../htdp-lib/2htdp/private/world.rkt | 166 +++++++++++------- .../htdp-test/2htdp/tests/record.rkt | 2 +- 2 files changed, 102 insertions(+), 66 deletions(-) diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt index fe9985d536..7ad1f8d37b 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/world.rkt @@ -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) - - (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?]))))))])) + (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?]))))))])) ;; 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) diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/record.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/record.rkt index 54bfc91c19..e52ab3e5f7 100644 --- a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/record.rkt +++ b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/record.rkt @@ -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)))