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

reformatting

Browse Source 
svn: r9852
This commit is contained in:
Eli Barzilay 2008-05-15 16:55:02 +00:00
parent b56df5be44
commit e62d2bf9ea
1 changed files with 595 additions and 606 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

417
collects/file/gif.ss
View File

@ -15,65 +15,70 @@
|# |#
#reader scribble/reader #reader scribble/reader
(module gif scheme/base #lang scheme/base
(require scheme/contract (require scheme/contract
scribble/srcdoc) scribble/srcdoc)
(require/doc scheme/base (require/doc scheme/base
scribble/manual) scribble/manual)
(define LZ_MAX_CODE 4095) (define LZ_MAX_CODE 4095)
(define GifVersionPrefix #"GIF89a") (define GifVersionPrefix #"GIF89a")
(provide/doc (provide/doc
(proc-doc gif-stream? (([v any/c]) () . ->d . [_ boolean?]) (proc-doc gif-stream?
@{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write], (([v any/c]) () . ->d . [_ boolean?])
@scheme[#f] otherwise.}) @{Returns @scheme[@t] if @scheme[v] is a GIF stream created by
(proc-doc image-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) @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 @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is not in
@scheme['done] mode, @scheme[#f] otherwise.}) @scheme['done] mode, @scheme[#f] otherwise.})
(proc-doc image-or-control-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) (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 @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is in
@scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.}) @scheme['init] or @scheme['image-or-control] mode, @scheme[#f]
(proc-doc empty-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) otherwise.})
(proc-doc empty-gif-stream?
(([v any/c]) () . ->d . [_ boolean?])
@{Returns @scheme[#t] if @scheme[v] is a GIF stream that in @{Returns @scheme[#t] if @scheme[v] is a GIF stream that in
@scheme['init] mode, @scheme[#f] otherwise.}) @scheme['init] mode, @scheme[#f] otherwise.})
(proc-doc gif-colormap? (([v any/c]) () . ->d . [_ boolean?]) (proc-doc gif-colormap?
@{Returns @scheme[#t] if @scheme[v] represets a colormap, @scheme[#f] otherwise. (([v any/c]) () . ->d . [_ boolean?])
A colormap is a list whose size is a power of @math{2} between @math{2^1} and @math{2^8}, @{Returns @scheme[#t] if @scheme[v] represets a colormap,
and whose elements are vectors of size 3 containing colors @scheme[#f] otherwise. A colormap is a list whose size is a power
(i.e., exact integers between @math{0} and @math{255} inclusive).}) of @math{2} between @math{2^1} and @math{2^8}, and whose elements
(proc-doc color? (([v any/c]) () . ->d . [_ boolean?]) 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?].}) @{The same as @scheme[byte?].})
(proc-doc dimension? (([v any/c]) () . ->d . [_ boolean?]) (proc-doc dimension?
(([v any/c]) () . ->d . [_ boolean?])
@{Returns @scheme[#t] if @scheme[v] is an exact integer between @{Returns @scheme[#t] if @scheme[v] is an exact integer between
@scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f] @scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f]
otherwise.})) otherwise.}))
(define-struct gif-stream (port (define-struct gif-stream
SWidth (port SWidth SHeight SBackGroundColor SColorMap [FileState #:mutable]))
SHeight
SBackGroundColor
SColorMap
[FileState #:mutable]))
(define (image-ready-gif-stream? g) (define (image-ready-gif-stream? g)
(and (gif-stream? g) (and (gif-stream? g)
(memq (gif-stream-FileState g) '(init image-or-control image)))) (memq (gif-stream-FileState g) '(init image-or-control image))))
(define (image-or-control-ready-gif-stream? g) (define (image-or-control-ready-gif-stream? g)
(and (gif-stream? g) (and (gif-stream? g)
(memq (gif-stream-FileState g) '(init image-or-control)))) (memq (gif-stream-FileState g) '(init image-or-control))))
(define (empty-gif-stream? g) (define (empty-gif-stream? g)
(and (gif-stream? g) (and (gif-stream? g)
(memq (gif-stream-FileState g) '(init)))) (memq (gif-stream-FileState g) '(init))))
(define color? byte?) (define color? byte?)
(define (dimension? x) (and (exact? x) (integer? x) (<= 0 x #xFFFF))) (define (dimension? x) (and (exact? x) (integer? x) (<= 0 x #xFFFF)))
(define (gif-colormap? l) (define (gif-colormap? l)
(and (list? l) (and (list? l)
(member (length l) '(2 4 8 16 32 64 128 256)) (member (length l) '(2 4 8 16 32 64 128 256))
(andmap (lambda (c) (andmap (lambda (c)
@ -84,36 +89,30 @@
(color? (vector-ref c 2)))) (color? (vector-ref c 2))))
l))) l)))
(define (color-map->bytes ColorMap) (define (color-map->bytes ColorMap)
(apply bytes (apply append (map vector->list ColorMap)))) (apply bytes (apply append (map vector->list ColorMap))))
(define (bits-per-pixel ColorMap) (define (bits-per-pixel ColorMap)
(case (length ColorMap) (case (length ColorMap)
[(2) 1] [(2) 1] [(4) 2] [(8) 3] [(16) 4] [(32) 5] [(64) 6] [(128) 7] [(256) 8]
[(4) 2]
[(8) 3]
[(16) 4]
[(32) 5]
[(64) 6]
[(128) 7]
[(256) 8]
[else (error 'bits-per-pixel [else (error 'bits-per-pixel
"strange colormap size: ~e" "strange colormap size: ~e"
(length ColorMap))])) (length ColorMap))]))
(define (WRITE g bytes) (define (WRITE g bytes)
(write-bytes bytes (gif-stream-port g))) (write-bytes bytes (gif-stream-port g)))
(provide/doc (proc-doc gif-state (([stream gif-stream?]) () . ->d . [_ symbol?]) (provide/doc (proc-doc gif-state
(([stream gif-stream?]) () . ->d . [_ symbol?])
@{Returns the state of @scheme[stream].})) @{Returns the state of @scheme[stream].}))
(define (gif-state GifFile) (define (gif-state GifFile)
(gif-stream-FileState GifFile)) (gif-stream-FileState GifFile))
;;/****************************************************************************** ;;/******************************************************************************
;; * This routine should be called before any other EGif calls, immediately ;; * This routine should be called before any other EGif calls, immediately
;; * follows the GIF file openning. ;; * follows the GIF file openning.
;; *****************************************************************************/ ;; *****************************************************************************/
(provide/doc (proc-doc (provide/doc (proc-doc
gif-start gif-start
(([out output-port?] (([out output-port?]
[w dimension?] [w dimension?]
@ -122,32 +121,26 @@
[cmap (or/c false/c gif-colormap?)]) [cmap (or/c false/c gif-colormap?)])
() ()
. ->d . [_ gif-stream?]) . ->d . [_ gif-stream?])
@{Writes the start of a GIF file to the given output port, and returns @{Writes the start of a GIF file to the given output port, and
a GIF stream that adds to the output port. returns a GIF stream that adds to the output port.
The width and height determine a virtual space for the overall GIF The width and height determine a virtual space for the overall
image. Individual images added to the GIF stream must fit within this GIF image. Individual images added to the GIF stream must fit
virtual space. The space is initialized by the given background color. 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) Finally, the default meaning of color numbers (such as the
is determined by the given colormap, but individual images background color) is determined by the given colormap, but
within the GIF file can have their own colormaps. individual images within the GIF file can have their own
colormaps.
A global colormap need not be supplied, in which case a colormap must A global colormap need not be supplied, in which case a
be supplied for each image. Beware that the bg-color is ill-defined if colormap must be supplied for each image. Beware that the
a global colormap is not provided.})) bg-color is ill-defined if a global colormap is not
(define (gif-start port provided.}))
Width (define (gif-start port Width Height BackGround ColorMap)
Height
BackGround
ColorMap)
(define GifFile (define GifFile
(make-gif-stream port (make-gif-stream port Width Height BackGround ColorMap 'init))
Width
Height
BackGround
ColorMap
'init))
(when ColorMap (when ColorMap
(unless (BackGround . < . (length ColorMap)) (unless (BackGround . < . (length ColorMap))
@ -184,11 +177,11 @@
GifFile) GifFile)
;;/****************************************************************************** ;;/******************************************************************************
;; * This routine should be called before any attempt to dump an image - any ;; * This routine should be called before any attempt to dump an image - any
;; * call to any of the pixel dump routines. ;; * call to any of the pixel dump routines.
;; *****************************************************************************/ ;; *****************************************************************************/
(provide/doc (proc-doc (provide/doc (proc-doc
gif-add-image gif-add-image
(([stream image-ready-gif-stream?] (([stream image-ready-gif-stream?]
[left dimension?] [left dimension?]
@ -200,43 +193,39 @@
[bstr bytes?]) [bstr bytes?])
() ()
. ->d . [_ void?]) . ->d . [_ void?])
@{Writes an image to the given GIF stream. The @scheme[left], @scheme[top], @{Writes an image to the given GIF stream. The @scheme[left],
@scheme[width], and @scheme[height] values specify the location and @scheme[top], @scheme[width], and @scheme[height] values
size of the image within the overall GIF image's virtual space. 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 If @scheme[interlaced?] is true, then @scheme[bstr] should
ininterlaced order instead of top-to-bottom order. Interlaced order is: provide bytes ininterlaced order instead of top-to-bottom
order. Interlaced order is:
@(itemize @(itemize @item{every 8th row, starting with 0}
@item{every 8th row, starting with 0}
@item{every 8th row, starting with 4} @item{every 8th row, starting with 4}
@item{every 4th row, starting with 2} @item{every 4th row, starting with 2}
@item{every 2nd row, starting with 1}) @item{every 2nd row, starting with 1})
If a global color is provided with @scheme[gif-start], a @scheme[#f] value If a global color is provided with @scheme[gif-start], a
can be provided for @scheme[cmap]. @scheme[#f] value can be provided for @scheme[cmap].
The @scheme[bstr] argument specifies the pixel content of the image. Each The @scheme[bstr] argument specifies the pixel content of the
byte specifies a color (i.e., an index in the colormap). Each row is image. Each byte specifies a color (i.e., an index in the
provided left-to-right, and the rows provided either top-to-bottom or colormap). Each row is provided left-to-right, and the rows
in interlaced order (see above). If the image is prefixed with a provided either top-to-bottom or in interlaced order (see
control that specifies an transparent index (see @scheme[gif-add-control]), above). If the image is prefixed with a control that specifies
then the corresponding ``color'' doesn't draw into the overall GIF an transparent index (see @scheme[gif-add-control]), then the
corresponding ``color'' doesn't draw into the overall GIF
image. image.
An exception is raised if any byte value in @scheme[bstr] is larger than the An exception is raised if any byte value in @scheme[bstr] is
colormap's length, if the @scheme[bstr] length is not @scheme[width] times larger than the colormap's length, if the @scheme[bstr] length
@scheme[height], or if the @scheme[top], @scheme[left], @scheme[width], and is not @scheme[width] times @scheme[height], or if the
@scheme[height] dimensions specify a region beyond the overall GIF image's @scheme[top], @scheme[left], @scheme[width], and
virtual space.})) @scheme[height] dimensions specify a region beyond the overall
(define (gif-add-image GifFile GIF image's virtual space.}))
Left (define (gif-add-image GifFile Left Top Width Height Interlace ColorMap Line)
Top
Width
Height
Interlace
ColorMap
Line)
(unless ColorMap (unless ColorMap
(unless (gif-stream-SColorMap GifFile) (unless (gif-stream-SColorMap GifFile)
@ -270,8 +259,7 @@
(when ColorMap (when ColorMap
(WRITE GifFile (color-map->bytes ColorMap))) (WRITE GifFile (color-map->bytes ColorMap)))
(let* ([cmap (or ColorMap (let* ([cmap (or ColorMap (gif-stream-SColorMap GifFile))])
(gif-stream-SColorMap GifFile))])
(check-line-bytes (length cmap) Line) (check-line-bytes (length cmap) Line)
@ -282,7 +270,7 @@
(set-gif-stream-FileState! GifFile 'image-or-control)) (set-gif-stream-FileState! GifFile 'image-or-control))
(define (check-line-bytes sz Line) (define (check-line-bytes sz Line)
(let loop ([i (bytes-length Line)]) (let loop ([i (bytes-length Line)])
(unless (zero? i) (unless (zero? i)
(let ([i (sub1 i)]) (let ([i (sub1 i)])
@ -294,10 +282,10 @@
(loop i))))) (loop i)))))
;;/****************************************************************************** ;;/******************************************************************************
;; * This routine should be called to add graphic control before the next image ;; * This routine should be called to add graphic control before the next image
;; *****************************************************************************/ ;; *****************************************************************************/
(provide/doc (proc-doc (provide/doc (proc-doc
gif-add-control gif-add-control
(([stream image-or-control-ready-gif-stream?] (([stream image-or-control-ready-gif-stream?]
[disposal (one-of/c 'any 'keep 'restore-bg 'restore-prev)] [disposal (one-of/c 'any 'keep 'restore-bg 'restore-prev)]
@ -306,41 +294,46 @@
[transparent (or/c false/c color?)]) [transparent (or/c false/c color?)])
() ()
. ->d . [_ void?]) . ->d . [_ void?])
@{Writes an image-control command to a GIF stream. Such a control must @{Writes an image-control command to a GIF stream. Such a control
appear just before an image, and it applies to the following image. must appear just before an image, and it applies to the
following image.
The GIF image model involves processing images one by one, placing The GIF image model involves processing images one by one,
each image into the specified position within the overall image's placing each image into the specified position within the
virtual space. An image-control command can specify a delay before an overall image's virtual space. An image-control command can
image is added (to create animated GIFs), and it also specifies how specify a delay before an image is added (to create animated
the image should be kept or removed from the overall image before GIFs), and it also specifies how the image should be kept or
proceeding to the next one (also for GIF animation). removed from the overall image before proceeding to the next
one (also for GIF animation).
The @scheme[disposal] argument specifies how to proceed: The @scheme[disposal] argument specifies how to proceed:
@(itemize @(itemize @item{@scheme['any] : doesn't matter (perhaps because
@item{@scheme['any] : doesn't matter (perhaps because the next image the next image completely overwrites the
completely overwrites the current one)} current one)}
@item{@scheme['keep] : leave the image in place} @item{@scheme['keep] : leave the image in place}
@item{@scheme['restore-bg] : replace the image with the background color} @item{@scheme['restore-bg] : replace the image with
@item{@scheme['restore-prev] : restore the overall image content to the the background color}
content before the image is added}) @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 If @scheme[wait-for-input?] is true, then the display program
some cue from the user (perhaps a mouse click) before adding the may wait for some cue from the user (perhaps a mouse click)
image. before adding the image.
The @scheme[delay] argument specifies a delay in 1/100s of a The @scheme[delay] argument specifies a delay in 1/100s of a
second. second.
If the @scheme[transparent] argument is a color, then it If the @scheme[transparent] argument is a color, then it
determines an index that is used to represent transparent pixels in the determines an index that is used to represent transparent
follow image (as opposed to the color specified by the colormap for the index). 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] An exception is raised if a control is already added to
without a corresponding image.})) @scheme[stream] without a corresponding image.}))
(define (gif-add-control GifFile (define (gif-add-control GifFile
Disposal Disposal
UserInput? UserInput?
Delay ; 1/100s of a second Delay ; 1/100s of a second
@ -361,34 +354,35 @@
0)) ; block terminator 0)) ; block terminator
(set-gif-stream-FileState! GifFile 'image)) (set-gif-stream-FileState! GifFile 'image))
;;/****************************************************************************** ;;/******************************************************************************
;; * This routine should be called to add the "loop" graphic control ;; * This routine should be called to add the "loop" graphic control
;; before adding any images ;; before adding any images
;; *****************************************************************************/ ;; *****************************************************************************/
(provide/doc (proc-doc (provide/doc (proc-doc
gif-add-loop-control gif-add-loop-control
(([stream empty-gif-stream?] (([stream empty-gif-stream?]
[iteration dimension?]) [iteration dimension?])
() ()
. ->d . [_ void?]) . ->d . [_ void?])
@{Writes a control command to a GIF stream for which no images or other @{Writes a control command to a GIF stream for which no images or
commands have already been written. The command causes the animating other commands have already been written. The command causes
sequence of images in the GIF to be repeated `iteration-dimension' the animating sequence of images in the GIF to be repeated
times, where 0 can be used to mean ``infinity.'' `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 An exception is raise if some control or image has been added
stream already.})) to the stream already.}))
(define (gif-add-loop-control GifFile (define (gif-add-loop-control GifFile
Iterations) Iterations)
(WRITE GifFile #"\x21\xFF\x0BNETSCAPE2.0\x03\x01") (WRITE GifFile #"\x21\xFF\x0BNETSCAPE2.0\x03\x01")
(EGifPutWord Iterations GifFile) (EGifPutWord Iterations GifFile)
(WRITE GifFile #"\x00") (WRITE GifFile #"\x00")
(set-gif-stream-FileState! GifFile 'image-or-control)) (set-gif-stream-FileState! GifFile 'image-or-control))
;;/****************************************************************************** ;;/******************************************************************************
;; * This routine should be called to add arbitrary comment text ;; * This routine should be called to add arbitrary comment text
;; *****************************************************************************/ ;; *****************************************************************************/
(provide/doc (proc-doc (provide/doc (proc-doc
gif-add-comment gif-add-comment
(([stream image-or-control-ready-gif-stream?] (([stream image-or-control-ready-gif-stream?]
[bstr bytes?]) [bstr bytes?])
@ -396,10 +390,9 @@
. ->d . [_ void?]) . ->d . [_ void?])
@{Adds a generic comment to the GIF stream. @{Adds a generic comment to the GIF stream.
An exception is raised if an image-control command was just written to An exception is raised if an image-control command was just
the stream (so that an image is required next).})) written to the stream (so that an image is required next).}))
(define (gif-add-comment GifFile (define (gif-add-comment GifFile Str)
Str)
(WRITE GifFile #"\x21\xFE") (WRITE GifFile #"\x21\xFE")
(let loop ([pos 0]) (let loop ([pos 0])
(when (pos . < . (bytes-length Str)) (when (pos . < . (bytes-length Str))
@ -410,34 +403,33 @@
(WRITE GifFile #"\0") (WRITE GifFile #"\0")
(set-gif-stream-FileState! GifFile 'image-or-control)) (set-gif-stream-FileState! GifFile 'image-or-control))
;;/****************************************************************************** ;;/******************************************************************************
;; * This routine should be called last, to end GIF file. ;; * This routine should be called last, to end GIF file.
;; *****************************************************************************/ ;; *****************************************************************************/
(provide/doc (proc-doc (provide/doc (proc-doc
gif-end gif-end
(([stream image-or-control-ready-gif-stream?]) (([stream image-or-control-ready-gif-stream?])
() ()
. ->d . [_ void?]) . ->d . [_ void?])
@{Finishes @{Finishes writing a GIF file. The GIF stream's output port is
writing a GIF file. The GIF stream's output port is not not automatically closed.
automatically closed.
An exception is raised if an image-control command was just written to An exception is raised if an image-control command was just
the stream (so that an image is required next).})) written to the stream (so that an image is required next).}))
(define (gif-end GifFile) (define (gif-end GifFile)
(WRITE GifFile #";") (WRITE GifFile #";")
(set-gif-stream-FileState! GifFile 'done)) (set-gif-stream-FileState! GifFile 'done))
;;/****************************************************************************** ;;/******************************************************************************
;; * Put 2 bytes (word) into the given file: ;; * Put 2 bytes (word) into the given file:
;; *****************************************************************************/ ;; *****************************************************************************/
(define (EGifPutWord Word GifFile) (define (EGifPutWord Word GifFile)
(WRITE GifFile (integer->integer-bytes Word 2 #f #f))) (WRITE GifFile (integer->integer-bytes Word 2 #f #f)))
;;/****************************************************************************** ;;/******************************************************************************
;; * LZ compression output ;; * LZ compression output
;; *****************************************************************************/ ;; *****************************************************************************/
(define (write-buffered-byte b buf port) (define (write-buffered-byte b buf port)
(let ([cnt (add1 (bytes-ref buf 0))]) (let ([cnt (add1 (bytes-ref buf 0))])
(bytes-set! buf cnt b) (bytes-set! buf cnt b)
(bytes-set! buf 0 cnt) (bytes-set! buf 0 cnt)
@ -445,12 +437,12 @@
(write-bytes buf port) (write-bytes buf port)
(bytes-set! buf 0 0)))) (bytes-set! buf 0 0))))
(define (CompressOutput port buf Code (define (CompressOutput port buf Code
RunningBits RunningCode MaxCode1 RunningBits RunningCode MaxCode1
CrntShiftState CrntShiftDWord) CrntShiftState CrntShiftDWord)
(let-values ([(CrntShiftState CrntShiftDWord) (let-values ([(CrntShiftState CrntShiftDWord)
(let loop ([CrntShiftDWord (bitwise-ior (let loop ([CrntShiftDWord
CrntShiftDWord (bitwise-ior CrntShiftDWord
(arithmetic-shift Code CrntShiftState))] (arithmetic-shift Code CrntShiftState))]
[CrntShiftState (+ CrntShiftState RunningBits)]) [CrntShiftState (+ CrntShiftState RunningBits)])
(if (CrntShiftState . >= . 8) (if (CrntShiftState . >= . 8)
@ -466,10 +458,10 @@
(values RunningBits MaxCode1 (values RunningBits MaxCode1
CrntShiftState CrntShiftDWord)))) CrntShiftState CrntShiftDWord))))
;;/****************************************************************************** ;;/******************************************************************************
;; * LZ compression ;; * LZ compression
;; *****************************************************************************/ ;; *****************************************************************************/
(define (EGifCompress GifFile BitsPerPixel Line) (define (EGifCompress GifFile BitsPerPixel Line)
(WRITE GifFile (bytes BitsPerPixel)) (WRITE GifFile (bytes BitsPerPixel))
@ -511,7 +503,8 @@
(let loop ([CrntShiftState CrntShiftState] (let loop ([CrntShiftState CrntShiftState]
[CrntShiftDWord CrntShiftDWord]) [CrntShiftDWord CrntShiftDWord])
(when (CrntShiftState . > . 0) (when (CrntShiftState . > . 0)
(write-buffered-byte (bitwise-and CrntShiftDWord #xff) buf port) (write-buffered-byte (bitwise-and CrntShiftDWord #xff)
buf port)
(loop (arithmetic-shift CrntShiftDWord -8) (loop (arithmetic-shift CrntShiftDWord -8)
(- CrntShiftState 8)))) (- CrntShiftState 8))))
(unless (zero? (bytes-ref buf 0)) (unless (zero? (bytes-ref buf 0))
@ -559,53 +552,53 @@
CrntShiftState CrntShiftDWord CrntShiftState CrntShiftDWord
HashTable (add1 i)))))))))))))) HashTable (add1 i))))))))))))))
;;/****************************************************************************** ;;/******************************************************************************
;; * color quantization utility ;; * color quantization utility
;; *****************************************************************************/ ;; *****************************************************************************/
(define (argb-bytes? b) (define (argb-bytes? b)
(and (bytes? b) (and (bytes? b)
(zero? (remainder (bytes-length b) 4)))) (zero? (remainder (bytes-length b) 4))))
(provide/doc (provide/doc
(proc-doc quantize (proc-doc quantize
(([bstr argb-bytes?]) (([bstr argb-bytes?])
() ()
. ->d . . ->d .
(values [_ bytes?] [_ gif-colormap?] [_ (or/c false/c color?)])) (values [_ bytes?] [_ gif-colormap?] [_ (or/c false/c color?)]))
@{Each @{Each image in a GIF stream is limited to 256 colors, including the
image in a GIF stream is limited to 256 colors, including the transparent ``color,'' if any. The @scheme[quantize] function
transparent ``color,'' if any. The @scheme[quantize] function helps converts a helps converts a 24-bit image (plus alpha channel) into an
24-bit image (plus alpha channel) into an indexed-color image,reducing indexed-color image,reducing the number of colors if necessary.
the number of colors if necessary.
Given a set of pixels expressed in ARGB format Given a set of pixels expressed in ARGB format (i.e., each four
(i.e., each four bytes is a set of values for one pixel: alpha, red, blue, and green), bytes is a set of values for one pixel: alpha, red, blue, and
@scheme[quantize] produces produces green),@scheme[quantize] produces produces
@(itemize @(itemize @item{bytes for the image (i.e., a array of colors,
@item{bytes for the image (i.e., a array of colors, expressed as a byte string)} expressed as a byte string)}
@item{a colormap} @item{a colormap}
@item{either @scheme[#f] or a color index for the transparent ``color''}) @item{either @scheme[#f] or a color index for the
transparent ``color''})
The conversion treats alpha values less than 128 as transparent The conversion treats alpha values less than 128 as transparent
pixels, and other alpha values as solid. pixels, and other alpha values as solid.
The quantization process first attempts to use all (non-transparent) The quantization process first attempts to use all
colors in the image. if that fails, it reduces the image to 12-bit (non-transparent) colors in the image. if that fails, it reduces
color (3 bits per each of red, green, and blue) by rounding up pixel the image to 12-bit color (3 bits per each of red, green, and
values, and tries again. If that fails, it reduces the image to 6-bit blue) by rounding up pixel values, and tries again. If that
color (2 bits per each of red, green, and blue). 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, 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 simply append them for the input of a single call of
then break apart the result bytes.})) @scheme[quantize], and then break apart the result bytes.}))
(define (quantize argb) (define (quantize argb)
(let* ([len (quotient (bytes-length argb) 4)] (let* ([len (quotient (bytes-length argb) 4)]
[result (make-bytes len)] [result (make-bytes len)]
[rgb-key (lambda (r g b) [rgb-key (lambda (r g b)
(bitwise-ior (bitwise-ior (bitwise-ior (bitwise-ior (arithmetic-shift r 16)
(arithmetic-shift r 16)
(arithmetic-shift g 8)) (arithmetic-shift g 8))
b))] b))]
[key->rgb (lambda (k) [key->rgb (lambda (k)
@ -655,9 +648,7 @@
(unless (= this-idx 256) (unless (= this-idx 256)
(bytes-set! result i this-idx) (bytes-set! result i this-idx)
(loop (add1 i) (+ pos 4)))))) (loop (add1 i) (+ pos 4))))))
(if ((hash-count table) . > . (if transparent (if ((hash-count table) . > . (if transparent 255 256))
255
256))
;; Try again ;; Try again
(loop (cdr masks)) (loop (cdr masks))
;; Found an ok quantization ;; Found an ok quantization
@ -674,9 +665,7 @@
[(<= cnt 128) 128] [(<= cnt 128) 128]
[else 256])] [else 256])]
[t (make-vector size #(0 0 0))]) [t (make-vector size #(0 0 0))])
(hash-for-each (for ([(k v) table])
table (vector-set! t v (key->rgb k)))
(lambda (k v)
(vector-set! t v (key->rgb k))))
(vector->list t)) (vector->list t))
transparent))))))) transparent))))))