From 323ae22f12f88d98746c2696e939c0494f82e21c Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sat, 26 Jul 2008 21:48:29 +0000 Subject: [PATCH] Adding a five-second pause to the end of an animated-gif. Added #:last-frame-delay parameter to mrlib/gif's write-animated-gif function. svn: r10927 --- collects/htdp/world.ss | 2 +- collects/mrlib/gif.ss | 58 +++++++++++++++++++++++++----------------- 2 files changed, 36 insertions(+), 24 deletions(-) diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index 2335509770..da58079a3a 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -781,7 +781,7 @@ Matthew (define intv (if (> +inf.0 *the-delta* 0) (inexact->exact (floor (* 100 *the-delta*))) 5)) (when (file-exists? ANIMATED-GIF-FILE) (delete-file ANIMATED-GIF-FILE)) - (write-animated-gif bitmap-list intv ANIMATED-GIF-FILE #:one-at-a-time? #t)) + (write-animated-gif bitmap-list intv ANIMATED-GIF-FILE #:one-at-a-time? #t #:last-frame-delay 500)) (define ANIMATED-GIF-FILE "i-animated.gif") diff --git a/collects/mrlib/gif.ss b/collects/mrlib/gif.ss index 12a080413a..215255b548 100644 --- a/collects/mrlib/gif.ss +++ b/collects/mrlib/gif.ss @@ -2,21 +2,22 @@ (module gif scheme/base (require scheme/gui/base scheme/class + scheme/list net/gifwrite scheme/contract) - + (provide write-gif write-animated-gif) - + (define (force-bm bm) (if (procedure? bm) (bm) bm)) - + (define (split-bytes b len offset) (if (= offset (bytes-length b)) null (cons (subbytes b offset (+ offset len)) (split-bytes b len (+ offset len))))) - - (define (write-gifs bms delay filename one-at-a-time?) + + (define (write-gifs bms delay filename one-at-a-time? last-frame-delay) (let* ([init (force-bm (car bms))] [w (send init get-width)] [h (send init get-height)]) @@ -39,13 +40,17 @@ (let* ([gif (gif-start p w h 0 #f)]) (when delay (gif-add-loop-control gif 0)) - (for-each (lambda (argb-thunk) - (let-values ([(pixels colormap transparent) - (quantize (argb-thunk))]) - (when (or transparent delay) - (gif-add-control gif 'any #f (or delay 0) transparent)) - (gif-add-image gif 0 0 w h #f colormap pixels))) - argb-thunks) + (let ([last-argb-thunk (last argb-thunks)]) + (for-each (lambda (argb-thunk) + (let-values ([(pixels colormap transparent) + (quantize (argb-thunk))]) + (when (or transparent delay) + (gif-add-control gif 'any #f (or delay 0) transparent)) + (gif-add-image gif 0 0 w h #f colormap pixels) + (when (and last-frame-delay (eq? argb-thunk last-argb-thunk)) + (gif-add-control gif 'any #f last-frame-delay transparent) + (gif-add-image gif 0 0 w h #f colormap pixels)))) + argb-thunks)) (gif-end gif)))) ;; Build images and quantize all at once: (let-values ([(pixels colormap transparent) @@ -56,17 +61,24 @@ (let* ([gif (gif-start p w h 0 colormap)]) (when delay (gif-add-loop-control gif 0)) - (for-each (lambda (pixels) - (when (or transparent delay) - (gif-add-control gif 'any #f (or delay 0) transparent)) - (gif-add-image gif 0 0 w h #f #f pixels)) - (split-bytes pixels (* w h) 0)) + (let* ([pixelss (split-bytes pixels (* w h) 0)] + [last-pixels (last pixelss)]) + (for-each (lambda (pixels) + (when (or transparent delay) + (gif-add-control gif 'any #f (or delay 0) transparent)) + (gif-add-image gif 0 0 w h #f #f pixels) + (when (and last-frame-delay (eq? pixels last-pixels)) + (gif-add-control gif 'any #f last-frame-delay transparent) + (gif-add-image gif 0 0 w h #f colormap pixels))) + pixelss)) (gif-end gif))))))))) - + (define (write-gif bm filename) - (write-gifs (list bm) #f filename #f)) - - (define (write-animated-gif bms delay filename #:one-at-a-time? [one-at-a-time? #f]) - (write-gifs bms delay filename one-at-a-time?)) - + (write-gifs (list bm) #f filename #f #f)) + + (define (write-animated-gif bms delay filename + #:one-at-a-time? [one-at-a-time? #f] + #:last-frame-delay [last-frame-delay #f]) + (write-gifs bms delay filename one-at-a-time? last-frame-delay)) + )