clean up file/gif vs. net/gifwrie confusion
svn: r9848
This commit is contained in:
Matthew Flatt
parent
31d9a7d885
commit
02485e1e50
|
|
@ -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)
|
#reader scribble/reader
|
||||||
(provide (all-from-out net/gifwrite))
|
(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)))))))
|
||||||
|
|
|
||||||
|
|
@ -1,232 +1,36 @@
|
||||||
#lang scribble/doc
|
#lang scribble/doc
|
||||||
@(require "common.ss"
|
@(require scribble/manual
|
||||||
(for-label file/gif
|
scribble/extract
|
||||||
(only-in scheme/gui bitmap%)))
|
(for-label file/gif))
|
||||||
|
|
||||||
@title{GIF File Writing}
|
@title[#:tag "gif"]{GIF File Writing}
|
||||||
|
|
||||||
@defmodule[file/gif]{The @schememodname[file/gif] library provides
|
@defmodule[file/gif]
|
||||||
functions for writing GIF files to a stream, including GIF files with
|
|
||||||
multiple images and controls (such as animated GIFs).}
|
|
||||||
|
|
||||||
This library does not rely on @schememodname[scheme/gui]. See
|
The @schememodname[file/gif] library provides functions for
|
||||||
@scheme[bitmap%] (which is part of @schememodname[scheme/gui]) to read
|
writing GIF files to a stream, including GIF files with multiple
|
||||||
a GIF file. See also @schememodname[mrlib/gif].
|
images and controls (such as animated GIFs).
|
||||||
|
|
||||||
@defproc[(gif-start [out output-port?]
|
A GIF stream is created by @scheme[gif-start], and then individual
|
||||||
[width (integer-in 0 #xFFFFFFFF)]
|
images are written with @scheme[gif-add-image]. Optionally,
|
||||||
[height (integer-in 0 #xFFFFFFFF)]
|
@scheme[gif-add-control] inserts instructions for rendering the
|
||||||
[bg-color byte?]
|
images. The @scheme[gif-end] function ends the GIF stream.
|
||||||
[colormap (or/c false/c gif-colormap?)])
|
|
||||||
gif-stream?]{
|
|
||||||
|
|
||||||
Writes the start of a GIF file to the given output port, and returns a
|
A GIF stream can be in any one of the following states:
|
||||||
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{
|
@itemize{
|
||||||
|
|
||||||
@item{@scheme[empty-gif-stream?] : no images or controls have been added to the stream}
|
@item{@scheme['init] : 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-or-control] : another image or control can be
|
||||||
|
written}
|
||||||
|
|
||||||
@item{@scheme[image-ready-gif-stream?] : another image can be written
|
@item{@scheme['image] : another image can be written (but not a
|
||||||
now (since a control was written).}
|
control, since a control was written)}
|
||||||
|
|
||||||
@item{done : nothing more can be added}
|
@item{@scheme['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:
|
|
||||||
|
|
||||||
@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]
|
@(include-extracted "../gif.ss")
|
||||||
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.}
|
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
(for-label file/gunzip
|
(for-label file/gunzip
|
||||||
file/gzip))
|
file/gzip))
|
||||||
|
|
||||||
@title{@exec{gzip} Decompression}
|
@title[#:tag "gunzip"]{@exec{gzip} Decompression}
|
||||||
|
|
||||||
@defmodule[file/gunzip]{The @schememodname[file/gunzip] library provides
|
@defmodule[file/gunzip]{The @schememodname[file/gunzip] library provides
|
||||||
utilities to decompress archive files in @exec{gzip} format, or simply
|
utilities to decompress archive files in @exec{gzip} format, or simply
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
@(require "common.ss"
|
@(require "common.ss"
|
||||||
(for-label file/gzip))
|
(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
|
@defmodule[file/gzip]{The @schememodname[file/gzip] library provides
|
||||||
utilities to create archive files in @exec{gzip} format, or simply to
|
utilities to create archive files in @exec{gzip} format, or simply to
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@
|
||||||
@(define md5-eval (make-base-eval))
|
@(define md5-eval (make-base-eval))
|
||||||
@interaction-eval[#:eval md5-eval (require file/md5)]
|
@interaction-eval[#:eval md5-eval (require file/md5)]
|
||||||
|
|
||||||
@title{MD5 Message Digest}
|
@title[#:tag "md5"]{MD5 Message Digest}
|
||||||
|
|
||||||
@defmodule[file/md5]
|
@defmodule[file/md5]
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
@(require "common.ss"
|
@(require "common.ss"
|
||||||
(for-label file/tar))
|
(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
|
@defmodule[file/tar]{The @schememodname[file/tar] library provides
|
||||||
utilities to create archive files in USTAR format, like the archive
|
utilities to create archive files in USTAR format, like the archive
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@
|
||||||
file/gunzip
|
file/gunzip
|
||||||
scheme/file))
|
scheme/file))
|
||||||
|
|
||||||
@title{@exec{zip} File Creation}
|
@title[#:tag "zip"]{@exec{zip} File Creation}
|
||||||
|
|
||||||
@defmodule[file/zip]{The @schememodname[file/zip] library provides
|
@defmodule[file/zip]{The @schememodname[file/zip] library provides
|
||||||
utilities to create @exec{zip} archive files, which are compatible
|
utilities to create @exec{zip} archive files, which are compatible
|
||||||
|
|
|
||||||
|
|
@ -1,682 +1,4 @@
|
||||||
#|
|
#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
|
|
||||||
*****************************************************************************/
|
|
||||||
|#
|
|
||||||
|
|
||||||
#reader scribble/reader
|
(require file/gif)
|
||||||
(module gifwrite scheme/base
|
(provide (all-from-out file/gif))
|
||||||
(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)))))))
|
|
||||||
|
|
|
||||||
|
|
@ -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")
|
|
||||||
|
|
@ -24,7 +24,6 @@
|
||||||
@include-section["ssl-tcp-unit.scrbl"]
|
@include-section["ssl-tcp-unit.scrbl"]
|
||||||
@include-section["cgi.scrbl"]
|
@include-section["cgi.scrbl"]
|
||||||
@include-section["cookie.scrbl"]
|
@include-section["cookie.scrbl"]
|
||||||
@include-section["gifwrite.scrbl"]
|
|
||||||
|
|
||||||
@(bibliography
|
@(bibliography
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user