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

Moved octree-quantize to private, replacing original implementation of file/gif's quantize.

Browse Source 
svn: r10996
This commit is contained in:
Danny Yoo 2008-07-31 02:19:40 +00:00
parent 69d723acfc
commit ec408d0f24
3 changed files with 26 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
collects/file/gif.ss
View File

@ -17,7 +17,8 @@
#reader scribble/reader #reader scribble/reader
#lang scheme/base #lang scheme/base
(require scheme/contract (require scheme/contract
scribble/srcdoc) scribble/srcdoc
(prefix-in octree: file/private/octree-quantize))
(require/doc scheme/base (require/doc scheme/base
scribble/manual) scribble/manual)
@ -566,6 +567,7 @@
() ()
. ->d . . ->d .
(values [_ bytes?] [_ gif-colormap?] [_ (or/c false/c color?)])) (values [_ bytes?] [_ gif-colormap?] [_ (or/c false/c color?)]))
@{Each image in a GIF stream is limited to 256 colors, including the @{Each 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
converts a 24-bit image (plus alpha channel) into an converts a 24-bit image (plus alpha channel) into an
@ -584,88 +586,26 @@
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 The quantization process uses Octrees @cite["gervautz1990"] to construct an adaptive
(non-transparent) colors in the image. if that fails, it reduces palette for all (non-transparent) colors in the image. This implementation is
the image to 12-bit color (3 bits per each of red, green, and based on an article by Dean Clark @cite["clark1996"].
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, To convert a collection of images all with the same quantization,
simply append them for the input of a single call of simply append them for the input of a single call of
@scheme[quantize], and then break apart the result bytes.})) @scheme[quantize], and then break apart the result bytes.
@(bibliography
(bib-entry #:key "gervautz1990"
#:author "M. Gervautz and W. Purgathofer"
#:title "A simple method for color quantization: Octree quantization"
#:location "Graphics Gems"
#:date "1990")
(bib-entry #:key "clark1996"
#:author "Dean Clark"
#:title "Color Quantization using Octrees"
#:location "Dr. Dobbs Journal"
#:date "January 1, 1996"
#:url "http://www.ddj.com/184409805"))}))
(define (quantize argb) (define (quantize argb)
(let* ([len (quotient (bytes-length argb) 4)] (octree:quantize argb))
[result (make-bytes len)]
[rgb-key (lambda (r g b)
(bitwise-ior (bitwise-ior (arithmetic-shift r 16)
(arithmetic-shift g 8))
b))]
[key->rgb (lambda (k)
(vector (arithmetic-shift k -16)
(bitwise-and #xFF (arithmetic-shift k -8))
(bitwise-and #xFF k)))])
(let loop ([masks (list
;; 8 bits per color
(lambda (v) v)
;; 4 bits per color
(lambda (v)
(bitwise-ior
(bitwise-ior
v
(arithmetic-shift (bitwise-and v #x55) 1))
(arithmetic-shift (bitwise-and v #xCC) -1)))
;; 1 bit per color
(lambda (v)
(if (v . > . 127)
255
0)))])
(let ([mask (car masks)]
[transparent #f]
[table (make-hasheq)] ; relying on fixnums
[idx 0])
;; Iterate over image to count colors
;; (as reduced by mask)
(let loop ([i 0][pos 0])
(unless (= i len)
(let ([this-idx
(if ((bytes-ref argb pos) . < . 128)
(begin
(unless transparent
(set! transparent idx)
(set! idx (add1 idx)))
transparent)
(let ([vec (rgb-key
(mask (bytes-ref argb (+ 1 pos)))
(mask (bytes-ref argb (+ 2 pos)))
(mask (bytes-ref argb (+ 3 pos))))])
(let ([v (hash-ref table vec #f)])
(or v
(begin
(hash-set! table vec idx)
(set! idx (add1 idx))
(sub1 idx))))))])
(unless (= this-idx 256)
(bytes-set! result i this-idx)
(loop (add1 i) (+ pos 4))))))
(if ((hash-count table) . > . (if transparent 255 256))
;; Try again
(loop (cdr masks))
;; Found an ok quantization
(values result
(let* ([cnt (+ (hash-count table)
(if transparent 1 0))]
[size (cond
[(<= cnt 2) 2]
[(<= cnt 4) 4]
[(<= cnt 8) 8]
[(<= cnt 16) 16]
[(<= cnt 32) 32]
[(<= cnt 64) 64]
[(<= cnt 128) 128]
[else 256])]
[t (make-vector size #(0 0 0))])
(for ([(k v) table])
(vector-set! t v (key->rgb k)))
(vector->list t))
transparent))))))

0
collects/file/octree-quantize.ss → collects/file/private/octree-quantize.ss
View File

7
collects/mrlib/gif.ss
View File

@ -4,8 +4,7 @@
scheme/class scheme/class
scheme/list scheme/list
net/gifwrite net/gifwrite
scheme/contract scheme/contract)
(prefix-in octree: file/octree-quantize))
(provide write-gif (provide write-gif
write-animated-gif) write-animated-gif)
@ -44,7 +43,7 @@
(let ([last-argb-thunk (last argb-thunks)]) (let ([last-argb-thunk (last argb-thunks)])
(for-each (lambda (argb-thunk) (for-each (lambda (argb-thunk)
(let-values ([(pixels colormap transparent) (let-values ([(pixels colormap transparent)
(octree:quantize (argb-thunk))]) (quantize (argb-thunk))])
(when (or transparent delay) (when (or transparent delay)
(gif-add-control gif 'any #f (or delay 0) transparent)) (gif-add-control gif 'any #f (or delay 0) transparent))
(gif-add-image gif 0 0 w h #f colormap pixels) (gif-add-image gif 0 0 w h #f colormap pixels)
@ -55,7 +54,7 @@
(gif-end gif)))) (gif-end gif))))
;; Build images and quantize all at once: ;; Build images and quantize all at once:
(let-values ([(pixels colormap transparent) (let-values ([(pixels colormap transparent)
(octree:quantize (apply bytes-append (map (lambda (t) (t)) argb-thunks)))]) (quantize (apply bytes-append (map (lambda (t) (t)) argb-thunks)))])
(call-with-output-file* (call-with-output-file*
filename filename
(lambda (p) (lambda (p)