From 4fba4a4edf357b11fad695e1b9a87fe73305d71e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 6 Jan 2007 23:33:50 +0000 Subject: [PATCH] new library for writing GIF files svn: r5235 --- collects/net/doc.txt | 191 +++++++++++++++ collects/net/gifwrite.ss | 502 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 693 insertions(+) create mode 100644 collects/net/gifwrite.ss diff --git a/collects/net/doc.txt b/collects/net/doc.txt index 86735b0256..3fff117a29 100644 --- a/collects/net/doc.txt +++ b/collects/net/doc.txt @@ -2271,3 +2271,194 @@ PROCEDURES ----------------------------------------------------------- 'amp-or-semi name=shriram&host=nw name=shriram;host=nw or name=shriram;host=nw + +========================================================================== +_GIF_ writing, _animated GIF_ writing +========================================================================== + +To load directly: (require (lib "gifwrite.ss" "net")) + +ABSTRACT ------------------------------------------------------------- + +The gifwrite package provides functions for writing GIF files to a +stream, including GIF files with multiple images and controls (such as +animated GIFs). + +TYPES ---------------------------------------------------------------- + +> gif-stream + +A GIF stream is created by `gif-start'. + +A stream can be in a number of states: + + * 'init : no images or controls have been added to the stream + * 'image-or-control : another image or control can be written now + * 'image : another image can be written now (since a control was + written) + * 'done : nothing more can be added + +> dimension + +An exact integer between 0 and #xFFFFFFFF, inclusive. + +> color + +An exact integer between 0 and 255, inclusive, indicating an index in +a color map. + +> colormap + +A list of vectors; each vector must contain three color values: one +for red, one for blue, and one for green. The list length must be 2, +4, 8, 16, 32, 64, 128, or 256. The colors are indexed (starting from +0) by their order in the list. + +PROCEDURES ----------------------------------------------------------- + +> (gif-start output-port width-dimension height-dimension bg-color colormap-or-#f) + +Writes the start of a GIF file to the given output port, and returns +a GIF stream that adds to the output port. + +The width and height determine a virtual space for the overall GIF +image. Individual images added to the GIF stream must fit within this +virtual space. The space is initialized by the given background color. + +Finally, the default meaning of color numbers (such as the background +color) is determined by the given colormap, but individual images +within the GIF file can have their own colormaps. + +A global colormap need not be supplied, in which case a colormap must +be supplied for each image. Beware that the bg-color is ill-defined if +a global colormap is not provided. + +> (gif-end gif-stream) + +Finishes writing a GIF file. The GIF stream's output port is not +automatically closed. + +An exception is raised if an image-control command was just written to +the stream (so that an image is required next). + +> (gif-add-image gif-stream left-dimension + top-dimension + width-dimension + height-dimension + interlaced? + colormap-or-#f + bytes) + +Writes an image to the given GIF stream. The left, top, width, and +height values specify the location and size of the image within the +overall GIF image's virtual space. + +If `interlaced?' is true, then `bytes' should provide bytes in +interlaced order instead of top-to-bottom order. Interlaced order is: + * every 8th row, starting with 0 + * every 8th row, starting with 4 + * every 4th row, starting with 2 + * every 2nd row, starting with 1 + +If a global color is provided with `gif-start', a #f value can be +provide instead of a colormap. + +The `bytes' argument specifies the pixel content of the image. Each +byte specifies a color (i.e., an index in the colormap). Each row is +provided left-to-right, and the rows provided either top-to-bottom or +in interlaced order (see above). If the image is prefixed with a +control that specifies an transparent index (see `gif-add-control'), +then the corresponding "color" doesn't draw into the overall GIF +image. + +An exception is raised if any byte value in `bytes' is larger than the +colormap's length, if the `bytes' length is not `width' times +`height', or if the top, left, width, and height dimensions specify a +region beyond the overall GIF image's virtual space. + +> (gif-add-control gif-stream disposal-symbol + wait-for-input? + delay-dimension + transparent-color-or-#f) + +Writes an image-control command to a GIF stream. Such a control must +appear just before an image, and it applies to the following image. + +The GIF image model involves processing images one by one, placing +each image into the specified position within the overall image's +virtual space. An image-control command can specify a delay before an +image is added (to create animated GIFs), and it also specifies how +the image should be kept or removed from the overall image before +proceeding to the next one (also for GIF animation). + +The `disposal-symbol' argument specifies how to proceed: + + - 'any : doesn't matter (perhaps because the next image + completely overwrites the current one) + - 'keep : leave the image in place + - 'restore-bg : replace the image with the background color + - 'restore-prev : restore the overall image content to the + content before the image is added + +If `wait-for-input?' is true, then the display program may wait for +some cue from the user (perhaps a mouse click) before adding the +image. + +The `delay-dimension' argument specifies a delay in 1/100s of a +second. + +If the `transparent-color-or-#f' argument is a color, then it +determines an index that is used to reprsent transparent pixels in the +follow image (as opposed to the color specified by the colormap for +the index). + +An exception is raised if a control is already added to `gif-stream' +without a corresponding image. + +> (gif-add-loop-control gif-stream iteration-dimension) + +Writes an control command to a GIF stream for which no images or other +commands have already been written. The command causes the animating +sequence of images in the GIF to be repeated `iteration-dimension' +times, where 0 can be used to mean "infinity". + +An exception is raise if some control or image has been added to the +stream already. + +> (gif-add-comment gif-stream bytes) + +Adds a generic comment to the GIF stream. + +An exception is raised if an image-control command was just written to +the stream (so that an image is required next). + +> (quantize argb-bytes) + +Eachimage in a GIF stream is limited to 256 colors, including the +transparent "color", if any. The `quantize' function helps converts a +24-bit image (plus alpha channel) into an indexed-color image,reducing +the number of colors if necessary. + +Given a set of pixels expressed in ARGB format (i.e., each four bytes +is a set of values for one pixel: alpha, red, blue, and green), +`quantize' produces produces + + - bytes for the image (i.e., a array of colors, expressed as a byte + string) + + - a colormap + + - either #f or a color index for the transparent "color" + +The conversion treats alpha values less than 128 as transparent +pixels, and other alpha values as solid. + +The quantization process first attempts to use all (non-transparent) +colors in the image. if that fails, it reduces the image to 12-bit +color (3 bits per each of red, green, and blue) by rounding up pixel +values, and tries again. If that fails, it reduces the image to 6-bit +color (2 bits per each of red, green, and blue). + +To convert a collection of images all with the same quantization, +simply append them for the input of a single call of `quantize', and +then break apart the result bytes. diff --git a/collects/net/gifwrite.ss b/collects/net/gifwrite.ss new file mode 100644 index 0000000000..a023fe9478 --- /dev/null +++ b/collects/net/gifwrite.ss @@ -0,0 +1,502 @@ +#| +/****************************************************************************** + * "Gif-Lib" - Yet another gif library. + * + * Written by: Gershon Elber Ver 1.1, Aug. 1990 + ****************************************************************************** + * The kernel of the GIF Encoding process can be found here. + ****************************************************************************** + * History: + * 14 Jun 89 - Version 1.0 by Gershon Elber. + * 3 Sep 90 - Version 1.1 by Gershon Elber (Support for Gif89, Unique names). + * 26 Jun 96 - Version 3.0 by Eric S. Raymond (Full GIF89 support) + * 5 Jan 07 - Ported to MzScheme by Matthew + *****************************************************************************/ +|# + +(module gifwrite mzscheme + (require (lib "contract.ss")) + + (define LZ_MAX_CODE 4095) + + (define GifVersionPrefix #"GIF89a") + + (define-struct gif-stream (port + SWidth + SHeight + SBackGroundColor + SColorMap + FileState)) + + (define (image-ready-gif-stream? g) + (and (gif-stream? g) + (memq (gif-stream-FileState g) '(init image-or-control image)))) + + (define (image-or-control-ready-gif-stream? g) + (and (gif-stream? g) + (memq (gif-stream-FileState g) '(init image-or-control)))) + + (define (empty-gif-stream? g) + (and (gif-stream? g) + (memq (gif-stream-FileState g) '(init)))) + + (define color? byte?) + (define (dimension? x) (and (exact? x) (integer? x) (<= 0 x #xFFFF))) + (define (disposal? s) + (memq s '(any keep restore-bg restore-prev))) + + (define (color-map? l) + (and (list? l) + (member (length l) '(2 4 8 16 32 64 128 256)) + (andmap (lambda (c) + (and (vector? c) + (= 3 (vector-length c)) + (color? (vector-ref c 0)) + (color? (vector-ref c 1)) + (color? (vector-ref c 2)))) + l))) + + (define (color-map->bytes ColorMap) + (apply bytes (apply append (map vector->list ColorMap)))) + + (define (bits-per-pixel ColorMap) + (case (length ColorMap) + [(2) 1] + [(4) 2] + [(8) 3] + [(16) 4] + [(32) 5] + [(64) 6] + [(128) 7])) + + (define (WRITE g bytes) + (write-bytes bytes (gif-stream-port g))) + + (provide/contract [gif-state + (gif-stream? . -> . symbol?)]) + (define (gif-state GifFile) + (gif-stream-FileState GifFile)) + + ;;/****************************************************************************** + ;; * This routine should be called before any other EGif calls, immediately + ;; * follows the GIF file openning. + ;; *****************************************************************************/ + (provide/contract [gif-start + (output-port? + dimension? + dimension? + color? + (or/c false/c color-map?) + . -> . gif-stream?)]) + (define (gif-start port + Width + Height + BackGround + ColorMap) + (define GifFile + (make-gif-stream port + Width + Height + BackGround + ColorMap + 'init)) + + (when ColorMap + (unless (BackGround . < . (length ColorMap)) + (error 'gif-start + "background color ~a is out of range for the color map: ~e" + BackGround + ColorMap))) + + (WRITE GifFile GifVersionPrefix) + + ;;/* + ;; * Put the logical screen descriptor into the file: + ;; */ + ;;/* Logical Screen Descriptor: Dimensions */ + (EGifPutWord Width GifFile) + (EGifPutWord Height GifFile) + + ;;/* Logical Screen Descriptor: Packed Fields */ + ;;/* Note: We have actual size of the color table default to the largest + ;; * possible size (7+1 == 8 bits) because the decoder can use it to decide + ;; * how to display the files. + ;; */ + (WRITE GifFile + (bytes (bitwise-ior + (if ColorMap #x80 #x00) + (arithmetic-shift #x7 4) ; /* Bits originally allocated to each primary color */ + (if ColorMap (sub1 (bits-per-pixel ColorMap)) #x07)) ; /* Actual size of the color table. */ + BackGround ; /* Index into the ColorTable for background color */ + 0)) ; /* Pixel Aspect Ratio */ + + ;; /* If we have Global color map - dump it also: */ + (when ColorMap + (WRITE GifFile (color-map->bytes ColorMap))) + + GifFile) + + ;;/****************************************************************************** + ;; * This routine should be called before any attempt to dump an image - any + ;; * call to any of the pixel dump routines. + ;; *****************************************************************************/ + (provide/contract [gif-add-image + (image-ready-gif-stream? + dimension? + dimension? + dimension? + dimension? + any/c + (or/c false/c color-map?) + bytes? + . -> . any)]) + (define (gif-add-image GifFile + Left + Top + Width + Height + Interlace + ColorMap + Line) + + (unless ColorMap + (unless (gif-stream-SColorMap GifFile) + (error 'gif-add-image + "no color map for image"))) + + (unless (= (bytes-length Line) + (* Width Height)) + (error 'gif-add-image + "bytes string size doesn't match width times height: ~e" + Line)) + + (unless (and ((+ Left Width) . <= . (gif-stream-SWidth GifFile)) + ((+ Top Height) . <= . (gif-stream-SHeight GifFile))) + (error 'gif-add-image + "image extends beyond GIF virtual screen")) + + (WRITE GifFile #",") ; /* Image seperator character. */ + (EGifPutWord Left GifFile) + (EGifPutWord Top GifFile) + (EGifPutWord Width GifFile) + (EGifPutWord Height GifFile) + (WRITE GifFile + (bytes + (bitwise-ior + (if ColorMap #x80 #x00) + (if Interlace #x40 #x00) + (if ColorMap (sub1 (bits-per-pixel ColorMap)) #x00)))) + + ;; /* If we have local color map - dump it also: */ + (when ColorMap + (WRITE GifFile (color-map->bytes ColorMap))) + + (let* ([cmap (or ColorMap + (gif-stream-SColorMap GifFile))]) + + (check-line-bytes (length cmap) Line) + + (EGifCompress GifFile + (bits-per-pixel cmap) + Line)) + + (set-gif-stream-FileState! GifFile 'image-or-control)) + + (define (check-line-bytes sz Line) + (let loop ([i (bytes-length Line)]) + (unless (zero? i) + (let ([i (sub1 i)]) + (unless ((bytes-ref Line i) . < . sz) + (error 'gif-add-image + "out-of-range color index ~a in line: ~e" + (bytes-ref Line i) + Line)) + (loop i))))) + + + ;;/****************************************************************************** + ;; * This routine should be called to add graphic control before the next image + ;; *****************************************************************************/ + (provide/contract [gif-add-control + (image-or-control-ready-gif-stream? + disposal? + any/c + dimension? + (or/c false/c color?) + . -> . any)]) + (define (gif-add-control GifFile + Disposal + UserInput? + Delay ; 1/100s of a second + TransparentColor) + (WRITE GifFile #"\x21\xF9\x04") + (WRITE GifFile + (bytes (bitwise-ior + (case Disposal + [(any) 0] + [(keep) #x4] + [(restore-bg) #x8] + [(restore-prev) #xC]) + (if UserInput? #x2 0) + (if TransparentColor #x1 0)))) + (EGifPutWord Delay GifFile) + (WRITE GifFile (bytes + (or TransparentColor 0) + 0)) ; block terminator + (set-gif-stream-FileState! GifFile 'image)) + + ;;/****************************************************************************** + ;; * This routine should be called to add the "loop" graphic control + ;; before adding any images + ;; *****************************************************************************/ + (provide/contract [gif-add-loop-control + (empty-gif-stream? + dimension? + . -> . any)]) + (define (gif-add-loop-control GifFile + Iterations) + (WRITE GifFile #"\x21\xFF\x0BNETSCAPE2.0\x03\x01") + (EGifPutWord Iterations GifFile) + (WRITE GifFile #"\x00") + (set-gif-stream-FileState! GifFile 'image-or-control)) + + ;;/****************************************************************************** + ;; * This routine should be called to add arbitrary comment text + ;; *****************************************************************************/ + (provide/contract [gif-add-comment + (image-or-control-ready-gif-stream? + bytes? + . -> . any)]) + (define (gif-add-comment GifFile + Str) + (WRITE GifFile #"\x21\xFE") + (let loop ([pos 0]) + (when (pos . < . (bytes-length Str)) + (let ([amt (min 255 (- (bytes-length Str) pos))]) + (write-byte amt (gif-stream-port GifFile)) + (write-bytes Str (gif-stream-port GifFile) pos (+ pos amt)) + (loop (+ pos amt))))) + (WRITE GifFile #"\0") + (set-gif-stream-FileState! GifFile 'image-or-control)) + + ;;/****************************************************************************** + ;; * This routine should be called last, to end GIF file. + ;; *****************************************************************************/ + (provide/contract [gif-end + (image-or-control-ready-gif-stream? + . -> . any)]) + (define (gif-end GifFile) + (WRITE GifFile #";") + (set-gif-stream-FileState! GifFile 'done)) + + ;;/****************************************************************************** + ;; * Put 2 bytes (word) into the given file: + ;; *****************************************************************************/ + (define (EGifPutWord Word GifFile) + (WRITE GifFile (integer->integer-bytes Word 2 #f #f))) + + ;;/****************************************************************************** + ;; * LZ compression output + ;; *****************************************************************************/ + (define (write-buffered-byte b buf port) + (let ([cnt (add1 (bytes-ref buf 0))]) + (bytes-set! buf cnt b) + (bytes-set! buf 0 cnt) + (when (= cnt 255) + (write-bytes buf port) + (bytes-set! buf 0 0)))) + + (define (CompressOutput port buf Code + RunningBits RunningCode MaxCode1 + CrntShiftState CrntShiftDWord) + (let-values ([(CrntShiftState CrntShiftDWord) + (let loop ([CrntShiftDWord (bitwise-ior + CrntShiftDWord + (arithmetic-shift Code CrntShiftState))] + [CrntShiftState (+ CrntShiftState RunningBits)]) + (if (CrntShiftState . >= . 8) + (begin + (write-buffered-byte (bitwise-and CrntShiftDWord #xff) buf port) + (loop (arithmetic-shift CrntShiftDWord -8) + (- CrntShiftState 8))) + (values CrntShiftState CrntShiftDWord)))]) + (if (and (RunningCode . >= . MaxCode1) + (Code . <= . 4095)) + (values (add1 RunningBits) (arithmetic-shift 1 (add1 RunningBits)) + CrntShiftState CrntShiftDWord) + (values RunningBits MaxCode1 + CrntShiftState CrntShiftDWord)))) + + ;;/****************************************************************************** + ;; * LZ compression + ;; *****************************************************************************/ + (define (EGifCompress GifFile BitsPerPixel Line) + + (WRITE GifFile (bytes BitsPerPixel)) + + (let* ([ClearCode (arithmetic-shift 1 BitsPerPixel)] + [EOFCode (add1 ClearCode)] + [RunningCode (add1 EOFCode)] + [RunningBits (add1 BitsPerPixel)]; /* Number of bits per code. */ + [MaxCode1 (arithmetic-shift 1 RunningBits)]; /* Max. code + 1. */ + [HashTable (make-hash-table)] + [CrntShiftState 0]; /* No information in CrntShiftDWord. */ + [CrntShiftDWord 0] + [port (gif-stream-port GifFile)] + [len (bytes-length Line)] + [buf (make-bytes 256 0)]) + + (let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord) + (CompressOutput port buf ClearCode + RunningBits RunningCode MaxCode1 + CrntShiftState CrntShiftDWord)]) + (let loop ([CrntCode (bytes-ref Line 0)] + [RunningCode RunningCode] + [RunningBits RunningBits] + [MaxCode1 MaxCode1] + [CrntShiftState CrntShiftState] + [CrntShiftDWord CrntShiftDWord] + [HashTable HashTable] + [i 1]) + (if (= i len) + ;; Finish: + (let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord) + (CompressOutput port buf CrntCode + RunningBits RunningCode MaxCode1 + CrntShiftState CrntShiftDWord)]) + (let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord) + (CompressOutput port buf EOFCode + RunningBits RunningCode MaxCode1 + CrntShiftState CrntShiftDWord)]) + ;; Flush output: + (let loop ([CrntShiftState CrntShiftState] + [CrntShiftDWord CrntShiftDWord]) + (when (CrntShiftState . > . 0) + (write-buffered-byte (bitwise-and CrntShiftDWord #xff) buf port) + (loop (arithmetic-shift CrntShiftDWord -8) + (- CrntShiftState 8)))) + (unless (zero? (bytes-ref buf 0)) + (write-bytes buf port 0 (add1 (bytes-ref buf 0)))) + (write-bytes #"\0" port))) + ;; /* Get next pixel from stream. */ + (let ([Pixel (bytes-ref Line i)]) + ;; /* Form a new unique key to search hash table for the code combines + ;; * CrntCode as Prefix string with Pixel as postfix char. + ;; */ + (let* ([NewKey (bitwise-ior (arithmetic-shift CrntCode 8) Pixel)] + [NewCode (hash-table-get HashTable NewKey #f)]) + (if NewCode + ;;/* This Key is already there, or the string is old one, so + ;; * simple take new code as our CrntCode: + ;; */ + (loop NewCode + RunningCode RunningBits MaxCode1 + CrntShiftState CrntShiftDWord + HashTable (add1 i)) + ;;/* Put it in hash table, output the prefix code, and make our + ;; * CrntCode equal to Pixel. */ + (let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord) + (CompressOutput port buf CrntCode + RunningBits RunningCode MaxCode1 + CrntShiftState CrntShiftDWord)]) + (let ([CrntCode Pixel]) + ;; /* If however the HashTable if full, we send a clear first and + ;; * Clear the hash table. */ + (if (RunningCode . >= . LZ_MAX_CODE) + ;; /* Time to do some clearance: */ + (let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord) + (CompressOutput port buf ClearCode + RunningBits RunningCode MaxCode1 + CrntShiftState CrntShiftDWord)]) + (loop CrntCode + (add1 EOFCode) (add1 BitsPerPixel) (arithmetic-shift 1 (add1 BitsPerPixel)) + CrntShiftState CrntShiftDWord + (make-hash-table) (add1 i))) + ;; /* Put this unique key with its relative Code in hash table: */ + (begin + (hash-table-put! HashTable NewKey RunningCode) + (loop CrntCode + (add1 RunningCode) RunningBits MaxCode1 + CrntShiftState CrntShiftDWord + HashTable (add1 i)))))))))))))) + + ;;/****************************************************************************** + ;; * color quantization utility + ;; *****************************************************************************/ + + (define (argb-bytes? b) + (and (bytes? b) + (zero? (remainder (bytes-length b) 4)))) + + (provide/contract + [quantize ((argb-bytes?) + . ->* . + (bytes? color-map? (or/c false/c color?)))]) + + (define (quantize argb) + (let* ([len (quotient (bytes-length argb) 4)] + [result (make-bytes len)]) + (let loop ([masks (list + (lambda (v) v) + (lambda (v) + (bitwise-ior + (bitwise-ior + v + (arithmetic-shift (bitwise-and v #x55) 1)) + (arithmetic-shift (bitwise-and v #xCC) -1))) + (lambda (v) + (if (v . > . 127) + 255 + 0)))]) + (let ([mask (car masks)] + [transparent #f] + [table (make-hash-table 'equal)] + [idx 0]) + ;; Iterate over image to count colors + ;; (as reduced by mask) + (let loop ([i 0][pos 0]) + (unless (= i len) + (let ([this-idx + (if ((bytes-ref argb pos) . < . 128) + (begin + (unless transparent + (set! transparent idx) + (set! idx (add1 idx))) + transparent) + (let ([vec (vector + (mask (bytes-ref argb (+ 1 pos))) + (mask (bytes-ref argb (+ 2 pos))) + (mask (bytes-ref argb (+ 3 pos))))]) + (let ([v (hash-table-get table vec #f)]) + (or v + (begin + (hash-table-put! table vec idx) + (set! idx (add1 idx)) + (sub1 idx))))))]) + (bytes-set! result i (min 255 this-idx))) + (loop (add1 i) (+ pos 4)))) + (if ((hash-table-count table) . > . (if transparent + 255 + 256)) + ;; Try again + (loop (cdr masks)) + ;; Found an ok quantization + (values result + (let* ([cnt (+ (hash-table-count table) + (if transparent 1 0))] + [size (cond + [(<= cnt 2) 2] + [(<= cnt 4) 4] + [(<= cnt 8) 8] + [(<= cnt 16) 16] + [(<= cnt 32) 32] + [(<= cnt 64) 64] + [(<= cnt 128) 128] + [else 256])] + [t (make-vector size #(0 0 0))]) + (hash-table-for-each + table + (lambda (k v) + (vector-set! t v k))) + (vector->list t)) + transparent)))))))