diff --git a/collects/file/gif.ss b/collects/file/gif.ss index a866c68201..a9938f423d 100644 --- a/collects/file/gif.ss +++ b/collects/file/gif.ss @@ -15,668 +15,657 @@ |# #reader scribble/reader -(module gif scheme/base - (require scheme/contract - scribble/srcdoc) +#lang scheme/base +(require scheme/contract + scribble/srcdoc) - (require/doc scheme/base - scribble/manual) +(require/doc scheme/base + scribble/manual) - (define LZ_MAX_CODE 4095) +(define LZ_MAX_CODE 4095) - (define GifVersionPrefix #"GIF89a") +(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.})) +(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-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-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 (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 (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 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 (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 (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 (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))) +(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)) +(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. +;;/****************************************************************************** +;; * 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)) + 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. - (when ColorMap - (unless (BackGround . < . (length ColorMap)) - (error 'gif-start - "background color ~a is out of range for the color map: ~e" - BackGround - ColorMap))) + 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. - (WRITE GifFile GifVersionPrefix) + 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)) - ;;/* - ;; * Put the logical screen descriptor into the file: - ;; */ - ;;/* Logical Screen Descriptor: Dimensions */ - (EGifPutWord Width GifFile) - (EGifPutWord Height GifFile) + (when ColorMap + (unless (BackGround . < . (length ColorMap)) + (error 'gif-start + "background color ~a is out of range for the color map: ~e" + BackGround + ColorMap))) - ;;/* 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))) + (WRITE GifFile GifVersionPrefix) - GifFile) + ;;/* + ;; * Put the logical screen descriptor into the file: + ;; */ + ;;/* Logical Screen Descriptor: Dimensions */ + (EGifPutWord Width GifFile) + (EGifPutWord Height 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}) + ;;/* 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 a global color is provided with @scheme[gif-start], a @scheme[#f] value - can be provided for @scheme[cmap]. + ;; /* If we have Global color map - dump it also: */ + (when ColorMap + (WRITE GifFile (color-map->bytes 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. + GifFile) - 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) +;;/****************************************************************************** +;; * 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. - (unless ColorMap - (unless (gif-stream-SColorMap GifFile) - (error 'gif-add-image - "no color map for image"))) + If @scheme[interlaced?] is true, then @scheme[bstr] should + provide bytes ininterlaced order instead of top-to-bottom + order. Interlaced order is: - (unless (= (bytes-length Line) - (* Width Height)) + @(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 - "bytes string size doesn't match width times height: ~e" - Line)) + "no color map for image"))) - (unless (and ((+ Left Width) . <= . (gif-stream-SWidth GifFile)) - ((+ Top Height) . <= . (gif-stream-SHeight GifFile))) - (error 'gif-add-image - "image extends beyond GIF virtual screen")) + (unless (= (bytes-length Line) + (* Width Height)) + (error 'gif-add-image + "bytes string size doesn't match width times height: ~e" + Line)) - (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)))) + (unless (and ((+ Left Width) . <= . (gif-stream-SWidth GifFile)) + ((+ Top Height) . <= . (gif-stream-SHeight GifFile))) + (error 'gif-add-image + "image extends beyond GIF virtual screen")) - ;; /* If we have local color map - dump it also: */ - (when ColorMap - (WRITE GifFile (color-map->bytes ColorMap))) + (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)))) - (let* ([cmap (or ColorMap - (gif-stream-SColorMap GifFile))]) + ;; /* If we have local color map - dump it also: */ + (when ColorMap + (WRITE GifFile (color-map->bytes ColorMap))) - (check-line-bytes (length cmap) Line) + (let* ([cmap (or ColorMap (gif-stream-SColorMap GifFile))]) - (EGifCompress GifFile - (max 2 ;; min code size of LZW is 2 - (bits-per-pixel cmap)) - Line)) + (check-line-bytes (length cmap) Line) - (set-gif-stream-FileState! GifFile 'image-or-control)) + (EGifCompress GifFile + (max 2 ;; min code size of LZW is 2 + (bits-per-pixel cmap)) + Line)) - (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))))) + (set-gif-stream-FileState! GifFile 'image-or-control)) - - ;;/****************************************************************************** - ;; * 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. +(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))))) - 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. +;;/****************************************************************************** +;; * 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 @scheme[delay] argument specifies a delay in 1/100s of a - second. + 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). - 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). + The @scheme[disposal] argument specifies how to proceed: - An exception is raised if a control is already added to @scheme[stream] - without a corresponding image.})) + @(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}) - (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)) + 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. - ;;/****************************************************************************** - ;; * 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)) + The @scheme[delay] argument specifies a delay in 1/100s of a + second. - ;;/****************************************************************************** - ;; * 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)) + 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). - ;;/****************************************************************************** - ;; * 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)) + An exception is raised if a control is already added to + @scheme[stream] without a corresponding image.})) - ;;/****************************************************************************** - ;; * Put 2 bytes (word) into the given file: - ;; *****************************************************************************/ - (define (EGifPutWord Word GifFile) - (WRITE GifFile (integer->integer-bytes Word 2 #f #f))) +(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)) - ;;/****************************************************************************** - ;; * 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)))) +;;/****************************************************************************** +;; * 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.'' - ;;/****************************************************************************** - ;; * LZ compression - ;; *****************************************************************************/ - (define (EGifCompress GifFile BitsPerPixel Line) + 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)) - (WRITE GifFile (bytes BitsPerPixel)) +;;/****************************************************************************** +;; * 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. - (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)]) + 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)) - (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) +;;/****************************************************************************** +;; * 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)))) - (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. */ + (- 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 CrntCode + (CompressOutput port buf ClearCode 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)))))))))))))) + (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 - ;; *****************************************************************************/ +;;/****************************************************************************** +;; * 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))))))) +(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))]) + (for ([(k v) table]) + (vector-set! t v (key->rgb k))) + (vector->list t)) + transparent))))))