suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

new library for writing GIF files

Browse Source 
svn: r5235
This commit is contained in:
Matthew Flatt 2007-01-06 23:33:50 +00:00
parent 7f26385727
commit 4fba4a4edf
2 changed files with 693 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

191
collects/net/doc.txt
View File

@ -2271,3 +2271,194 @@ PROCEDURES -----------------------------------------------------------
'amp-or-semi name=shriram&host=nw name=shriram;host=nw 'amp-or-semi name=shriram&host=nw name=shriram;host=nw
or or
name=shriram;host=nw name=shriram;host=nw
==========================================================================
_GIF_ writing, _animated GIF_ writing
==========================================================================
To load directly: (require (lib "gifwrite.ss" "net"))
ABSTRACT -------------------------------------------------------------
The gifwrite package provides functions for writing GIF files to a
stream, including GIF files with multiple images and controls (such as
animated GIFs).
TYPES ----------------------------------------------------------------
> gif-stream
A GIF stream is created by `gif-start'.
A stream can be in a number of states:
* 'init : no images or controls have been added to the stream
* 'image-or-control : another image or control can be written now
* 'image : another image can be written now (since a control was
written)
* 'done : nothing more can be added
> dimension
An exact integer between 0 and #xFFFFFFFF, inclusive.
> color
An exact integer between 0 and 255, inclusive, indicating an index in
a color map.
> colormap
A list of vectors; each vector must contain three color values: one
for red, one for blue, and one for green. The list length must be 2,
4, 8, 16, 32, 64, 128, or 256. The colors are indexed (starting from
0) by their order in the list.
PROCEDURES -----------------------------------------------------------
> (gif-start output-port width-dimension height-dimension bg-color colormap-or-#f)
Writes the start of a GIF file to the given output port, and returns
a GIF stream that adds to the output port.
The width and height determine a virtual space for the overall GIF
image. Individual images added to the GIF stream must fit within this
virtual space. The space is initialized by the given background color.
Finally, the default meaning of color numbers (such as the background
color) is determined by the given colormap, but individual images
within the GIF file can have their own colormaps.
A global colormap need not be supplied, in which case a colormap must
be supplied for each image. Beware that the bg-color is ill-defined if
a global colormap is not provided.
> (gif-end gif-stream)
Finishes writing a GIF file. The GIF stream's output port is not
automatically closed.
An exception is raised if an image-control command was just written to
the stream (so that an image is required next).
> (gif-add-image gif-stream left-dimension
top-dimension
width-dimension
height-dimension
interlaced?
colormap-or-#f
bytes)
Writes an image to the given GIF stream. The left, top, width, and
height values specify the location and size of the image within the
overall GIF image's virtual space.
If `interlaced?' is true, then `bytes' should provide bytes in
interlaced order instead of top-to-bottom order. Interlaced order is:
* every 8th row, starting with 0
* every 8th row, starting with 4
* every 4th row, starting with 2
* every 2nd row, starting with 1
If a global color is provided with `gif-start', a #f value can be
provide instead of a colormap.
The `bytes' argument specifies the pixel content of the image. Each
byte specifies a color (i.e., an index in the colormap). Each row is
provided left-to-right, and the rows provided either top-to-bottom or
in interlaced order (see above). If the image is prefixed with a
control that specifies an transparent index (see `gif-add-control'),
then the corresponding "color" doesn't draw into the overall GIF
image.
An exception is raised if any byte value in `bytes' is larger than the
colormap's length, if the `bytes' length is not `width' times
`height', or if the top, left, width, and height dimensions specify a
region beyond the overall GIF image's virtual space.
> (gif-add-control gif-stream disposal-symbol
wait-for-input?
delay-dimension
transparent-color-or-#f)
Writes an image-control command to a GIF stream. Such a control must
appear just before an image, and it applies to the following image.
The GIF image model involves processing images one by one, placing
each image into the specified position within the overall image's
virtual space. An image-control command can specify a delay before an
image is added (to create animated GIFs), and it also specifies how
the image should be kept or removed from the overall image before
proceeding to the next one (also for GIF animation).
The `disposal-symbol' argument specifies how to proceed:
- 'any : doesn't matter (perhaps because the next image
completely overwrites the current one)
- 'keep : leave the image in place
- 'restore-bg : replace the image with the background color
- 'restore-prev : restore the overall image content to the
content before the image is added
If `wait-for-input?' is true, then the display program may wait for
some cue from the user (perhaps a mouse click) before adding the
image.
The `delay-dimension' argument specifies a delay in 1/100s of a
second.
If the `transparent-color-or-#f' argument is a color, then it
determines an index that is used to reprsent transparent pixels in the
follow image (as opposed to the color specified by the colormap for
the index).
An exception is raised if a control is already added to `gif-stream'
without a corresponding image.
> (gif-add-loop-control gif-stream iteration-dimension)
Writes an control command to a GIF stream for which no images or other
commands have already been written. The command causes the animating
sequence of images in the GIF to be repeated `iteration-dimension'
times, where 0 can be used to mean "infinity".
An exception is raise if some control or image has been added to the
stream already.
> (gif-add-comment gif-stream bytes)
Adds a generic comment to the GIF stream.
An exception is raised if an image-control command was just written to
the stream (so that an image is required next).
> (quantize argb-bytes)
Eachimage in a GIF stream is limited to 256 colors, including the
transparent "color", if any. The `quantize' function helps converts a
24-bit image (plus alpha channel) into an indexed-color image,reducing
the number of colors if necessary.
Given a set of pixels expressed in ARGB format (i.e., each four bytes
is a set of values for one pixel: alpha, red, blue, and green),
`quantize' produces produces
- bytes for the image (i.e., a array of colors, expressed as a byte
string)
- a colormap
- either #f or a color index for the transparent "color"
The conversion treats alpha values less than 128 as transparent
pixels, and other alpha values as solid.
The quantization process first attempts to use all (non-transparent)
colors in the image. if that fails, it reduces the image to 12-bit
color (3 bits per each of red, green, and blue) by rounding up pixel
values, and tries again. If that fails, it reduces the image to 6-bit
color (2 bits per each of red, green, and blue).
To convert a collection of images all with the same quantization,
simply append them for the input of a single call of `quantize', and
then break apart the result bytes.

502
collects/net/gifwrite.ss Normal file
View File

@ -0,0 +1,502 @@
#|
/******************************************************************************
* "Gif-Lib" - Yet another gif library.
*
* Written by: Gershon Elber Ver 1.1, Aug. 1990
******************************************************************************
* The kernel of the GIF Encoding process can be found here.
******************************************************************************
* History:
* 14 Jun 89 - Version 1.0 by Gershon Elber.
* 3 Sep 90 - Version 1.1 by Gershon Elber (Support for Gif89, Unique names).
* 26 Jun 96 - Version 3.0 by Eric S. Raymond (Full GIF89 support)
* 5 Jan 07 - Ported to MzScheme by Matthew
*****************************************************************************/
|#
(module gifwrite mzscheme
(require (lib "contract.ss"))
(define LZ_MAX_CODE 4095)
(define GifVersionPrefix #"GIF89a")
(define-struct gif-stream (port
SWidth
SHeight
SBackGroundColor
SColorMap
FileState))
(define (image-ready-gif-stream? g)
(and (gif-stream? g)
(memq (gif-stream-FileState g) '(init image-or-control image))))
(define (image-or-control-ready-gif-stream? g)
(and (gif-stream? g)
(memq (gif-stream-FileState g) '(init image-or-control))))
(define (empty-gif-stream? g)
(and (gif-stream? g)
(memq (gif-stream-FileState g) '(init))))
(define color? byte?)
(define (dimension? x) (and (exact? x) (integer? x) (<= 0 x #xFFFF)))
(define (disposal? s)
(memq s '(any keep restore-bg restore-prev)))
(define (color-map? l)
(and (list? l)
(member (length l) '(2 4 8 16 32 64 128 256))
(andmap (lambda (c)
(and (vector? c)
(= 3 (vector-length c))
(color? (vector-ref c 0))
(color? (vector-ref c 1))
(color? (vector-ref c 2))))
l)))
(define (color-map->bytes ColorMap)
(apply bytes (apply append (map vector->list ColorMap))))
(define (bits-per-pixel ColorMap)
(case (length ColorMap)
[(2) 1]
[(4) 2]
[(8) 3]
[(16) 4]
[(32) 5]
[(64) 6]
[(128) 7]))
(define (WRITE g bytes)
(write-bytes bytes (gif-stream-port g)))
(provide/contract [gif-state
(gif-stream? . -> . symbol?)])
(define (gif-state GifFile)
(gif-stream-FileState GifFile))
;;/******************************************************************************
;; * This routine should be called before any other EGif calls, immediately
;; * follows the GIF file openning.
;; *****************************************************************************/
(provide/contract [gif-start
(output-port?
dimension?
dimension?
color?
(or/c false/c color-map?)
. -> . gif-stream?)])
(define (gif-start port
Width
Height
BackGround
ColorMap)
(define GifFile
(make-gif-stream port
Width
Height
BackGround
ColorMap
'init))
(when ColorMap
(unless (BackGround . < . (length ColorMap))
(error 'gif-start
"background color ~a is out of range for the color map: ~e"
BackGround
ColorMap)))
(WRITE GifFile GifVersionPrefix)
;;/*
;; * Put the logical screen descriptor into the file:
;; */
;;/* Logical Screen Descriptor: Dimensions */
(EGifPutWord Width GifFile)
(EGifPutWord Height GifFile)
;;/* Logical Screen Descriptor: Packed Fields */
;;/* Note: We have actual size of the color table default to the largest
;; * possible size (7+1 == 8 bits) because the decoder can use it to decide
;; * how to display the files.
;; */
(WRITE GifFile
(bytes (bitwise-ior
(if ColorMap #x80 #x00)
(arithmetic-shift #x7 4) ; /* Bits originally allocated to each primary color */
(if ColorMap (sub1 (bits-per-pixel ColorMap)) #x07)) ; /* Actual size of the color table. */
BackGround ; /* Index into the ColorTable for background color */
0)) ; /* Pixel Aspect Ratio */
;; /* If we have Global color map - dump it also: */
(when ColorMap
(WRITE GifFile (color-map->bytes ColorMap)))
GifFile)
;;/******************************************************************************
;; * This routine should be called before any attempt to dump an image - any
;; * call to any of the pixel dump routines.
;; *****************************************************************************/
(provide/contract [gif-add-image
(image-ready-gif-stream?
dimension?
dimension?
dimension?
dimension?
any/c
(or/c false/c color-map?)
bytes?
. -> . any)])
(define (gif-add-image GifFile
Left
Top
Width
Height
Interlace
ColorMap
Line)
(unless ColorMap
(unless (gif-stream-SColorMap GifFile)
(error 'gif-add-image
"no color map for image")))
(unless (= (bytes-length Line)
(* Width Height))
(error 'gif-add-image
"bytes string size doesn't match width times height: ~e"
Line))
(unless (and ((+ Left Width) . <= . (gif-stream-SWidth GifFile))
((+ Top Height) . <= . (gif-stream-SHeight GifFile)))
(error 'gif-add-image
"image extends beyond GIF virtual screen"))
(WRITE GifFile #",") ; /* Image seperator character. */
(EGifPutWord Left GifFile)
(EGifPutWord Top GifFile)
(EGifPutWord Width GifFile)
(EGifPutWord Height GifFile)
(WRITE GifFile
(bytes
(bitwise-ior
(if ColorMap #x80 #x00)
(if Interlace #x40 #x00)
(if ColorMap (sub1 (bits-per-pixel ColorMap)) #x00))))
;; /* If we have local color map - dump it also: */
(when ColorMap
(WRITE GifFile (color-map->bytes ColorMap)))
(let* ([cmap (or ColorMap
(gif-stream-SColorMap GifFile))])
(check-line-bytes (length cmap) Line)
(EGifCompress GifFile
(bits-per-pixel cmap)
Line))
(set-gif-stream-FileState! GifFile 'image-or-control))
(define (check-line-bytes sz Line)
(let loop ([i (bytes-length Line)])
(unless (zero? i)
(let ([i (sub1 i)])
(unless ((bytes-ref Line i) . < . sz)
(error 'gif-add-image
"out-of-range color index ~a in line: ~e"
(bytes-ref Line i)
Line))
(loop i)))))
;;/******************************************************************************
;; * This routine should be called to add graphic control before the next image
;; *****************************************************************************/
(provide/contract [gif-add-control
(image-or-control-ready-gif-stream?
disposal?
any/c
dimension?
(or/c false/c color?)
. -> . any)])
(define (gif-add-control GifFile
Disposal
UserInput?
Delay ; 1/100s of a second
TransparentColor)
(WRITE GifFile #"\x21\xF9\x04")
(WRITE GifFile
(bytes (bitwise-ior
(case Disposal
[(any) 0]
[(keep) #x4]
[(restore-bg) #x8]
[(restore-prev) #xC])
(if UserInput? #x2 0)
(if TransparentColor #x1 0))))
(EGifPutWord Delay GifFile)
(WRITE GifFile (bytes
(or TransparentColor 0)
0)) ; block terminator
(set-gif-stream-FileState! GifFile 'image))
;;/******************************************************************************
;; * This routine should be called to add the "loop" graphic control
;; before adding any images
;; *****************************************************************************/
(provide/contract [gif-add-loop-control
(empty-gif-stream?
dimension?
. -> . any)])
(define (gif-add-loop-control GifFile
Iterations)
(WRITE GifFile #"\x21\xFF\x0BNETSCAPE2.0\x03\x01")
(EGifPutWord Iterations GifFile)
(WRITE GifFile #"\x00")
(set-gif-stream-FileState! GifFile 'image-or-control))
;;/******************************************************************************
;; * This routine should be called to add arbitrary comment text
;; *****************************************************************************/
(provide/contract [gif-add-comment
(image-or-control-ready-gif-stream?
bytes?
. -> . any)])
(define (gif-add-comment GifFile
Str)
(WRITE GifFile #"\x21\xFE")
(let loop ([pos 0])
(when (pos . < . (bytes-length Str))
(let ([amt (min 255 (- (bytes-length Str) pos))])
(write-byte amt (gif-stream-port GifFile))
(write-bytes Str (gif-stream-port GifFile) pos (+ pos amt))
(loop (+ pos amt)))))
(WRITE GifFile #"\0")
(set-gif-stream-FileState! GifFile 'image-or-control))
;;/******************************************************************************
;; * This routine should be called last, to end GIF file.
;; *****************************************************************************/
(provide/contract [gif-end
(image-or-control-ready-gif-stream?
. -> . any)])
(define (gif-end GifFile)
(WRITE GifFile #";")
(set-gif-stream-FileState! GifFile 'done))
;;/******************************************************************************
;; * Put 2 bytes (word) into the given file:
;; *****************************************************************************/
(define (EGifPutWord Word GifFile)
(WRITE GifFile (integer->integer-bytes Word 2 #f #f)))
;;/******************************************************************************
;; * LZ compression output
;; *****************************************************************************/
(define (write-buffered-byte b buf port)
(let ([cnt (add1 (bytes-ref buf 0))])
(bytes-set! buf cnt b)
(bytes-set! buf 0 cnt)
(when (= cnt 255)
(write-bytes buf port)
(bytes-set! buf 0 0))))
(define (CompressOutput port buf Code
RunningBits RunningCode MaxCode1
CrntShiftState CrntShiftDWord)
(let-values ([(CrntShiftState CrntShiftDWord)
(let loop ([CrntShiftDWord (bitwise-ior
CrntShiftDWord
(arithmetic-shift Code CrntShiftState))]
[CrntShiftState (+ CrntShiftState RunningBits)])
(if (CrntShiftState . >= . 8)
(begin
(write-buffered-byte (bitwise-and CrntShiftDWord #xff) buf port)
(loop (arithmetic-shift CrntShiftDWord -8)
(- CrntShiftState 8)))
(values CrntShiftState CrntShiftDWord)))])
(if (and (RunningCode . >= . MaxCode1)
(Code . <= . 4095))
(values (add1 RunningBits) (arithmetic-shift 1 (add1 RunningBits))
CrntShiftState CrntShiftDWord)
(values RunningBits MaxCode1
CrntShiftState CrntShiftDWord))))
;;/******************************************************************************
;; * LZ compression
;; *****************************************************************************/
(define (EGifCompress GifFile BitsPerPixel Line)
(WRITE GifFile (bytes BitsPerPixel))
(let* ([ClearCode (arithmetic-shift 1 BitsPerPixel)]
[EOFCode (add1 ClearCode)]
[RunningCode (add1 EOFCode)]
[RunningBits (add1 BitsPerPixel)]; /* Number of bits per code. */
[MaxCode1 (arithmetic-shift 1 RunningBits)]; /* Max. code + 1. */
[HashTable (make-hash-table)]
[CrntShiftState 0]; /* No information in CrntShiftDWord. */
[CrntShiftDWord 0]
[port (gif-stream-port GifFile)]
[len (bytes-length Line)]
[buf (make-bytes 256 0)])
(let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord)
(CompressOutput port buf ClearCode
RunningBits RunningCode MaxCode1
CrntShiftState CrntShiftDWord)])
(let loop ([CrntCode (bytes-ref Line 0)]
[RunningCode RunningCode]
[RunningBits RunningBits]
[MaxCode1 MaxCode1]
[CrntShiftState CrntShiftState]
[CrntShiftDWord CrntShiftDWord]
[HashTable HashTable]
[i 1])
(if (= i len)
;; Finish:
(let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord)
(CompressOutput port buf CrntCode
RunningBits RunningCode MaxCode1
CrntShiftState CrntShiftDWord)])
(let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord)
(CompressOutput port buf EOFCode
RunningBits RunningCode MaxCode1
CrntShiftState CrntShiftDWord)])
;; Flush output:
(let loop ([CrntShiftState CrntShiftState]
[CrntShiftDWord CrntShiftDWord])
(when (CrntShiftState . > . 0)
(write-buffered-byte (bitwise-and CrntShiftDWord #xff) buf port)
(loop (arithmetic-shift CrntShiftDWord -8)
(- CrntShiftState 8))))
(unless (zero? (bytes-ref buf 0))
(write-bytes buf port 0 (add1 (bytes-ref buf 0))))
(write-bytes #"\0" port)))
;; /* Get next pixel from stream. */
(let ([Pixel (bytes-ref Line i)])
;; /* Form a new unique key to search hash table for the code combines
;; * CrntCode as Prefix string with Pixel as postfix char.
;; */
(let* ([NewKey (bitwise-ior (arithmetic-shift CrntCode 8) Pixel)]
[NewCode (hash-table-get HashTable NewKey #f)])
(if NewCode
;;/* This Key is already there, or the string is old one, so
;; * simple take new code as our CrntCode:
;; */
(loop NewCode
RunningCode RunningBits MaxCode1
CrntShiftState CrntShiftDWord
HashTable (add1 i))
;;/* Put it in hash table, output the prefix code, and make our
;; * CrntCode equal to Pixel. */
(let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord)
(CompressOutput port buf CrntCode
RunningBits RunningCode MaxCode1
CrntShiftState CrntShiftDWord)])
(let ([CrntCode Pixel])
;; /* If however the HashTable if full, we send a clear first and
;; * Clear the hash table. */
(if (RunningCode . >= . LZ_MAX_CODE)
;; /* Time to do some clearance: */
(let-values ([(RunningBits MaxCode1 CrntShiftState CrntShiftDWord)
(CompressOutput port buf ClearCode
RunningBits RunningCode MaxCode1
CrntShiftState CrntShiftDWord)])
(loop CrntCode
(add1 EOFCode) (add1 BitsPerPixel) (arithmetic-shift 1 (add1 BitsPerPixel))
CrntShiftState CrntShiftDWord
(make-hash-table) (add1 i)))
;; /* Put this unique key with its relative Code in hash table: */
(begin
(hash-table-put! HashTable NewKey RunningCode)
(loop CrntCode
(add1 RunningCode) RunningBits MaxCode1
CrntShiftState CrntShiftDWord
HashTable (add1 i))))))))))))))
;;/******************************************************************************
;; * color quantization utility
;; *****************************************************************************/
(define (argb-bytes? b)
(and (bytes? b)
(zero? (remainder (bytes-length b) 4))))
(provide/contract
[quantize ((argb-bytes?)
. ->* .
(bytes? color-map? (or/c false/c color?)))])
(define (quantize argb)
(let* ([len (quotient (bytes-length argb) 4)]
[result (make-bytes len)])
(let loop ([masks (list
(lambda (v) v)
(lambda (v)
(bitwise-ior
(bitwise-ior
v
(arithmetic-shift (bitwise-and v #x55) 1))
(arithmetic-shift (bitwise-and v #xCC) -1)))
(lambda (v)
(if (v . > . 127)
255
0)))])
(let ([mask (car masks)]
[transparent #f]
[table (make-hash-table 'equal)]
[idx 0])
;; Iterate over image to count colors
;; (as reduced by mask)
(let loop ([i 0][pos 0])
(unless (= i len)
(let ([this-idx
(if ((bytes-ref argb pos) . < . 128)
(begin
(unless transparent
(set! transparent idx)
(set! idx (add1 idx)))
transparent)
(let ([vec (vector
(mask (bytes-ref argb (+ 1 pos)))
(mask (bytes-ref argb (+ 2 pos)))
(mask (bytes-ref argb (+ 3 pos))))])
(let ([v (hash-table-get table vec #f)])
(or v
(begin
(hash-table-put! table vec idx)
(set! idx (add1 idx))
(sub1 idx))))))])
(bytes-set! result i (min 255 this-idx)))
(loop (add1 i) (+ pos 4))))
(if ((hash-table-count table) . > . (if transparent
255
256))
;; Try again
(loop (cdr masks))
;; Found an ok quantization
(values result
(let* ([cnt (+ (hash-table-count table)
(if transparent 1 0))]
[size (cond
[(<= cnt 2) 2]
[(<= cnt 4) 4]
[(<= cnt 8) 8]
[(<= cnt 16) 16]
[(<= cnt 32) 32]
[(<= cnt 64) 64]
[(<= cnt 128) 128]
[else 256])]
[t (make-vector size #(0 0 0))])
(hash-table-for-each
table
(lambda (k v)
(vector-set! t v k)))
(vector->list t))
transparent)))))))