add GIF parser
This commit is contained in:
Matthew Flatt
parent
5bef90e197
commit
41ce8ece58
|
|
@ -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
|
||||
bmp bmp/mask bmp/alpha)
|
||||
[(gif gif/mask gif/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)
|
||||
|
|
|
|||
176
collects/racket/draw/gif.rkt
Normal file
176
collects/racket/draw/gif.rkt
Normal file
|
|
@ -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)))))))
|
||||
144
collects/racket/draw/lzw.rkt
Normal file
144
collects/racket/draw/lzw.rkt
Normal file
|
|
@ -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)]))))))
|
||||
Loading…
Reference in New Issue
Block a user