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

Rackety

Browse Source
This commit is contained in:
Asumu Takikawa 2013-02-19 12:19:40 -05:00
parent ce960756cb
commit ea0c14dac2
1 changed files with 90 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

179
collects/mrlib/gif.rkt
View File

@ -1,94 +1,95 @@
#lang racket/base
(module gif scheme/base ;; A library for creating gifs out of bitmap%s
(require scheme/gui/base
scheme/class (require racket/gui/base
scheme/list racket/class
net/gifwrite racket/list
racket/contract) net/gifwrite
racket/contract)
(provide write-gif)
(provide write-gif)
(define (force-bm bm) (if (procedure? bm) (bm) bm))
(define (force-bm bm) (if (procedure? bm) (bm) bm))
(define (split-bytes b len offset)
(if (= offset (bytes-length b)) (define (split-bytes b len offset)
null (if (= offset (bytes-length b))
(cons (subbytes b offset (+ offset len)) null
(split-bytes b len (+ offset len))))) (cons (subbytes b offset (+ offset len))
(split-bytes b len (+ offset len)))))
(define (write-gifs bms delay filename one-at-a-time? last-frame-delay loop?)
(let* ([init (force-bm (car bms))] (define (write-gifs bms delay filename one-at-a-time? last-frame-delay loop?)
[w (send init get-width)] (let* ([init (force-bm (car bms))]
[h (send init get-height)]) [w (send init get-width)]
(let ([argb-thunks [h (send init get-height)])
(map (lambda (bm) (let ([argb-thunks
(lambda () (map (lambda (bm)
(let ([bm (force-bm bm)] (lambda ()
[argb (make-bytes (* w h 4) 255)]) (let ([bm (force-bm bm)]
(send bm get-argb-pixels 0 0 w h argb) [argb (make-bytes (* w h 4) 255)])
(let ([mask (send bm get-loaded-mask)]) (send bm get-argb-pixels 0 0 w h argb)
(when mask (let ([mask (send bm get-loaded-mask)])
(send mask get-argb-pixels 0 0 w h argb #t))) (when mask
argb))) (send mask get-argb-pixels 0 0 w h argb #t)))
(cons init (cdr bms)))]) argb)))
(if one-at-a-time? (cons init (cdr bms)))])
;; Quantize individually, and stream the images through (if one-at-a-time?
;; Quantize individually, and stream the images through
(call-with-output-file*
filename
(lambda (p)
(let* ([gif (gif-start p w h 0 #f)])
(when loop?
(gif-add-loop-control gif 0))
(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)
(quantize (apply bytes-append (map (lambda (t) (t)) argb-thunks)))])
(call-with-output-file* (call-with-output-file*
filename filename
(lambda (p) (lambda (p)
(let* ([gif (gif-start p w h 0 #f)]) (let* ([gif (gif-start p w h 0 colormap)])
(when loop? (when delay
(gif-add-loop-control gif 0)) (gif-add-loop-control gif 0))
(let ([last-argb-thunk (last argb-thunks)]) (let* ([pixelss (split-bytes pixels (* w h) 0)]
(for-each (lambda (argb-thunk) [last-pixels (last pixelss)])
(let-values ([(pixels colormap transparent) (for-each (lambda (pixels)
(quantize (argb-thunk))]) (when (or transparent delay)
(when (or transparent delay) (gif-add-control gif 'any #f (or delay 0) transparent))
(gif-add-control gif 'any #f (or delay 0) transparent)) (gif-add-image gif 0 0 w h #f #f pixels)
(gif-add-image gif 0 0 w h #f colormap pixels) (when (and last-frame-delay (eq? pixels last-pixels))
(when (and last-frame-delay (eq? argb-thunk last-argb-thunk)) (gif-add-control gif 'any #f last-frame-delay transparent)
(gif-add-control gif 'any #f last-frame-delay transparent) (gif-add-image gif 0 0 w h #f colormap pixels)))
(gif-add-image gif 0 0 w h #f colormap pixels)))) pixelss))
argb-thunks)) (gif-end gif)))))))))
(gif-end gif))))
;; Build images and quantize all at once: (define (write-gif bm filename)
(let-values ([(pixels colormap transparent) (write-gifs (list bm) #f filename #f #f #f))
(quantize (apply bytes-append (map (lambda (t) (t)) argb-thunks)))])
(call-with-output-file* (provide/contract
filename [write-animated-gif
(lambda (p) (->i ((bms (and/c (listof (or/c (is-a?/c bitmap%) (-> (is-a?/c bitmap%)))) pair?))
(let* ([gif (gif-start p w h 0 colormap)]) (delay (integer-in 0 4294967295))
(when delay (filename (or/c path? string?)))
(gif-add-loop-control gif 0)) (#:one-at-a-time? (one-at-a-time? any/c)
(let* ([pixelss (split-bytes pixels (* w h) 0)] #:last-frame-delay (last-frame-delay (or/c (integer-in 0 4294967295) false/c))
[last-pixels (last pixelss)]) #:loop? (Loop? (delay) (lambda (x) (and delay #t))))
(for-each (lambda (pixels) any)])
(when (or transparent delay)
(gif-add-control gif 'any #f (or delay 0) transparent)) (define (write-animated-gif bms delay filename
(gif-add-image gif 0 0 w h #f #f pixels) #:one-at-a-time? [one-at-a-time? #f]
(when (and last-frame-delay (eq? pixels last-pixels)) #:last-frame-delay [last-frame-delay #f]
(gif-add-control gif 'any #f last-frame-delay transparent) #:loop? [loop? (and delay #t)])
(gif-add-image gif 0 0 w h #f colormap pixels))) (write-gifs bms delay filename one-at-a-time? last-frame-delay loop?))
pixelss))
(gif-end gif)))))))))
(define (write-gif bm filename)
(write-gifs (list bm) #f filename #f #f #f))
(provide/contract
[write-animated-gif
(->i ((bms (and/c (listof (or/c (is-a?/c bitmap%) (-> (is-a?/c bitmap%)))) pair?))
(delay (integer-in 0 4294967295))
(filename (or/c path? string?)))
(#:one-at-a-time? (one-at-a-time? any/c)
#:last-frame-delay (last-frame-delay (or/c (integer-in 0 4294967295) false/c))
#:loop? (Loop? (delay) (lambda (x) (and delay #t))))
any)])
(define (write-animated-gif bms delay filename
#:one-at-a-time? [one-at-a-time? #f]
#:last-frame-delay [last-frame-delay #f]
#:loop? [loop? (and delay #t)])
(write-gifs bms delay filename one-at-a-time? last-frame-delay loop?))
)