Color quantization: Difference between revisions

Line 139:

(defun image->pixels (image)

(check-type image 8-bit-rgb-image)

(let ((pixels ~~(make-hash-table :test #'equal))~~)

(let (pixels)

(do-pixels (y x) image

(~~setf (gethash~~ (pixel* image y x) pixels~~) t~~))

(push (pixel* image y x) pixels))

~~(loop for p being the hash-key of~~ pixels

pixels))

collect p)))

(defun greatest-color-range (pixels)

Line 164:

Line 163:

(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~~))

(if (or (= target-num-colors 1) (null (rest pixels)))

(list pixels)

(let* ((channel (greatest-color-range pixels))

Line 174:

Line 173:

(defun quantize-colors (pixels target-num-colors)

(~~loop with~~ color-map = (make-hash-table :test #'equal)

(let ((color-map (make-hash-table :test #'equal)))

~~for~~ bucket in (median-cut pixels target-num-colors)

(dolist (bucket (median-cut pixels target-num-colors) color-map)

do (loop for (r g b) in bucket

(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)

finally (let ((average (list (round r-sum num-pixels)

(round g-sum num-pixels)

(round b-sum num-pixels))

(round b-sum num-pixels))))

~~for~~ pixel in bucket

(dolist (pixel bucket)

do (setf (gethash pixel color-map) average)))

(setf (gethash pixel color-map) average)))))))

finally (return color-map)))

(defun quantize-image (input-file output-file target-num-colors)