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

svn: r6065

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?))
 
   )
-
-               

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