Guo-Hall Thinning

guohall.lisp

;;; Performs Guo-Hall thinning of a grayscale image using OptiCL library

(require 'opticl)

(defun guo-hall-thinning (image)
  ;; convert to bitmap
  (declare (optimize (speed 3))
	   (type (simple-array (integer 0 255) (* *)) image))
  (loop for i from 0 below (array-total-size image)
	do (setf (row-major-aref image i)
		 (if (>= (row-major-aref image i) +threshold+) 1 0)))
  ;; perform transform
  (flet ((cycle (image evenp)
	   (flet ((at (i y x)
		    (and (pixel-in-bounds i y x)
			 (plusp (pixel i y x))))
		  (bi (v)
		    (if v 1 0)))
	     (destructuring-bind (h w) (array-dimensions image)
	       (let ((map (make-1-bit-gray-image h w
						 :initial-element 0)))
		 (declare (type (simple-array (integer 0 1) (* *)) map))
		 (loop for y from 0 below h do
		   (loop for x from 0 below w
			 for p2 = (at image (1- y) x)
			 for p3 = (at image (1- y) (1+ x))
			 for p4 = (at image y (1+ x))
			 for p5 = (at image (1+ y) (1+ x))
			 for p6 = (at image (1+ y) x)
			 for p7 = (at image (1+ y) (1- x))
			 for p8 = (at image y (1- x))
			 for p9 = (at image (1- y) (1- x))
			 for c = (+ (bi (and (not p2) (or p3 p4)))
				    (bi (and (not p4) (or p5 p6)))
				    (bi (and (not p6) (or p7 p8)))
				    (bi (and (not p8) (or p9 p2))))
			 for n1 = (+ (bi (or p9 p2)) (bi (or p3 p4))
				     (bi (or p5 p6)) (bi (or p7 p8)))
			 for n2 = (+ (bi (or p2 p3)) (bi (or p4 p5))
				     (bi (or p6 p7)) (bi (or p8 p9)))
			 for n = (min n1 n2)
			 for m = (if evenp
				     (and (or p2 p3 (not p5)) p4)
				     (and (or p6 p7 (not p9)) p8))
			 when (and (= c 1) (<= 2 n 3) (not m))
			   do (setf (pixel map y x) 1)))
		 (loop for i from 0 below (array-total-size image)
		       do (setf (row-major-aref image i)
				(logand (row-major-aref image i)
					(if (plusp (row-major-aref map i)) 0 1))))))
	     image)))
    (loop with prev
	  until (equalp image prev) do
	    (setf prev (copy-image image))
	    (cycle image t)
	    (cycle image nil)))
  ;; back to grayscale
  (loop for i from 0 below (array-total-size image)
	do (setf (row-major-aref image i) (* (row-major-aref image i) 255)))
  image)