;;; An (X)Emacs command to convert GIF or PNG image to gray X-Faces

;; For your .emacs file:
;;(autoload 'convert-image-to-gray-x-face "make-gray-x-face" nil t)

;; This program is stolen from gnus-fun.el.

(eval-when-compile
  (require 'cl))

(defun convert-image-to-gray-x-face (file depth)
  (interactive "*fFile: \nnDepth: ")
  (if (not (file-exists-p file))
      (error "File not found: %s" file))
  (if (or (< depth 2) (> depth 8))
      (error "Depth must be a positive number from 2 to 8"))
  (let* ((mapfile (expand-file-name
		   (make-temp-name "gray-x-face.")
		   (or (and (fboundp 'temp-directory)
			    (eval '(temp-directory)))
		       (and (boundp 'temporary-file-directory)
			    (stringp (symbol-value
				      'temporary-file-directory))
			    (file-directory-p (symbol-value
					       'temporary-file-directory))
			    (symbol-value 'temporary-file-directory))
		       "/tmp/")))
	 (levels (expt 2 depth))
	 (step (/ 255 (1- levels)))
	 color-alist bits-list mask pixel x-faces)
    (when (file-exists-p file)
      (let ((coding-system-for-read 'binary)
	    (coding-system-for-write 'binary)
	    default-enable-multibyte-characters
	    (case-fold-search t))
	(with-temp-buffer
	  (insert-file-contents file)
	  (goto-char (point-min))
	  (cond ((looking-at "GIF8[79]")
		 (call-process-region (point-min) (point-max)
				      "giftopnm" t '(t nil)))
		((looking-at "\x89PNG")
		 (call-process-region (point-min) (point-max)
				      "pngtopnm" t '(t nil)))
		(t
		 (error "Unsupported image format")))
	  (call-process-region (point-min) (point-max)
			       "ppmnorm" t '(t nil))
	  (call-process-region (point-min) (point-max)
			       "pnmscale" t '(t nil) nil
			       "-width" "48" "-height" "48")
	  (with-temp-file mapfile
	    (insert "P3\n")
	    (insert (format "%d 1\n" levels))
	    (insert "255\n")
	    (dotimes (i levels)
	      (insert (format "%d %d %d\n"
			      (* step i) (* step i) (* step i)))
	      (push (cons (* step i) i) color-alist)))
	  (unwind-protect
	      (call-process-region (point-min) (point-max)
				   "ppmquant" t '(t nil) nil
				   "-fs" "-map" mapfile)
	    (delete-file mapfile))
	  (call-process-region (point-min) (point-max)
			       "ppmtopgm" t '(t nil))
	  (call-process-region (point-min) (point-max)
			       "pnmnoraw" t '(t nil))
	  (goto-char (point-min))
	  (forward-line 3)
	  (while (setq pixel (ignore-errors (read (current-buffer))))
	    (push (cdr (assq pixel color-alist)) bits-list))
	  (setq bits-list (nreverse bits-list))
	  (dotimes (bit-number depth)
	    (setq mask (expt 2 bit-number))
	    (erase-buffer)
	    (insert "P1\n48 48\n")
	    (dolist (bits bits-list)
	      (insert (if (zerop (logand bits mask)) "0 " "1 ")))
	    (call-process-region (point-min) (point-max)
				 "pbmtoicon" t '(t nil))
	    (goto-char (point-min))
	    (re-search-forward "0x[0-9a-f][0-9a-f][0-9a-f][0-9a-f],")
	    (delete-region (point-min) (match-beginning 0))
	    (goto-char (point-min))
	    (while (search-forward "0x" nil t)
	      (replace-match ""))
	    (goto-char (point-min))
	    (while (re-search-forward "[^0-9a-f]+" nil t)
	      (replace-match ""))
	    (let ((coding-system-for-read 'raw-text))
	      (call-process-region (point-min) (point-max)
				   "compface" t '(t nil)))
	    (push (buffer-string) x-faces))))
      (unless (bolp)
	(forward-line 1)
	(unless (bolp)
	  (insert "\n")))
      (dotimes (i (length x-faces))
	(if (zerop i)
	    (insert "X-Face:" (car x-faces))
	  (save-restriction
	    (narrow-to-region (point) (point))
	    (insert (nth i x-faces))
	    (goto-char (point-min))
	    (while (re-search-forward "[\t\n ]+" nil t)
	      (replace-match ""))
	    (goto-char (point-min))
	    (insert "X-Face-" (number-to-string i) ": ")
	    (while (prog1
		       (= 79 (move-to-column 79))
		     (insert "\n ")))
	    (delete-backward-char 1)))))))