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