Color quantization: Difference between revisions
Content added Content deleted
m (Omit from AWK) |
(Add Common Lisp implementation) |
||
Line 126: | Line 126: | ||
free(heap.buf); |
free(heap.buf); |
||
}</lang> |
}</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}}== |
=={{header|D}}== |