MrEd bridge to GIF-writing library

svn: r5236

collects/mrlib/gif.ss

@@ -0,0 +1,52 @@
+
+(module gif mzscheme
+  (require (lib "class.ss")
+           (lib "file.ss")
+           (lib "mred.ss" "mred")
+           (lib "gifwrite.ss" "net"))
+
+  (provide write-gif
+           write-animated-gif)
+
+  (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
+             (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))))))))
+
+  (define (write-gif bm filename)
+    (write-gifs (list bm) #f filename))
+
+  (define (write-animated-gif bms delay filename)
+    (write-gifs bms delay filename))
+
+  )
+
+