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

add one-by-one mode to gif-animation library, and fix gif writer for monochrome images

Browse Source 
svn: r6065

original commit: ea91e1a8c59dd95cdf8926cb2614aa835ef3cd45
This commit is contained in:
Matthew Flatt 2007-04-28 03:38:42 +00:00
parent 456075b97f
commit 9992465419
1 changed files with 54 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
collects/mrlib/gif.ss
View File

@ -3,50 +3,73 @@
(require (lib "class.ss")
(lib "file.ss")
(lib "mred.ss" "mred")
(lib "gifwrite.ss" "net"))
(lib "gifwrite.ss" "net")
(lib "contract.ss")
(lib "kw.ss")
(lib "etc.ss"))
(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)
(let ([w (send (car bms) get-width)]
[h (send (car bms) get-height)])
(let ([argbs
(define (write-gifs bms delay filename one-at-a-time?)
(let* ([init (force-bm (car bms))]
[w (send init get-width)]
[h (send init get-height)])
(let ([argb-thunks
(map (lambda (bm)
(let ([argb (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h argb)
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h argb #t)))
argb))
bms)])
(let-values ([(pixels colormap transparent)
(quantize (apply bytes-append argbs))])
(call-with-output-file*
filename
(lambda (p)
(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))
(gif-end gif))))))))
(lambda ()
(let ([bm (force-bm bm)]
[argb (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h argb)
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h argb #t)))
argb)))
(cons init (cdr bms)))])
(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 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)
(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*
filename
(lambda (p)
(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))
(gif-end gif)))))))))
(define (write-gif bm filename)
(write-gifs (list bm) #f filename))
(write-gifs (list bm) #f filename #f))
(define (write-animated-gif bms delay filename)
(write-gifs bms delay filename))
(define/kw (write-animated-gif bms delay filename #:key [one-at-a-time? #f])
(write-gifs bms delay filename one-at-a-time?))
)