Color quantization: Difference between revisions
Add Common Lisp implementation
m (Omit from AWK) |
(Add Common Lisp implementation) |
||
Line 126:
free(heap.buf);
}</lang>
=={{header|Common Lisp}}==
{{libheader|opticl}}
Use median cut.
<lang lisp>(defpackage #:quantize
(:use #:cl
#:opticl))
(in-package #:quantize)
(defun image->pixels (image)
(check-type image 8-bit-rgb-image)
(let ((pixels (make-hash-table :test #'equal)))
(do-pixels (y x) image
(setf (gethash (pixel* image y x) pixels) t))
(loop for p being the hash-key of pixels
collect p)))
(defun greatest-color-range (pixels)
(loop for (r g b) in pixels
minimize r into r-min
minimize g into g-min
minimize b into b-min
maximize r into r-max
maximize g into g-max
maximize b into b-max
finally
(return (let* ((r-range (- r-max r-min))
(g-range (- g-max g-min))
(b-range (- b-max b-min))
(max-range (max r-range g-range b-range)))
(cond ((= r-range max-range) 0)
((= g-range max-range) 1)
(t 2))))))
(defun median-cut (pixels target-num-colors)
(assert (zerop (mod (log target-num-colors 2) 1)))
(if (or (= target-num-colors 1) (<= (length pixels) target-num-colors))
(list pixels)
(let* ((channel (greatest-color-range pixels))
(sorted (sort pixels #'< :key (lambda (pixel) (nth channel pixel))))
(half (floor (length sorted) 2))
(next-target (/ target-num-colors 2)))
(nconc (median-cut (subseq sorted 0 half) next-target)
(median-cut (subseq sorted half) next-target)))))
(defun quantize-colors (pixels target-num-colors)
(loop with color-map = (make-hash-table :test #'equal)
for bucket in (median-cut pixels target-num-colors)
do (loop for (r g b) in bucket
sum r into r-sum
sum g into g-sum
sum b into b-sum
count t into num-pixels
finally (loop with average = (list (round r-sum num-pixels)
(round g-sum num-pixels)
(round b-sum num-pixels))
for pixel in bucket
do (setf (gethash pixel color-map) average)))
finally (return color-map)))
(defun quantize-image (input-file output-file target-num-colors)
(let* ((image (read-png-file input-file))
(pixels (image->pixels image))
(color-map (quantize-colors pixels target-num-colors))
(result-image (with-image-bounds (height width) image
(make-8-bit-rgb-image height width :initial-element 0))))
(set-pixels (y x) result-image
(let* ((original (multiple-value-list (pixel image y x)))
(quantized (gethash original color-map)))
(values-list quantized)))
(write-png-file output-file result-image)))</lang>
=={{header|D}}==
| |||