diff --git a/collects/file/gif.ss b/collects/file/gif.ss index 3fd39545c3..a866c68201 100644 --- a/collects/file/gif.ss +++ b/collects/file/gif.ss @@ -1,4 +1,682 @@ -#lang scheme/base +#| +/****************************************************************************** + * "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 + *****************************************************************************/ +|# -(require net/gifwrite) -(provide (all-from-out net/gifwrite)) +#reader scribble/reader +(module gif scheme/base + (require scheme/contract + scribble/srcdoc) + + (require/doc scheme/base + scribble/manual) + + (define LZ_MAX_CODE 4095) + + (define GifVersionPrefix #"GIF89a") + + (provide/doc + (proc-doc gif-stream? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write], + @scheme[#f] otherwise.}) + (proc-doc image-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is not in + @scheme['done] mode, @scheme[#f] otherwise.}) + (proc-doc image-or-control-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is in + @scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.}) + (proc-doc empty-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[#t] if @scheme[v] is a GIF stream that in + @scheme['init] mode, @scheme[#f] otherwise.}) + (proc-doc gif-colormap? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[#t] if @scheme[v] represets a colormap, @scheme[#f] otherwise. + A colormap is a list whose size is a power of @math{2} between @math{2^1} and @math{2^8}, + and whose elements are vectors of size 3 containing colors + (i.e., exact integers between @math{0} and @math{255} inclusive).}) + (proc-doc color? (([v any/c]) () . ->d . [_ boolean?]) + @{The same as @scheme[byte?].}) + (proc-doc dimension? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[#t] if @scheme[v] is an exact integer between + @scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f] + otherwise.})) + + (define-struct gif-stream (port + SWidth + SHeight + SBackGroundColor + SColorMap + [FileState #:mutable])) + + (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 (gif-colormap? 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] + [(256) 8] + [else (error 'bits-per-pixel + "strange colormap size: ~e" + (length ColorMap))])) + + (define (WRITE g bytes) + (write-bytes bytes (gif-stream-port g))) + + (provide/doc (proc-doc gif-state (([stream gif-stream?]) () . ->d . [_ symbol?]) + @{Returns the state of @scheme[stream].})) + (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/doc (proc-doc + gif-start + (([out output-port?] + [w dimension?] + [h dimension?] + [bg-color color?] + [cmap (or/c false/c gif-colormap?)]) + () + . ->d . [_ gif-stream?]) + @{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.})) + (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/doc (proc-doc + gif-add-image + (([stream image-ready-gif-stream?] + [left dimension?] + [top dimension?] + [width dimension?] + [height dimension?] + [interlaced? any/c] + [cmap (or/c false/c gif-colormap?)] + [bstr bytes?]) + () + . ->d . [_ void?]) + @{Writes an image to the given GIF stream. The @scheme[left], @scheme[top], + @scheme[width], and @scheme[height] values specify the location and + size of the image within the overall GIF image's virtual space. + + If @scheme[interlaced?] is true, then @scheme[bstr] should provide bytes + ininterlaced order instead of top-to-bottom order. Interlaced order is: + + @(itemize + @item{every 8th row, starting with 0} + @item{every 8th row, starting with 4} + @item{every 4th row, starting with 2} + @item{every 2nd row, starting with 1}) + + If a global color is provided with @scheme[gif-start], a @scheme[#f] value + can be provided for @scheme[cmap]. + + The @scheme[bstr] 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 @scheme[gif-add-control]), + then the corresponding ``color'' doesn't draw into the overall GIF + image. + + An exception is raised if any byte value in @scheme[bstr] is larger than the + colormap's length, if the @scheme[bstr] length is not @scheme[width] times + @scheme[height], or if the @scheme[top], @scheme[left], @scheme[width], and + @scheme[height] dimensions specify a region beyond the overall GIF image's + virtual space.})) + (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 + (max 2 ;; min code size of LZW is 2 + (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/doc (proc-doc + gif-add-control + (([stream image-or-control-ready-gif-stream?] + [disposal (one-of/c 'any 'keep 'restore-bg 'restore-prev)] + [wait-for-input? any/c] + [delay dimension?] + [transparent (or/c false/c color?)]) + () + . ->d . [_ void?]) + @{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 @scheme[disposal] argument specifies how to proceed: + + @(itemize + @item{@scheme['any] : doesn't matter (perhaps because the next image + completely overwrites the current one)} + @item{@scheme['keep] : leave the image in place} + @item{@scheme['restore-bg] : replace the image with the background color} + @item{@scheme['restore-prev] : restore the overall image content to the + content before the image is added}) + + If @scheme[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 @scheme[delay] argument specifies a delay in 1/100s of a + second. + + If the @scheme[transparent] argument is a color, then it + determines an index that is used to represent 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 @scheme[stream] + without a corresponding image.})) + + (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/doc (proc-doc + gif-add-loop-control + (([stream empty-gif-stream?] + [iteration dimension?]) + () + . ->d . [_ void?]) + @{Writes a 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.})) + (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/doc (proc-doc + gif-add-comment + (([stream image-or-control-ready-gif-stream?] + [bstr bytes?]) + () + . ->d . [_ void?]) + @{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).})) + (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/doc (proc-doc + gif-end + (([stream image-or-control-ready-gif-stream?]) + () + . ->d . [_ void?]) + @{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).})) + (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-hasheq)] + [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-ref 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-hasheq) (add1 i))) + ;; /* Put this unique key with its relative Code in hash table: */ + (begin + (hash-set! 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/doc + (proc-doc quantize + (([bstr argb-bytes?]) + () + . ->d . + (values [_ bytes?] [_ gif-colormap?] [_ (or/c false/c color?)])) + @{Each + image in a GIF stream is limited to 256 colors, including the + transparent ``color,'' if any. The @scheme[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), + @scheme[quantize] produces produces + + @(itemize + @item{bytes for the image (i.e., a array of colors, expressed as a byte string)} + @item{a colormap} + @item{either @scheme[#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 @scheme[quantize], and + then break apart the result bytes.})) + (define (quantize argb) + (let* ([len (quotient (bytes-length argb) 4)] + [result (make-bytes len)] + [rgb-key (lambda (r g b) + (bitwise-ior (bitwise-ior + (arithmetic-shift r 16) + (arithmetic-shift g 8)) + b))] + [key->rgb (lambda (k) + (vector (arithmetic-shift k -16) + (bitwise-and #xFF (arithmetic-shift k -8)) + (bitwise-and #xFF k)))]) + (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 + 0)))]) + (let ([mask (car masks)] + [transparent #f] + [table (make-hasheq)] ; relying on fixnums + [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 (rgb-key + (mask (bytes-ref argb (+ 1 pos))) + (mask (bytes-ref argb (+ 2 pos))) + (mask (bytes-ref argb (+ 3 pos))))]) + (let ([v (hash-ref table vec #f)]) + (or v + (begin + (hash-set! table vec idx) + (set! idx (add1 idx)) + (sub1 idx))))))]) + (unless (= this-idx 256) + (bytes-set! result i this-idx) + (loop (add1 i) (+ pos 4)))))) + (if ((hash-count table) . > . (if transparent + 255 + 256)) + ;; Try again + (loop (cdr masks)) + ;; Found an ok quantization + (values result + (let* ([cnt (+ (hash-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-for-each + table + (lambda (k v) + (vector-set! t v (key->rgb k)))) + (vector->list t)) + transparent))))))) diff --git a/collects/file/scribblings/gif.scrbl b/collects/file/scribblings/gif.scrbl index 4c1a84d1a6..ab418bfda9 100644 --- a/collects/file/scribblings/gif.scrbl +++ b/collects/file/scribblings/gif.scrbl @@ -1,232 +1,36 @@ #lang scribble/doc -@(require "common.ss" - (for-label file/gif - (only-in scheme/gui bitmap%))) +@(require scribble/manual + scribble/extract + (for-label file/gif)) -@title{GIF File Writing} +@title[#:tag "gif"]{GIF File Writing} -@defmodule[file/gif]{The @schememodname[file/gif] library provides -functions for writing GIF files to a stream, including GIF files with -multiple images and controls (such as animated GIFs).} +@defmodule[file/gif] -This library does not rely on @schememodname[scheme/gui]. See -@scheme[bitmap%] (which is part of @schememodname[scheme/gui]) to read -a GIF file. See also @schememodname[mrlib/gif]. +The @schememodname[file/gif] library provides functions for +writing GIF files to a stream, including GIF files with multiple +images and controls (such as animated GIFs). -@defproc[(gif-start [out output-port?] - [width (integer-in 0 #xFFFFFFFF)] - [height (integer-in 0 #xFFFFFFFF)] - [bg-color byte?] - [colormap (or/c false/c gif-colormap?)]) - gif-stream?]{ +A GIF stream is created by @scheme[gif-start], and then individual +images are written with @scheme[gif-add-image]. Optionally, +@scheme[gif-add-control] inserts instructions for rendering the +images. The @scheme[gif-end] function ends the GIF stream. -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. - -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 @scheme[bg-color]'s -meaning is ill-defined if a global colormap is not provided.} - -@defproc[(gif-stream? [v any/c]) boolean?]{ - -Returns @scheme[#t] if @scheme[v] is a GIF stream created by -@scheme[gif-start]. - -A stream can be in any of several states, some of which are recognized -by more specific predicates: - -@itemize{ - - @item{@scheme[empty-gif-stream?] : no images or controls have been added to the stream} - - @item{@scheme[image-or-control-ready-gif-stream?] : another image or control can be written now} - - @item{@scheme[image-ready-gif-stream?] : another image can be written - now (since a control was written).} - - @item{done : nothing more can be added} - -}} - -@defproc[(empty-gif-stream? [v any/c]) boolean?]{ - -See @scheme[gif-stream?].} - - -@defproc[(image-or-control-ready-gif-stream? [v any/c]) boolean?]{ - -See @scheme[gif-stream?].} - - -@defproc[(image-ready-gif-stream? [v any/c]) boolean?]{ - -See @scheme[gif-stream?].} - - -@defproc[(gif-colormap? [v any/c]) boolean?]{ - -Returns @scheme[#t] if @scheme[v] is a list of vectors where each -vector must contain three bytes---one for red, one for blue, and one -for green---and 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.} - -@defproc[(gif-end [gs image-or-control-ready-gif-stream?]) void?]{ - -Finishes writing a GIF file. The GIF stream's output port is not -automatically closed.} - - -@defproc[(gif-add-image [gs image-or-control-ready-gif-stream?] - [left (integer-in 0 #xFFFFFFFF)] - [top (integer-in 0 #xFFFFFFFF)] - [width (integer-in 0 #xFFFFFFFF)] - [height (integer-in 0 #xFFFFFFFF)] - [interlaced? any/c] - [colormap (or/c gif-colormap? false/c)] - [bstr bytes?]) - void?]{ - -Writes an image to the given GIF stream @scheme[gs]. The -@scheme[left], @scheme[top], @scheme[width], and @scheme[height] -values specify the location and size of the image within the overall -GIF image's virtual space. - -If @scheme[interlaced?] is true, then @scheme[bytes] should provide -bytes in interlaced order instead of top-to-bottom order. Interlaced -order is: +A GIF stream can be in any one of the following states: @itemize{ - @item{every 8th row, starting with 0} - @item{every 8th row, starting with 4} - @item{every 4th row, starting with 2} - @item{every 2nd row, starting with 1} + @item{@scheme['init] : no images or controls have been added to the + stream} + + @item{@scheme['image-or-control] : another image or control can be + written} + + @item{@scheme['image] : another image can be written (but not a + control, since a control was written)} + + @item{@scheme['done] : nothing more can be added} } -If a global color is provided with @scheme[gif-start], a @scheme[#f] -value can be provided for @scheme[colormap]. - -The @scheme[bstr] 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 -@scheme[gif-add-control]), then the corresponding ``color'' doesn't -draw into the overall GIF image. - -An exception is raised if any byte value in @scheme[bstr] is larger -than the colormap's length, if the @scheme[bstr] length is not -@scheme[width] times @scheme[height], or if the @scheme[top], -@scheme[left], @scheme[width], and @scheme[height] dimensions specify -a region beyond the overall GIF image's virtual space.} - - -@defproc[(gif-add-control [gs image-or-control-ready-gif-stream?] - [disposal (one-of/c 'any 'keep 'restore-bg 'restore-prev)] - [wait-for-input? any/c] - [delay-csec (integer-in 0 #xFFFFFFFF)] - [transparent (or/c byte? false/c)]) - void?]{ - -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 @scheme[disposal] argument specifies how to proceed: - -@itemize{ - - @item{@scheme['any] : doesn't matter (perhaps because the next image - completely overwrites the current one)} - - @item{@scheme['keep] : leave the image in place} - - @item{@scheme['restore-bg] : replace the image with the background - color} - - @item{@scheme['restore-prev] : restore the overall image content to the - content before the image is added} - -} - -If @scheme[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 @scheme[delay-csec] argument specifies a delay in @math{1/100}s of -a second. - -If the @scheme[transparent] argument is a byte, then it determines an -index that is used to represent transparent pixels in the follow image -(as opposed to the color specified by the colormap for the index).} - - -@defproc[(gif-add-loop-control [gs image-or-control-ready-gif-stream?] - [iteration (integer-in 0 #xFFFFFFFF)]) - void?]{ - -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 @scheme[iteration] -times, where 0 can be used to mean ``infinity.''} - - -@defproc[(gif-add-comment [gs image-or-control-ready-gif-stream?]) - void?]{ - -Adds a generic comment to the GIF stream.} - - -@defproc[(quantize [argb-bstr bytes?]) - (values bytes? - gif-colormap? - (or/c byte? false/c))]{ - -Each image in a GIF stream is limited to 256 colors, including the -transparent ``color,'' if any. The @scheme[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), -@scheme[quantize] produces produces - -@itemize{ - - @item{bytes for the image (i.e., a array of colors, expressed as a byte - string),} - - @item{a colormap, and} - - @item{either @scheme[#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, -append them for the input of a single call of @scheme[quantize], and -then break apart the result bytes.} +@(include-extracted "../gif.ss") diff --git a/collects/file/scribblings/gunzip.scrbl b/collects/file/scribblings/gunzip.scrbl index 4c33f54a53..3596970ec1 100644 --- a/collects/file/scribblings/gunzip.scrbl +++ b/collects/file/scribblings/gunzip.scrbl @@ -3,7 +3,7 @@ (for-label file/gunzip file/gzip)) -@title{@exec{gzip} Decompression} +@title[#:tag "gunzip"]{@exec{gzip} Decompression} @defmodule[file/gunzip]{The @schememodname[file/gunzip] library provides utilities to decompress archive files in @exec{gzip} format, or simply diff --git a/collects/file/scribblings/gzip.scrbl b/collects/file/scribblings/gzip.scrbl index 1732866f1d..482fb64b33 100644 --- a/collects/file/scribblings/gzip.scrbl +++ b/collects/file/scribblings/gzip.scrbl @@ -2,7 +2,7 @@ @(require "common.ss" (for-label file/gzip)) -@title{@exec{gzip} Compression and File Creation} +@title[#:tag "gzip"]{@exec{gzip} Compression and File Creation} @defmodule[file/gzip]{The @schememodname[file/gzip] library provides utilities to create archive files in @exec{gzip} format, or simply to diff --git a/collects/file/scribblings/md5.scrbl b/collects/file/scribblings/md5.scrbl index 41b5d3fa5c..a8ec5ccf80 100644 --- a/collects/file/scribblings/md5.scrbl +++ b/collects/file/scribblings/md5.scrbl @@ -7,7 +7,7 @@ @(define md5-eval (make-base-eval)) @interaction-eval[#:eval md5-eval (require file/md5)] -@title{MD5 Message Digest} +@title[#:tag "md5"]{MD5 Message Digest} @defmodule[file/md5] diff --git a/collects/file/scribblings/tar.scrbl b/collects/file/scribblings/tar.scrbl index 6c0d350be0..8f019ddc51 100644 --- a/collects/file/scribblings/tar.scrbl +++ b/collects/file/scribblings/tar.scrbl @@ -2,7 +2,7 @@ @(require "common.ss" (for-label file/tar)) -@title{@exec{tar} File Creation} +@title[#:tag "tar"]{@exec{tar} File Creation} @defmodule[file/tar]{The @schememodname[file/tar] library provides utilities to create archive files in USTAR format, like the archive diff --git a/collects/file/scribblings/zip.scrbl b/collects/file/scribblings/zip.scrbl index 4d8bc88916..fe933198f9 100644 --- a/collects/file/scribblings/zip.scrbl +++ b/collects/file/scribblings/zip.scrbl @@ -4,7 +4,7 @@ file/gunzip scheme/file)) -@title{@exec{zip} File Creation} +@title[#:tag "zip"]{@exec{zip} File Creation} @defmodule[file/zip]{The @schememodname[file/zip] library provides utilities to create @exec{zip} archive files, which are compatible diff --git a/collects/net/gifwrite.ss b/collects/net/gifwrite.ss index aed179d287..8f74c9c110 100644 --- a/collects/net/gifwrite.ss +++ b/collects/net/gifwrite.ss @@ -1,682 +1,4 @@ -#| -/****************************************************************************** - * "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 - *****************************************************************************/ -|# +#lang scheme/base -#reader scribble/reader -(module gifwrite scheme/base - (require scheme/contract - scribble/srcdoc) - - (require/doc scheme/base - scribble/manual) - - (define LZ_MAX_CODE 4095) - - (define GifVersionPrefix #"GIF89a") - - (provide/doc - (proc-doc gif-stream? (([v any/c]) () . ->d . [_ boolean?]) - @{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write], - @scheme[#f] otherwise.}) - (proc-doc image-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) - @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is not in - @scheme['done] mode, @scheme[#f] otherwise.}) - (proc-doc image-or-control-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) - @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is in - @scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.}) - (proc-doc empty-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) - @{Returns @scheme[#t] if @scheme[v] is a GIF stream that in - @scheme['init] mode, @scheme[#f] otherwise.}) - (proc-doc gif-colormap? (([v any/c]) () . ->d . [_ boolean?]) - @{Returns @scheme[#t] if @scheme[v] represets a colormap, @scheme[#f] otherwise. - A colormap is a list whose size is a power of @math{2} between @math{2^1} and @math{2^8}, - and whose elements are vectors of size 3 containing colors - (i.e., exact integers between @math{0} and @math{255} inclusive).}) - (proc-doc color? (([v any/c]) () . ->d . [_ boolean?]) - @{The same as @scheme[byte?].}) - (proc-doc dimension? (([v any/c]) () . ->d . [_ boolean?]) - @{Returns @scheme[#t] if @scheme[v] is an exact integer between - @scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f] - otherwise.})) - - (define-struct gif-stream (port - SWidth - SHeight - SBackGroundColor - SColorMap - [FileState #:mutable])) - - (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 (gif-colormap? 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] - [(256) 8] - [else (error 'bits-per-pixel - "strange colormap size: ~e" - (length ColorMap))])) - - (define (WRITE g bytes) - (write-bytes bytes (gif-stream-port g))) - - (provide/doc (proc-doc gif-state (([stream gif-stream?]) () . ->d . [_ symbol?]) - @{Returns the state of @scheme[stream].})) - (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/doc (proc-doc - gif-start - (([out output-port?] - [w dimension?] - [h dimension?] - [bg-color color?] - [cmap (or/c false/c gif-colormap?)]) - () - . ->d . [_ gif-stream?]) - @{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.})) - (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/doc (proc-doc - gif-add-image - (([stream image-ready-gif-stream?] - [left dimension?] - [top dimension?] - [width dimension?] - [height dimension?] - [interlaced? any/c] - [cmap (or/c false/c gif-colormap?)] - [bstr bytes?]) - () - . ->d . [_ void?]) - @{Writes an image to the given GIF stream. The @scheme[left], @scheme[top], - @scheme[width], and @scheme[height] values specify the location and - size of the image within the overall GIF image's virtual space. - - If @scheme[interlaced?] is true, then @scheme[bstr] should provide bytes - ininterlaced order instead of top-to-bottom order. Interlaced order is: - - @(itemize - @item{every 8th row, starting with 0} - @item{every 8th row, starting with 4} - @item{every 4th row, starting with 2} - @item{every 2nd row, starting with 1}) - - If a global color is provided with @scheme[gif-start], a @scheme[#f] value - can be provided for @scheme[cmap]. - - The @scheme[bstr] 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 @scheme[gif-add-control]), - then the corresponding ``color'' doesn't draw into the overall GIF - image. - - An exception is raised if any byte value in @scheme[bstr] is larger than the - colormap's length, if the @scheme[bstr] length is not @scheme[width] times - @scheme[height], or if the @scheme[top], @scheme[left], @scheme[width], and - @scheme[height] dimensions specify a region beyond the overall GIF image's - virtual space.})) - (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 - (max 2 ;; min code size of LZW is 2 - (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/doc (proc-doc - gif-add-control - (([stream image-or-control-ready-gif-stream?] - [disposal (one-of/c 'any 'keep 'restore-bg 'restore-prev)] - [wait-for-input? any/c] - [delay dimension?] - [transparent (or/c false/c color?)]) - () - . ->d . [_ void?]) - @{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 @scheme[disposal] argument specifies how to proceed: - - @(itemize - @item{@scheme['any] : doesn't matter (perhaps because the next image - completely overwrites the current one)} - @item{@scheme['keep] : leave the image in place} - @item{@scheme['restore-bg] : replace the image with the background color} - @item{@scheme['restore-prev] : restore the overall image content to the - content before the image is added}) - - If @scheme[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 @scheme[delay] argument specifies a delay in 1/100s of a - second. - - If the @scheme[transparent] argument is a color, then it - determines an index that is used to represent 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 @scheme[stream] - without a corresponding image.})) - - (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/doc (proc-doc - gif-add-loop-control - (([stream empty-gif-stream?] - [iteration dimension?]) - () - . ->d . [_ void?]) - @{Writes a 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.})) - (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/doc (proc-doc - gif-add-comment - (([stream image-or-control-ready-gif-stream?] - [bstr bytes?]) - () - . ->d . [_ void?]) - @{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).})) - (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/doc (proc-doc - gif-end - (([stream image-or-control-ready-gif-stream?]) - () - . ->d . [_ void?]) - @{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).})) - (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-hasheq)] - [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-ref 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-hasheq) (add1 i))) - ;; /* Put this unique key with its relative Code in hash table: */ - (begin - (hash-set! 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/doc - (proc-doc quantize - (([bstr argb-bytes?]) - () - . ->d . - (values [_ bytes?] [_ gif-colormap?] [_ (or/c false/c color?)])) - @{Each - image in a GIF stream is limited to 256 colors, including the - transparent ``color,'' if any. The @scheme[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), - @scheme[quantize] produces produces - - @(itemize - @item{bytes for the image (i.e., a array of colors, expressed as a byte string)} - @item{a colormap} - @item{either @scheme[#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 @scheme[quantize], and - then break apart the result bytes.})) - (define (quantize argb) - (let* ([len (quotient (bytes-length argb) 4)] - [result (make-bytes len)] - [rgb-key (lambda (r g b) - (bitwise-ior (bitwise-ior - (arithmetic-shift r 16) - (arithmetic-shift g 8)) - b))] - [key->rgb (lambda (k) - (vector (arithmetic-shift k -16) - (bitwise-and #xFF (arithmetic-shift k -8)) - (bitwise-and #xFF k)))]) - (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 - 0)))]) - (let ([mask (car masks)] - [transparent #f] - [table (make-hasheq)] ; relying on fixnums - [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 (rgb-key - (mask (bytes-ref argb (+ 1 pos))) - (mask (bytes-ref argb (+ 2 pos))) - (mask (bytes-ref argb (+ 3 pos))))]) - (let ([v (hash-ref table vec #f)]) - (or v - (begin - (hash-set! table vec idx) - (set! idx (add1 idx)) - (sub1 idx))))))]) - (unless (= this-idx 256) - (bytes-set! result i this-idx) - (loop (add1 i) (+ pos 4)))))) - (if ((hash-count table) . > . (if transparent - 255 - 256)) - ;; Try again - (loop (cdr masks)) - ;; Found an ok quantization - (values result - (let* ([cnt (+ (hash-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-for-each - table - (lambda (k v) - (vector-set! t v (key->rgb k)))) - (vector->list t)) - transparent))))))) +(require file/gif) +(provide (all-from-out file/gif)) diff --git a/collects/net/scribblings/gifwrite.scrbl b/collects/net/scribblings/gifwrite.scrbl deleted file mode 100644 index ae7db7b987..0000000000 --- a/collects/net/scribblings/gifwrite.scrbl +++ /dev/null @@ -1,36 +0,0 @@ -#lang scribble/doc -@(require scribble/manual - scribble/extract - (for-label net/gifwrite)) - -@title[#:tag "gifwrite"]{GIF: Writing Image Files} - -@defmodule[net/gifwrite] - -The @schememodname[net/gifwrite] library provides functions for -writing GIF files to a stream, including GIF files with multiple -images and controls (such as animated GIFs). - -A GIF stream is created by @scheme[gif-start], and then individual -images are written with @scheme[gif-add-image]. Optionally, -@scheme[gif-add-control] inserts instructions for rendering the -images. The @scheme[gif-end] function ends the GIF stream. - -A GIF stream can be in any one of the following states: - -@itemize{ - - @item{@scheme['init] : no images or controls have been added to the - stream} - - @item{@scheme['image-or-control] : another image or control can be - written} - - @item{@scheme['image] : another image can be written (but not a - control, since a control was written)} - - @item{@scheme['done] : nothing more can be added} - -} - -@(include-extracted "../gifwrite.ss") diff --git a/collects/net/scribblings/net.scrbl b/collects/net/scribblings/net.scrbl index a2226e3c31..ca20926846 100644 --- a/collects/net/scribblings/net.scrbl +++ b/collects/net/scribblings/net.scrbl @@ -24,7 +24,6 @@ @include-section["ssl-tcp-unit.scrbl"] @include-section["cgi.scrbl"] @include-section["cookie.scrbl"] -@include-section["gifwrite.scrbl"] @(bibliography