47 lines
1.6 KiB
Common Lisp
47 lines
1.6 KiB
Common Lisp
(defpackage #:histogram
|
|
(:use #:cl
|
|
#:opticl))
|
|
|
|
(in-package #:histogram)
|
|
|
|
(defun color->gray-image (image)
|
|
(check-type image 8-bit-rgb-image)
|
|
(let ((gray-image (with-image-bounds (height width) image
|
|
(make-8-bit-gray-image height width :initial-element 0))))
|
|
(do-pixels (i j) image
|
|
(multiple-value-bind (r g b) (pixel image i j)
|
|
(let ((gray (+ (* 0.2126 r) (* 0.7152 g) (* 0.0722 b))))
|
|
(setf (pixel gray-image i j) (round gray)))))
|
|
gray-image))
|
|
|
|
(defun make-histogram (image)
|
|
(check-type image 8-bit-gray-image)
|
|
(let ((histogram (make-array 256 :element-type 'fixnum :initial-element 0)))
|
|
(do-pixels (i j) image
|
|
(incf (aref histogram (pixel image i j))))
|
|
histogram))
|
|
|
|
(defun find-median (histogram)
|
|
(loop with num-pixels = (loop for count across histogram sum count)
|
|
with half = (/ num-pixels 2)
|
|
for count across histogram
|
|
for i from 0
|
|
sum count into acc
|
|
when (>= acc half)
|
|
return i))
|
|
|
|
(defun gray->black&white-image (image)
|
|
(check-type image 8-bit-gray-image)
|
|
(let* ((histogram (make-histogram image))
|
|
(median (find-median histogram))
|
|
(bw-image (with-image-bounds (height width) image
|
|
(make-1-bit-gray-image height width :initial-element 0))))
|
|
(do-pixels (i j) image
|
|
(setf (pixel bw-image i j) (if (<= (pixel image i j) median) 1 0)))
|
|
bw-image))
|
|
|
|
(defun main ()
|
|
(let* ((image (read-jpeg-file "lenna.jpg"))
|
|
(bw-image (gray->black&white-image (color->gray-image image))))
|
|
(write-pbm-file "lenna-bw.pbm" bw-image)))
|