add GIF parser

collects/racket/draw/bitmap.rkt

@@ -8,6 +8,7 @@
          "png.ss"
          "jpeg.ss"
          "xbm.ss"
+         "gif.rkt"
          "local.ss"
          "color.ss")
 
@@ -295,8 +296,15 @@
                           (values s #f)))))
                   (lambda ()
                     (destroy-decompress d))))]
-           [(gif gif/mask gif/alpha
+           [(gif gif/mask gif/alpha)
-                 bmp bmp/mask bmp/alpha)
+            (let-values ([(w h rows) (gif->rgba-rows in)])
+              (let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)]
+                     [alpha? #t]
+                     [pre? #f]
+                     [b&w? #f])
+                (install-from-png-arrays s w h rows b&w? alpha? pre? #f)
+                (values s b&w?)))]
+           [(bmp bmp/mask bmp/alpha)
             (let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 10 10)])
               (values s #f))]
            [(xbm xbm/alpha)

collects/racket/draw/gif.rkt

@@ -0,0 +1,176 @@
+#lang scheme
+(require "lzw.rkt")
+
+(provide gif->rgba-rows)
+
+(define-syntax-rule (when-debugging expr ...) 
+  #;(begin expr ...)
+  (void))
+
+(define-struct lsd (width height gt? res sort? gt-size bg-idx ratio))
+(define-struct img-desc (left top width height lct? interlace? sort? lct-size))
+(define-struct image (desc data ct))
+
+(define current-color-table
+  (make-parameter #f))
+
+(define (read-header p)
+  (unless (bytes=? (read-bytes 3 p) #"GIF")
+    (error "missing the GIF header"))
+  (let ([version (read-bytes 3 p)])
+    (cond
+      [(bytes=? version #"87a") 87]
+      [(bytes=? version #"89a") 89]
+      [else (error "unknown GIF version: ~a" version)])))
+
+(define (print-lsd l)
+  (printf "dimensions: ~a x ~a~n"
+          (lsd-width l) (lsd-height l))
+  (if (lsd-gt? l)
+      (printf "global color table of size ~a~n" (lsd-gt-size l))
+      (printf "no global color table~n"))
+  (printf "color res:~a~nsort?: ~a~n"
+          (lsd-res l) (lsd-sort? l))
+  (printf "bg-idx: ~a~naspect ratio:~a~n" 
+          (lsd-bg-idx l) (lsd-ratio l)))
+
+(define (read-lsd p)
+  (define block (read-bytes 7 p))
+  (unless (and (bytes? block)
+               (= (bytes-length block) 7))
+    (error "malformed Logical Screen Descriptor"))
+  (let ([packed-fields (bytes-ref block 4)])
+    (make-lsd (integer-bytes->integer block #f #f 0 2)
+              (integer-bytes->integer block #f #f 2 4)
+              (bitwise-bit-set? packed-fields 7)
+              (add1 (bitwise-bit-field packed-fields 4 7))
+              (bitwise-bit-set? packed-fields 3)
+              (expt 2 (add1 (bitwise-bit-field packed-fields 0 3)))
+              (bytes-ref block 5)
+              (bytes-ref block 6))))
+
+(define (read-ct size p)
+  (define res (make-bytes (* 3 size)))
+  (let ([n (read-bytes! res p)])
+    (unless (= n (* 3 size))
+      (error "Color Table unexpectedly ended")))
+  res)
+
+(define (print-argbs cs)
+  (define size (/ (bytes-length cs) 4))
+  (printf "size: ~a~n" size)
+  (for ([n (in-range size)])
+       (printf "color ~a: (~a, ~a, ~a, ~a)~n"
+               n
+               (bytes-ref cs (* 4 n))
+               (bytes-ref cs (+ 1 (* 4 n)))
+               (bytes-ref cs (+ 2 (* 4 n)))
+               (bytes-ref cs (+ 3 (* 4 n))))))
+
+(define (print-img-desc id)
+  (printf "pos: (~a, ~a)~n"
+          (img-desc-left id) (img-desc-top id))
+  (printf "dimensions: ~a x ~a~n"
+          (img-desc-width id) (img-desc-height id))
+  (if (img-desc-lct? id)
+      (printf "local color table of size ~a~n" (img-desc-lct-size id))
+      (printf "no local color table~n"))
+  (printf "interlaced?: ~a~nsort?: ~a~n"
+          (img-desc-interlace? id)
+          (img-desc-sort? id)))
+
+(define (read-img-desc p)
+  (define block (read-bytes 9 p))
+  (let ([packed-fields (bytes-ref block 8)])
+    (make-img-desc
+     (integer-bytes->integer block #f #f 0 2)
+     (integer-bytes->integer block #f #f 2 4)
+     (integer-bytes->integer block #f #f 4 6)
+     (integer-bytes->integer block #f #f 6 8)
+     (bitwise-bit-set? packed-fields 7)
+     (bitwise-bit-set? packed-fields 6)
+     (bitwise-bit-set? packed-fields 5)
+     (expt 2 (add1 (bitwise-bit-field packed-fields 0 3))))))
+
+(define (read-data-subblocks p)
+  (apply 
+   bytes-append
+   (let loop ([blocks null])
+     (let ([size (read-byte p)])
+       (cond
+         [(eof-object? size)
+          (error "Unexpected EOF")]
+         [(= size 0) (reverse blocks)]
+         [else
+          (loop (cons (read-bytes size p) blocks))])))))
+
+(define (read-image-table image-data p)
+  (define coding-bits (read-byte p))
+  (define lzw-data (read-data-subblocks p))
+  (lzw-decompress image-data coding-bits lzw-data))
+
+(define (read-image p)
+  (define id (read-img-desc p))
+  (define data (make-bytes (* (img-desc-width id) (img-desc-height id))))
+  (when-debugging
+   (print-img-desc id))
+  (parameterize ([current-color-table 
+                  (if (img-desc-lct? id)
+                      (read-ct (img-desc-lct-size id) p)
+                      (current-color-table))])
+    (when-debugging
+     (when (img-desc-lct? id)
+       (print-argbs (current-color-table))))
+    (read-image-table data p)
+    (make-image id data (current-color-table))))
+
+(define (read-gif p just-one?)
+  (define version (read-header p))
+  (define lsd (read-lsd p))
+  (define global-table
+    (and (lsd-gt? lsd)
+         (read-ct (lsd-gt-size lsd) p)))
+  (when-debugging
+   (printf "version: ~a~n" version)
+   (print-lsd lsd)
+   (when global-table
+     (print-argbs global-table)))
+  (parameterize ([current-color-table global-table])
+    (define parsed-blocks
+      (let loop ([parsed-blocks null])
+        (let ([id (read-byte p)])
+          (cond 
+            [(eof-object? id)
+             (error "Unexpected end of file")]
+            [(= id #x3b)
+             (reverse parsed-blocks)]
+            [(= id #x2c)
+             (let ([i (read-image p)])
+               (if just-one?
+                   i
+                   (loop (cons i parsed-blocks))))]
+            [else
+             (log-warning (format "gif: unhandled block type 0x~x~n" id))
+             (loop parsed-blocks)]))))
+    parsed-blocks))
+
+(define (gif->rgba-rows in)
+  (let ([i (read-gif in #t)])
+    (let* ([data (image-data i)]
+           [len (bytes-length data)]
+           [ct (image-ct i)]
+           [w (img-desc-width (image-desc i))]
+           [h (img-desc-height (image-desc i))])
+      (values
+       w
+       h
+       (list->vector
+        (for/list ([j (in-range h)])
+          (let ([bstr (make-bytes (* 4 w) 255)])
+            (let ([yp (* w j)])
+              (for ([i (in-range w)])
+                (let ([pos (* 3 (bytes-ref data (+ yp i)))])
+                  (bytes-set! bstr (* i 4) (bytes-ref ct pos))
+                  (bytes-set! bstr (+ 1 (* i 4)) (bytes-ref ct (+ 1 pos)))
+                  (bytes-set! bstr (+ 2 (* i 4)) (bytes-ref ct (+ 2 pos))))))
+            bstr)))))))

collects/racket/draw/lzw.rkt

@@ -0,0 +1,144 @@
+#lang racket/base
+
+;;; Translated from Skippy for Common Lisp:
+;;;
+;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+;;;
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;
+;;;; Id: lzw.lisp,v 1.11 2007/01/03 22:01:10 xach Exp
+
+(provide lzw-decompress)
+
+(define (make-input-bitstream bstr)
+  (let ([pos 0]
+        [val 0]
+        [bits 0]
+        [limit (bytes-length bstr)])
+    (lambda (n)
+      (let loop ()
+        (cond
+         [(n . <= . bits)
+          (begin0
+           (bitwise-and val (sub1 (arithmetic-shift 1 n)))
+           (set! val (arithmetic-shift val (- n)))
+           (set! bits (- bits n)))]
+         [(= pos limit)
+          (add1 (arithmetic-shift 1 n))]
+         [else
+          (set! val (bitwise-ior (arithmetic-shift (bytes-ref bstr pos) 
+                                                   bits)
+                                 val))
+          (set! pos (add1 pos))
+          (set! bits (+ 8 bits))
+          (loop)])))))
+
+(define (read-bits n bstream)
+  (bstream n))
+
+(define (lzw-decompress result-bstr code-size bstr)
+  (let* ((entries (make-vector 4096 -1))
+         (preds (make-vector 4096 -1))
+         (clear-code (expt 2 code-size))
+         (end-of-input (+ clear-code 1))
+         (next-entry-index (+ clear-code 2))
+         (compression-size (add1 code-size))
+         (compression-threshold (* clear-code 2))
+         (pos 0)
+         (bitstream (make-input-bitstream bstr)))
+    (for ([i (in-range clear-code)])
+      (vector-set! entries i i))
+    (letrec ([reset-table 
+              (lambda ()
+                (vector-fill! preds -1)
+                (for ([i (in-range clear-code 4096)])
+                  (vector-set! entries i -1))
+                (set! next-entry-index (+ clear-code 2))
+                (set! compression-size (add1 code-size))
+                (set! compression-threshold (* clear-code 2)))]
+             [root-value 
+              (lambda (code)
+                (let loop ([code code])
+                  (let ([pred (vector-ref preds code)])
+                    (if (negative? pred)
+                        (vector-ref entries code)
+                        (loop pred)))))]
+             [increase-compression-size!
+              (lambda ()
+                (set! compression-size (min 12 (add1 compression-size)))
+                (set! compression-threshold (* compression-threshold 2)))]
+             [add-entry 
+              (lambda (entry pred)
+                (when (>= pred next-entry-index)
+                  (error "Corrupt data in LZW stream"))
+                (vector-set! preds next-entry-index pred)
+                (vector-set! entries next-entry-index entry)
+                (let ([result next-entry-index])
+                  (set! next-entry-index (add1 next-entry-index))
+                  (when (>= next-entry-index compression-threshold)
+                    (increase-compression-size!))
+                  result))]
+             [code-depth 
+              (lambda (code)
+                (let loop ([depth 0][code code])
+                  (let ([pred (vector-ref preds code)])
+                    (if (negative? pred)
+                        depth
+                        (loop (add1 depth) pred)))))]
+             [output-code-string 
+              (lambda (code)
+                (let ([j pos])
+                  (let ([i (+ pos (code-depth code))])
+                  (set! pos (add1 i))
+                  (if (>= i (bytes-length result-bstr))
+                      (log-warning "Too much input data for image, ignoring extra")
+                      (let loop ([code code]
+                                 [i i])
+                        ;; (printf "set ~a\n" (vector-ref entries code))
+                        (bytes-set! result-bstr i (vector-ref entries code))
+                        (when (i . > . j)
+                          (loop (vector-ref preds code)
+                                (sub1 i))))))))])
+      (let loop ([last-code -1])
+        (let ([code (read-bits compression-size bitstream)])
+          ;; (printf "~s: ~s ~s ~s\n" compression-size code clear-code end-of-input)
+          (cond 
+           [(= code clear-code)
+            (reset-table)
+            (loop -1)]
+           [(= code end-of-input)
+            (void)]
+           [(= last-code -1)
+            (output-code-string code)
+            (loop code)]
+           [else
+            (let ([entry (vector-ref entries code)])
+              (if (negative? entry)
+                  (let ([root (root-value last-code)])
+                    (output-code-string (add-entry root last-code)))
+                  (let ([root (root-value code)])
+                    (add-entry root last-code)
+                    (output-code-string code))))
+            (loop code)]))))))