diff --git a/collects/mrlib/gif.ss b/collects/mrlib/gif.ss index dbe9404650..19bad3e77a 100644 --- a/collects/mrlib/gif.ss +++ b/collects/mrlib/gif.ss @@ -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?)) ) - - \ No newline at end of file diff --git a/collects/net/gifwrite.ss b/collects/net/gifwrite.ss index a023fe9478..c830e07f6c 100644 --- a/collects/net/gifwrite.ss +++ b/collects/net/gifwrite.ss @@ -67,7 +67,11 @@ [(16) 4] [(32) 5] [(64) 6] - [(128) 7])) + [(128) 7] + [(256) 8] + [else (error 'bits-per-pixel + "strange colormap size: ~e" + (length ColorMap))])) (define (WRITE g bytes) (write-bytes bytes (gif-stream-port g))) @@ -197,7 +201,8 @@ (check-line-bytes (length cmap) Line) (EGifCompress GifFile - (bits-per-pixel cmap) + (max 2 ;; min code size of LZW is 2 + (bits-per-pixel cmap)) Line)) (set-gif-stream-FileState! GifFile 'image-or-control)) @@ -437,13 +442,16 @@ (let* ([len (quotient (bytes-length argb) 4)] [result (make-bytes len)]) (let loop ([masks (list + ;; 8 bits per color (lambda (v) v) + ;; 4 bits per color (lambda (v) (bitwise-ior (bitwise-ior v (arithmetic-shift (bitwise-and v #x55) 1)) (arithmetic-shift (bitwise-and v #xCC) -1))) + ;; 1 bit per color (lambda (v) (if (v . > . 127) 255