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

* Set svn:eol-style

Browse Source 
* Minor style edits
* No need for a specific exception, and fix error messages

svn: r10994
This commit is contained in:
Eli Barzilay 2008-07-31 00:56:22 +00:00
parent f2a1773422
commit 8740c47362
1 changed files with 65 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
collects/file/octree-quantize.ss
View File

@ -14,7 +14,7 @@
;; Adaptively quantizes 24-bit image data to fit within, at most, 256 colors ;; Adaptively quantizes 24-bit image data to fit within, at most, 256 colors
;; (including the transparent color.) The signature is meant to match the ;; (including the transparent color.) The signature is meant to match the
;; function provided by file/gif. ;; function provided by file/gif.
(define (quantize argb #:palette (palette 255)) (define (quantize argb #:palette [palette 255])
(let* ([an-octree (make-octree-from-argb argb palette)] (let* ([an-octree (make-octree-from-argb argb palette)]
[len (bytes-length argb)] [len (bytes-length argb)]
[dest (make-bytes (/ len 4))]) [dest (make-bytes (/ len 4))])
@ -33,13 +33,11 @@
(values dest (vector->list (octree-palette an-octree)) TRANSPARENT-INDEX))) (values dest (vector->list (octree-palette an-octree)) TRANSPARENT-INDEX)))
;; make-octree-from-argb: bytes positive-number -> octree ;; make-octree-from-argb: bytes positive-number -> octree
;; Constructs an octree ready to quantize the colors from an-argb. ;; Constructs an octree ready to quantize the colors from an-argb.
(define (make-octree-from-argb an-argb n) (define (make-octree-from-argb an-argb n)
(unless (> n 0) (unless (> n 0)
(raise (make-exn:fail:octree "n must be positive" (current-continuation-marks)))) (raise-type-error 'make-octree-from-argb "positive number" n))
(let ([an-octree (new-octree)] (let ([an-octree (new-octree)]
[len (bytes-length an-argb)]) [len (bytes-length an-argb)])
(let make-octree-loop ([i 0]) (let make-octree-loop ([i 0])
@ -64,11 +62,8 @@
(define (alpha-opaque? a) (define (alpha-opaque? a)
(>= a 128)) (>= a 128))
(define TRANSPARENT-INDEX 0) (define TRANSPARENT-INDEX 0)
;; quantize-bitmap: bitmap positive-number -> bitmap ;; quantize-bitmap: bitmap positive-number -> bitmap
;; Given a bitmap, returns a new bitmap quantized to, at most, n colors. ;; Given a bitmap, returns a new bitmap quantized to, at most, n colors.
(define (quantize-bitmap bm n) (define (quantize-bitmap bm n)
@ -108,42 +103,33 @@
(send dc set-bitmap #f) (send dc set-bitmap #f)
new-bm))) new-bm)))
;; The maximum level height of an octree. ;; The maximum level height of an octree.
(define MAX-LEVEL 7) (define MAX-LEVEL 7)
(define byte/c (integer-in 0 255)) (define byte/c (integer-in 0 255))
(define octet/c (integer-in 0 7)) (define octet/c (integer-in 0 7))
;; A color is a (vector byte byte byte)
(define-struct (exn:fail:octree exn:fail) ())
;; A color is an (vector byte byte byte)
;; An octree is a: ;; An octree is a:
(define-struct octree (root ;; node (define-struct octree (root ; node
leaf-count ;; number leaf-count ; number
reduction-heads ;; (vectorof (or/c node #f)) reduction-heads ; (vectorof (or/c node #f))
palette ;; (vectorof (or/c color #f)) palette) ; (vectorof (or/c color #f))
)
#:mutable) #:mutable)
;; reduction-heads is used to accelerate the search for a reduction candidate. ;; reduction-heads is used to accelerate the search for a reduction candidate.
;; A subtree node is a: ;; A subtree node is a:
(define-struct node (leaf? ;; bool (define-struct node (leaf? ; bool
npixels ;; number -- number of pixels this subtree node represents npixels ; number -- number of pixels this subtree node represents
redsum ;; number redsum ; number
greensum ;; number greensum ; number
bluesum ;; number bluesum ; number
children ;; (vectorof (or/c #f node)) children ; (vectorof (or/c #f node))
next ;; (or/c #f node) next ; (or/c #f node)
palette-index ;; (or/c #f (integer-in 0 255)) palette-index) ; (or/c #f (integer-in 0 255))
)
#:mutable) #:mutable)
;; node-next is used to accelerate the search for a reduction candidate. ;; node-next is used to accelerate the search for a reduction candidate.
@ -161,25 +147,22 @@
)] )]
[an-octree [an-octree
(make-octree root-node (make-octree root-node
0 ;; no leaves so far 0 ; no leaves so far
(make-vector (add1 MAX-LEVEL) #f) ;; no reductions so far (make-vector (add1 MAX-LEVEL) #f) ; no reductions so far
(make-vector 256 #(0 0 0)) ;; the palette (make-vector 256 #(0 0 0)))]) ; the palette
)])
;; Although we'll almost never reduce to this level, initialize the first ;; Although we'll almost never reduce to this level, initialize the first
;; reducible node to the root, for completeness sake. ;; reducible node to the root, for completeness sake.
(vector-set! (octree-reduction-heads an-octree) 0 root-node) (vector-set! (octree-reduction-heads an-octree) 0 root-node)
an-octree)) an-octree))
;; rgb->index: natural-number byte byte byte -> octet ;; rgb->index: natural-number byte byte byte -> octet
;; Given a level and an (r,g,b) triplet, returns an octet that can be used ;; Given a level and an (r,g,b) triplet, returns an octet that can be used
;; as an index into our octree structure. ;; as an index into our octree structure.
(define (rgb->index level r g b) (define (rgb->index level r g b)
(bitwise-ior (bitwise-ior (bitwise-and 4 (arithmetic-shift r (- level 5)))
(bitwise-and 4 (arithmetic-shift r (- level 5))) (bitwise-and 2 (arithmetic-shift g (- level 6)))
(bitwise-and 2 (arithmetic-shift g (- level 6))) (bitwise-and 1 (arithmetic-shift b (- level 7)))))
(bitwise-and 1 (arithmetic-shift b (- level 7)))))
;; octree-insert-color!: octree byte byte byte -> void ;; octree-insert-color!: octree byte byte byte -> void
@ -217,11 +200,11 @@
(cond (cond
[(= level MAX-LEVEL) [(= level MAX-LEVEL)
;; If we added a leaf, mark it in the octree. ;; If we added a leaf, mark it in the octree.
(set-octree-leaf-count! an-octree (set-octree-leaf-count! an-octree
(add1 (octree-leaf-count an-octree)))] (add1 (octree-leaf-count an-octree)))]
[else [else
;; Attach the node as a reducible node if it's interior. ;; Attach the node as a reducible node if it's interior.
(set-node-next! (set-node-next!
new-node (vector-ref (octree-reduction-heads an-octree) new-node (vector-ref (octree-reduction-heads an-octree)
(add1 level))) (add1 level)))
(vector-set! (octree-reduction-heads an-octree) (vector-set! (octree-reduction-heads an-octree)
@ -235,8 +218,7 @@
;; octree-reduce!: octree -> void ;; octree-reduce!: octree -> void
;; Reduces one of the subtrees, collapsing the children into a single node. ;; Reduces one of the subtrees, collapsing the children into a single node.
(define (octree-reduce! an-octree) (define (octree-reduce! an-octree)
(let ([candidate (pop-reduction-candidate! an-octree)]) (node-reduce! (pop-reduction-candidate! an-octree) an-octree))
(node-reduce! candidate an-octree)))
;; node-reduce!: node octree -> void ;; node-reduce!: node octree -> void
@ -286,10 +268,9 @@
(for ([child (in-vector (node-children a-node))] (for ([child (in-vector (node-children a-node))]
#:when (and child (not (node-leaf? child)))) #:when (and child (not (node-leaf? child))))
(loop child) (loop child)
(when (interior-node-one-leaf-child? a-node) (when (interior-node-one-leaf-child? a-node)
(node-reduce! a-node an-octree)))) (node-reduce! a-node an-octree))))
;; Attach palette entries. ;; Attach palette entries.
(let ([current-palette-index 1]) (let ([current-palette-index 1])
(let loop ([a-node (octree-root an-octree)]) (let loop ([a-node (octree-root an-octree)])
@ -314,16 +295,14 @@
(node-leaf? (car child-list))))) (node-leaf? (car child-list)))))
;; octree-lookup: octree byte byte byte -> (values byte byte byte) ;; octree-lookup: octree byte byte byte -> (values byte byte byte)
;; Returns the palettized color. ;; Returns the palettized color.
(define (octree-lookup an-octree r g b) (define (octree-lookup an-octree r g b)
(let ([index (let* ([index (node-lookup-index (octree-root an-octree) an-octree r g b 0)]
(node-lookup-index (octree-root an-octree) an-octree r g b 0)]) [vec (vector-ref (octree-palette an-octree) index)])
(let ([vec (vector-ref (octree-palette an-octree) index)]) (values (vector-ref vec 0)
(values (vector-ref vec 0) (vector-ref vec 1)
(vector-ref vec 1) (vector-ref vec 2))))
(vector-ref vec 2)))))
;; octree-lookup-index: octree byte byte byte -> byte ;; octree-lookup-index: octree byte byte byte -> byte
@ -337,18 +316,14 @@
(define (node-lookup-index a-node an-octree r g b level) (define (node-lookup-index a-node an-octree r g b level)
(let loop ([a-node a-node] (let loop ([a-node a-node]
[level level]) [level level])
(cond [(node-leaf? a-node) (if (node-leaf? a-node)
(node-palette-index a-node)] (node-palette-index a-node)
[else (let ([child (vector-ref (node-children a-node) (rgb->index level r g b))])
(let ([child (vector-ref (node-children a-node) (rgb->index level r g b))]) (unless child
(unless child (error 'node-lookup-index
(raise (make-exn:fail:octree "color (~a, ~a, ~a) not previously inserted"
(format r g b))
"octree-lookup: Color (~a, ~a, ~a) not previously inserted" (loop child (add1 level))))))
r g b)
(current-continuation-marks))))
(loop child (add1 level)))])))
(define color? byte?) (define color? byte?)
@ -369,31 +344,30 @@
(zero? (remainder (bytes-length b) 4)))) (zero? (remainder (bytes-length b) 4))))
(provide/contract [quantize ((argb-bytes?) (#:palette (integer-in 1 255)) (provide/contract
. ->* . (values bytes? gif-colormap? color?))] [quantize ((argb-bytes?) (#:palette [integer-in 1 255])
[quantize-bitmap ((is-a?/c bitmap%) natural-number/c . ->* . (values bytes? gif-colormap? color?))]
. -> . [quantize-bitmap
(is-a?/c bitmap%))] ([is-a?/c bitmap%] natural-number/c . -> . [is-a?/c bitmap%])]
[struct (exn:fail:octree exn:fail) ((message string?) [struct octree
(continuation-marks continuation-mark-set?))] ([root node?]
[struct octree [leaf-count natural-number/c]
((root node?) [reduction-heads (vectorof (or/c node? false/c))]
(leaf-count natural-number/c) [palette (vectorof (vector/c byte/c byte/c byte/c))])]
(reduction-heads (vectorof (or/c node? false/c))) [struct node
(palette (vectorof (vector/c byte/c byte/c byte/c))))] ([leaf? boolean?]
[struct node [npixels natural-number/c]
((leaf? boolean?) [redsum natural-number/c]
(npixels natural-number/c) [greensum natural-number/c]
(redsum natural-number/c) [bluesum natural-number/c]
(greensum natural-number/c) [children (vectorof (or/c false/c node?))]
(bluesum natural-number/c) [next (or/c node? false/c)]
(children (vectorof (or/c false/c node?))) [palette-index byte/c])]
(next (or/c node? false/c)) [new-octree (-> octree?)]
(palette-index byte/c))] [octree-insert-color! (octree? byte/c byte/c byte/c . -> . any)]
[new-octree (-> octree?)] [octree-lookup
[octree-insert-color! (octree? byte/c byte/c byte/c . -> . any)] (octree? byte/c byte/c byte/c . -> . (values byte/c byte/c byte/c))]
[octree-lookup (octree? byte/c byte/c byte/c . -> . (values byte/c byte/c byte/c))] [octree-reduce! (octree? . -> . any)]
[octree-reduce! (octree? . -> . any)] [octree-finalize! (octree? . -> . any)]
[octree-finalize! (octree? . -> . any)] [rgb->index (natural-number/c byte/c byte/c byte/c . -> . octet/c)])
[rgb->index (natural-number/c byte/c byte/c byte/c . -> . octet/c)])