(ql:quickload :cl-netpbm)

(defun burkes (img thresh &aux
                  (x (array-dimension img 0))
                  (y (array-dimension img 1)))
 (declare (type fixnum x y thresh)
          (optimize (speed 3) (safety 0)))
 (let ((res (make-array (array-dimensions img)
                        :element-type 'bit))
       (cur (make-array (+ 4 x)
                        :element-type 'double-float))
       (nxt (make-array (+ 4 x)
                        :element-type 'double-float)))
   (declare (dynamic-extent cur nxt))
   (loop for i from 0 to (1- y)
         do (progn
              (loop for j from 0 to (1- x)
                    do (let* ((s (+ (aref img j i)
                                    (aref cur (+ j 2))))
                              (pix (if (< s thresh)
                                       0
                                       1))
                              (err (- s (* pix 255))))
                         (setf (aref res j i) pix)
                         (incf (aref cur (+ j 3)) (* err 0.25D0))
                         (incf (aref cur (+ j 4)) (* err 0.125D0))
                         (incf (aref nxt j) (* err 0.0625D0))
                         (incf (aref nxt (+ j 1)) (* err 0.125D0))
                         (incf (aref nxt (+ j 2)) (* err 0.25D0))
                         (incf (aref nxt (+ j 3)) (* err 0.125D0))
                         (setf (aref nxt (+ j 4)) (* err 0.0625D0))))
              (let ((tmp cur))
                (loop for i from 0 to 3
                      do (setf (aref tmp i) 0.0D0))
                (setf cur nxt)
                (setf nxt tmp))))
   res))

(defun serria-lite (img thresh &aux
                  (x (array-dimension img 0))
                  (y (array-dimension img 1)))
 (let ((res (make-array (array-dimensions img)
                        :element-type 'bit))
       (cur (make-array (+ 2 x)
                        :element-type 'double-float))
       (fwd (make-array (+ 2 x)
                        :element-type 'double-float)))
   (loop for i from 0 to (1- y)
         do (progn
              (loop for j from 0 to (1- x)
                    do (let* ((s (+ (aref img j i)
                                    (aref cur (1+ j))))
                              (pix (if (< s thresh)
                                       0
                                       1))
                              (err (- s (* pix 255))))
                         (setf (aref res j i) pix)
                         (incf (aref cur (+ j 2)) (* err 0.5D0))
                         (let ((n (* err 0.25D0)))
                           (incf (aref fwd j) n)
                           (setf (aref fwd (1+ j)) n))))
              (let ((tmp cur))
                (setf (aref tmp (1- x)) 0.0D0
                      (aref tmp 0) 0.0D0)
                (setf cur fwd)
                (setf fwd tmp))))
   res))


(defun atkinson (img thresh
                &aux
                  (x (array-dimension img 0))
                  (y (array-dimension img 1)))
 (declare (type fixnum x y thresh)
          (optimize (speed 3) (safety 0)))
 (let ((res (make-array (array-dimensions img)
                        :element-type 'bit))
       (cur (make-array (+ 3 x)
                        :element-type 'double-float))
       (fwd1 (make-array (+ 3 x)
                         :element-type 'double-float))
       (fwd2 (make-array (+ 3 x)
                         :element-type 'double-float)))
   (declare (dynamic-extent cur fwd1 fwd2))
   (loop for i from 0 to (1- y)
         do (progn
              (loop for j from 0 to (1- x)
                    do (let* ((s (+ (aref img j i)
                                    (aref cur (1+ j))))
                              (pix (if (< s thresh)
                                       0
                                       1))
                              (err (* 0.125D0 (- s (* pix 255)))))
                         (setf (aref res j i) pix)
                         (incf (aref cur (+ j 2)) err)
                         (incf (aref cur (+ j 3)) err)
                         (incf (aref fwd1 j) err)
                         (incf (aref fwd1 (1+ j)) err)
                         (incf (aref fwd1 (+ j 2)) err)
                         (setf (aref fwd2 (1+ j)) err)))
              (let ((tmp cur))
                (setf (aref cur 0) 0.0D0
                      (aref cur (1- x)) 0.0D0
                      (aref cur (- x 2)) 0.0D0)
                (setf cur fwd1)
                (setf fwd1 fwd2)
                (setf fwd2 tmp))))
   res))

(defvar *value* 210)
(defvar *dither-function* #'atkinson)
(defun convert (file)
 (netpbm:write-to-file
  (make-pathname :name (pathname-name file) :type "pbm")
  (funcall *dither-function* (netpbm:read-from-file file) *value*)
  :format :pbm))

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.