;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XLIB -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: CLX Enhancements
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/clx+.lisp
;;; File Creation Date: 11/14/91 12:11:15
;;; Last Modification Time: 08/04/92 11:49:41
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 11/25/1991 (Hubertus)  Fixed various bugs caused by Matthias' 
;;;                        'Never test programs written by yourself' 
;;;                        programming strategy.
;;;
;;;_____________________________________________________________________________

(in-package :xlib)

(eval-when (load eval compile)
  (export '(write-pixmap-file read-pixmap-file type-of-image-file percent-done)))

#||
* Get image
* Get #Colors
* Get used pixels
* Get corresponding color values
* Map used pixels onto a sequence from 0 on    0 -> pixel -> color
*Write color mapping

*read color mapping
*Map colors onto standard colormap  0 -> color -> standard pixel
*Copy standard colormap
*store new pixel values
*install colormap
||#

(defmacro vformat (pred format-string &rest format-args)
  `(when ,pred (format t ,format-string ,.format-args)))

(defun percent-done ()
  "May be redefined for a progression indicator.")

(defvar *max-colormap-size* 256 "Maximum size of colormap.")

(defstruct (image-info (:conc-name image-))
  (ximage nil :type (or null image))
  bits-per-pixel
  red
  blue
  green
  (used (make-array '(256) :element-type '(member t nil)
			       :Initial-element nil))
  (maxpixel 0 :type integer)
  (used-pixels 0 :type integer))

(defun create-image-info (&rest args)
  (let* ((iinfo (apply #'make-image-info args))
	 (type (if (= (image-bits-per-pixel iinfo) 24) 'card32 'card8)))
    (setf (image-red iinfo) (make-array 256 :element-type type))
    (setf (image-blue  iinfo) (make-array 256 :element-type type))
    (setf (image-green  iinfo) (make-array 256 :element-type type))
    iinfo))

(defvar *verbose* nil "Some functions will be more verbose if this is true")

(defun write-pixmap-file (pathname image colormap &key name (verbose *verbose*))
  "Writes the IMAGE and COLORMAP information to an image file in
 standard X pixmap format (xpm). The IMAGE can have depth 8
 (psuedo-color) or 24 (true-color). The NAME is an image identifier
 written to the file; the default NAME is (or (image-name IMAGE)
 'image)."
  (setq pathname (merge-pathnames pathname (make-pathname :type "xpm")))
  (let ((iinfo (prepare-image-info image colormap :verbose verbose)))
    (write-pixmap-file-internal iinfo pathname :name name :verbose verbose)))

(defun read-pixmap-file (pathname window &key (verbose *verbose*))
  "Reads an image file in standard X pixmap format and returns two
values: an IMAGE and a COLORMAP object.  It will be attempted to use the 
colormap of the given WINDOW. Otherwise a new colormap is created."
  (let ((colormap (window-colormap window))
	(depth (drawable-depth window)))
    (setq pathname (merge-pathnames pathname (make-pathname :type "xpm")))
    (unless (eq (type-of-image-file pathname) :xpm)
      (error "~a is not a PIXMAP file" pathname))
    (let* ((iinfo (read-pixmap-file-internal pathname window verbose))
	   (cm (uncompress-image-colormap iinfo window
					  :verbose verbose)))
      (values (image-ximage iinfo) (or cm colormap)))))

(defun prepare-image-info (image colormap &key verbose)
  (let* ((iinfo (create-image-info
		 :ximage image :bits-per-pixel (image-depth image))) 
	 (parray (image-z-pixarray image))
	 (pixel nil)
	 (pixels-used 0)
	 (maxcolors (min 256 (expt 2 (image-depth image))))
	 (auxarray (make-array (list maxcolors) :element-type 'integer)))
    (vformat verbose "~&Image has depth ~d~%" (image-depth image))
    (force-output)
    (cond ((= (image-depth image) 24)
	   (let ((i 0))
	     (dotimes (blue 8)
	       (dotimes (green 4)
		 (dotimes (red 8)
		   (setf (aref (image-red  iinfo) i) (ash red 5))
		   (setf (aref (image-green  iinfo) i) (ash green 6))
		   (setf (aref (image-blue  iinfo) i) (ash blue 5))
		   (incf i)))))
	   (flet ((normalize-pixel (Pixel)
		    (+ (ash (logand pixel #.(ash #B11100000 24)) #.(- 3 32))
		       (ash (logand pixel #.(ash #b11000000 16)) #.(- 5 24))
		       (ash (logand pixel #.(ash #b11100000 8)) #.(- 8 16)))))
	     (dotimes (row (image-height image))
	       (dotimes (col (image-width image))
		 (setq pixel    (normalize-pixel (aref parray row col)))
		 (setf (aref parray row col) pixel)
		 (when  (not (aref (image-used iinfo) pixel))
		   (incf pixels-used)
		   (setf (aref (image-used iinfo) pixel) t)
		   (when (> pixel (image-maxpixel iinfo))
		     (setf (image-maxpixel iinfo) pixel)))))))  
	  ((= (image-depth image) 8)
	   (dotimes (i maxcolors)
	     (setf (aref auxarray i) i))
	   (let ((carray (query-colors colormap auxarray :result-type 'array)))
	       (dotimes (pixel maxcolors)
		 (setf (aref (image-red iinfo) pixel)
		     (rgb-to-integer (color-red (aref carray pixel))))
		 (setf (aref (image-blue iinfo) pixel)
		     (rgb-to-integer (color-blue (aref carray pixel))))
		 (setf (aref (image-green iinfo) pixel)
		     (rgb-to-integer (color-green (aref carray pixel))))))
	   (dotimes (row (image-height image))
	     (dotimes (col (image-width image))
	       (setq pixel (aref parray row col))
	       (when  (not (aref (image-used iinfo) pixel))
		 (incf pixels-used)
		 (setf (aref (image-used iinfo) pixel) t)
		 (when (> pixel (image-maxpixel iinfo))
		   (setf (image-maxpixel iinfo) pixel)))))
	   ))
    (incf (image-maxpixel iinfo))
    (setf (image-used-pixels iinfo) pixels-used)
    (vformat verbose "Swapping colormap.~%")
    (compress-image-colormap iinfo)
    (vformat verbose "Colormap swapped.~%")
    iinfo))

(defun compress-image-colormap (image-info)
  (let ((remap (make-array (list (1+ (image-maxpixel image-info))) :element-type 'integer))
	(parray (image-z-pixarray (image-ximage image-info)))
	(pixel nil))
    (flet ((swap (array i k)
	   (let ((aux (aref array i)))
	     (setf (aref array i) (aref array k))
	     (setf (aref array k) aux))))
    (do ((i 0 (1+ i))
	 (k (position-if #'identity (image-used image-info)
			 :start 0)
	    (position-if #'identity (image-used image-info)
			 :start (1+ k))))
	((>= i (image-used-pixels image-info)))
      (setf (aref remap k) i)
      (when (not (= i k))
	;; Swap image-used:
	;(swap (image-used image-info) i k)
	;; Swap image colors:
	(swap (image-red image-info) i k)
	(swap (image-blue image-info) i k)
	(swap (image-green image-info) i k))))
    (dotimes (i (image-used-pixels image-info))
      (setf (aref (image-used image-info) i) t))
    (do ((i (image-used-pixels image-info) (1+ i)))
	((>= i (image-maxpixel image-info)))
      (setf (aref (image-used image-info) i) nil))
    (dotimes (row (image-height (image-ximage image-info)))
      (dotimes (col (image-width (image-ximage image-info)))
	(setq pixel (aref parray row col))
	(when (/= pixel (aref remap pixel))
	  (setf (aref parray row col) (aref remap pixel)))))
    (setf (image-maxpixel image-info) (image-used-pixels image-info))
    (setf (image-z-pixarray (image-ximage image-info)) parray)
    image-info))

(defun write-pixmap-file-internal (image-info pathname &key name verbose)
  (let* ((image (image-ximage image-info))
	 (parray (image-z-pixarray image))
	 (nc (image-maxpixel image-info))
	 (cpp (if (<= nc 26) 1 2))
	 (mne (make-array (list nc) :element-type '(array character 1))))
    (setq pathname (merge-pathnames pathname (make-pathname :type "xpm")))
    (with-open-file (outfile pathname :direction :output
		     :if-exists :rename)
      (unless name (setq name (pathname-name pathname)))
      (setq name (string-downcase name))
      (format outfile "#define ~a_format 1~%" name)
      (format outfile "#define ~a_width ~d~%" name (image-width image))
      (format outfile "#define ~a_height ~d~%" name (image-height image))
      (format outfile "#define ~a_ncolors ~d~%" name nc)
      (format outfile "#define ~a_chars_per_pixel ~d~%" name cpp)
      (format outfile "static char * ~a_colors[] = {~%" name)
      (vformat verbose "~&Writing colormap information.")
      (dotimes (cidx nc)
	(setf (aref mne cidx)
	    (cond ((= cpp 2)
		   (concatenate 'string 
		     (list (code-char (+ (floor cidx 10) #.(char-code #\a)))
			   (code-char (+ (mod cidx 10) #.(char-code #\0))))))
	      (t
	       (string (code-char (+ cidx (if (zerop cidx)
					     #.(char-code #\Space)
					   #.(char-code #\A))))))))
	(format outfile "\"~a\", \"#~2,'0x00~2,'0x00~2,'0x00\"~%"
		(aref mne cidx) (aref (image-red image-info) cidx)
		(aref (image-green image-info) cidx)
		(aref (image-blue image-info) cidx)))
      (format outfile "} ;~%")
      (vformat verbose "...~%")
      (vformat verbose "Writing pixel values")
      (format outfile "static char * ~a_pixels[] = {~%" name)
      (let ((aux (make-array (list (* (image-width image) cpp))
			     :element-type 'standard-char
			     :fill-pointer t)))
	(dotimes (h (image-height image))
	  (write-char #\" outfile)
	  (setf (fill-pointer aux) 0)
	  (dotimes (w (image-width image))
	    (let ((pixel-key (aref mne (aref parray h w))))
		(dotimes (j cpp)
		  (vector-push (char pixel-key j) aux))))
	  (write-string aux outfile)
	  (write-string "\"," outfile)
	  (terpri outfile)
	  (percent-done)
	  (vformat verbose ".")))
      (format outfile "} ;~%")
      (vformat verbose "~%")
      )))

(defun rgb-to-integer (rgb)
  (floor (* rgb 255)))

(defun integer-to-rgb (int)
  (float (/ int 255)))

(defmacro ignore-allocation-errors (&body args)
  `(ignore-errors ,.args))
		    
(defun uncompress-image-colormap (image-info window &key  verbose)
  (let* ((depth (drawable-depth window))
	 (colormap (window-colormap window))
	 (mne (make-array (list (image-maxpixel image-info))
			  :element-type (if (<= depth 8) 'card8 'card32)))
	 (image (image-ximage image-info))
	 (parray (image-z-pixarray image))
	 (new-pixel 0)
	 (alloc-pixels nil)
	 (alloc-pixel nil))
    (vformat verbose "~&Allocating ~d colors." (image-maxpixel image-info))
    (setq alloc-pixels
		   (ignore-allocation-errors (alloc-color-cells colormap
								(image-maxpixel image-info))))
    (unless alloc-pixels
      (vformat verbose "~&Creating new colormap.")
      (setf colormap (create-colormap (window-visual window) window))
      (setq alloc-pixels
		   (ignore-allocation-errors (alloc-color-cells colormap
								(image-maxpixel image-info)))))
    (when alloc-pixels
      (free-colors colormap alloc-pixels))
    (dotimes (pixel (image-maxpixel image-info))
      (cond ((= depth 8)
	     (let ((color
		    (make-color
		     :red (integer-to-rgb (aref (image-red image-info) pixel))
		     :green (integer-to-rgb (aref (image-green image-info) pixel))
		     :blue (integer-to-rgb (aref (image-blue image-info) pixel)))))
	       (setq alloc-pixel
		   (ignore-allocation-errors (alloc-color colormap color)))
	       (unless alloc-pixel
		   (setq alloc-pixel new-pixel)
		   (warn "Could not allocate pixel, using ~d" new-pixel)))
	       (setq new-pixel alloc-pixel))
	    ((= depth 24)
	     (setq new-pixel ;; pixel werte in array entsprechen nicht denen in Image
		   (* 256 (+ (aref (image-blue image-info) pixel)
		  (* 256 (+ (aref (image-green image-info) pixel)
			    (* 256 (aref (image-red image-info) pixel)))))))
	     #||  (vformat verbose "Red: ~3d Green: ~3d Blue: ~3d "
			(aref (image-red image-info) pixel)
			(aref (image-green image-info) pixel)
			(aref (image-blue image-info) pixel))||#)) 
      (setf (aref mne pixel) new-pixel))
    (dotimes (h (image-height image))
      (dotimes (w (image-width image))
	(setf (aref parray h w) (aref mne (aref parray h w)))))
    (setf (image-z-pixarray image) parray)
    (if (= depth 8) colormap)))

(defun read-pixmap-file-internal (pathname window &optional verbose)
  ;; Creates an image from a C include file in X11 pixmap format
  (declare (type (or pathname string stream) pathname))
  (declare (values image))
  (setq pathname (merge-pathnames pathname (make-pathname :type "xpm")))
  (with-open-file (fstream pathname :direction :input)
    (let ((display-depth (drawable-depth window))
	  (line "")
	  (properties nil)
	  (next nil)
	  (name nil)
	  (name-end nil))
      (declare (type string line)
	       (type stringable name)
	       (type list properties))
      ;; Get properties
      (loop
	(setq line (read-line fstream))
	(unless (char= (aref line 0) #\#) (return))
	(flet ((read-keyword (line start end)
		 (intern
		   (substitute
		     #\- #\_
		     (string-upcase (subseq line start end))
		     :test #'char=)
		   :keyword)))
	  (when (null name)
	    (setq name-end (position #\_ line :test #'char= :from-end t)
		  name (read-keyword line 8 name-end))
	    (unless (eq name :image)
	      (setf (getf properties :name) name)))
	  (let* ((ind-start (xlib::index1+ name-end))
		 (ind-end (position #\Space line :test #'char=
				    :start ind-start))
		 (ind (read-keyword line ind-start ind-end))
		 (val-start (xlib::index1+ ind-end))
		 (val (parse-integer line :start val-start)))
	    (setf (getf properties ind) val))))
      ;; Calculate sizes
      (multiple-value-bind
	  (format width height depth left-pad ncolors chars-per-pixel)
	  (flet ((extract-property (ind &rest default)
		   (prog1 (apply #'getf properties ind default)
			  (remf properties ind))))
	    (values (extract-property :format)
		    (extract-property :width)
		    (extract-property :height)
		    (extract-property :depth 8)
		    (extract-property :left-pad 0)
		    (extract-property :ncolors)
		    (extract-property :chars-per-pixel 1)))
	(declare (type (or null card16) width height)
		 (type image-depth depth)
		 (type card8 left-pad)
		 (ignore left-pad))
	(unless (and (eq format 1) width height) (error "Not a PIXMAP file"))
	(vformat verbose "~&Width: ~s, Height: ~s, Depth: ~s, Colors: ~s~%"
		   width height depth ncolors)
	(let* ((bits-per-pixel
		  (cond ((xlib::index> depth 24) 32)
			((xlib::index> depth 16) 24)
			((xlib::index> depth 8)  16)
			((xlib::index> depth 4)   8)
			((xlib::index> depth 1)   4)
			(t                  1)))
		 (bits-per-line (xlib::index* width bits-per-pixel))
		 (bytes-per-line (xlib::index-ceiling bits-per-line 8))
		 (padded-bits-per-line
		  (xlib::index* (xlib::index-ceiling bits-per-line 32) 32))
		 (padded-bytes-per-line
		  (xlib::index-ceiling padded-bits-per-line 8))
		 (data (make-array (list height width)
				   :element-type
				   (cond ((> display-depth 8) 'card32)
					 ((> display-depth 1) 'card8))))
		 (line-base 0)
		 (byte 0) 
		 (image-info (create-image-info
			      :bits-per-pixel display-depth))
		 (hashtable (make-hash-table :size (* 2 ncolors)
						  :test #'equal)))
	    (declare (type array-index bits-per-line bytes-per-line
			   padded-bits-per-line padded-bytes-per-line
			   line-base byte)
		     (ignore byte line-base padded-bytes-per-line bytes-per-line))
	    (vformat verbose "Setting up color table.~%")
	    (loop 
	      (when (search "_colors[]" line)
		(return))
	      (setq line (read-line fstream)))
	    (flet ((parse-hex (char)
		     (second
		      (assoc char
			     '((#\0  0) (#\1  1) (#\2  2) (#\3  3)
			       (#\4  4) (#\5  5) (#\6  6) (#\7  7)
			       (#\8  8) (#\9  9) (#\a 10) (#\b 11)
			       (#\c 12) (#\d 13) (#\e 14) (#\f 15))
			     :test #'char-equal))))
	      (flet ((pixel-key-to-index (string)
		       (cond ((= chars-per-pixel 1)
			      (if (char= (char string 0) #\Space)
				  0
				(- (char-code (char string 0))
				   #.(char-code #\A))))
			     ((= chars-per-pixel 2)
			      (+ (* 10 (- (char-code (char string 0))
					  #.(char-code #\a)))
				 (- (char-code (char string 1))
				    #.(char-code #\0))))
			     (t (error "Cannot handle XPM format with ~d chars-per-pixel" chars-per-pixel))))
		 
		     (read-color-value ()
		       (let ((number 0))
			 (incf number (parse-hex (read-char fstream)))
			 (setq number (* 16 number))
			 (incf number (parse-hex (read-char fstream)))
			 (cond ((> depth 8)
				(setq number (* 16 number))
				(incf number (parse-hex (read-char fstream)))
				(setq number (* 16 number))
				(incf number (parse-hex (read-char fstream))))
			       (t (read-char fstream) (read-char fstream)))
			 number))
		     (read-color-value2 (string start length)
		       (let ((number 0))
			 (incf number (parse-hex (char string start )))
			 (dotimes (i length number)
			   (incf start)
			   (when (or (< i 1)
				     (> depth 8))
			     (setq number (* 16 number))
			     (incf number (parse-hex (char string start))))))))
		(let ((hex-length nil))
		  (dotimes (i ncolors)
		    (loop (when (char= (peek-char nil fstream) #\")(return))
		      (read-char fstream))
		    (setq next (read fstream))
		    (setf (gethash next hashtable) i)
		    (loop (when (char= (peek-char nil fstream) #\")(return))
		      (read-char fstream))
		    (setq next (read fstream))
		    (cond ((char= (char next 0) #\#)
			   (setq hex-length
			       (floor (1- (length next)) 3))
			   (setf (aref (image-red image-info) i)
			       (read-color-value2 next 1 hex-length))
			   (setf (aref (image-green image-info) i)
			       (read-color-value2 next (1+ hex-length) hex-length))
			   (setf (aref (image-blue image-info) i)
			       (read-color-value2 next (+ hex-length hex-length 1)
						  hex-length)))
			  ((typep next 'stringable) ;; it is a name
			   (let ((color
				  (ignore-errors
				   (lookup-color (window-colormap window)
						 next))))
			   (setf (aref (image-red image-info) i)
			       (rgb-to-integer (color-red color)))
			   (setf (aref (image-green image-info) i)
			       (rgb-to-integer (color-green color)))
			   (setf (aref (image-blue image-info) i)
			       (rgb-to-integer (color-blue color)))))
			  (t (error "Unknown color specification format: ~s"
				    next)))
		    (vformat verbose "Index ~3d: ~s ~a ~a ~a~%" i next
				    (aref (image-red image-info) i)
				    (aref (image-green image-info) i)
				    (aref (image-blue image-info) i))))
		(read-line fstream)
		(percent-done)
		(let ((input (make-string chars-per-pixel)))
		  (flet ((read-next-color-key ()
			   (dotimes (i chars-per-pixel)
			     (setf (char input i) (read-char fstream)))
			   (gethash input hashtable)))
		    (loop (when (search "_pixels[]" (read-line fstream))
			    (return)))
		    (dotimes (row height)
		      (loop (when (char= (read-char fstream) #\") (return))) ;#\"
		      (dotimes (col width)
			(setq next  (read-next-color-key))
			(setf (aref data row col) next)
			(unless (aref (image-used image-info) next)
			  (setf (aref (image-used image-info) next) t)
			  (incf (image-used-pixels image-info))))
		      (read-char fstream)
		      (percent-done) ;; the closing double quote
		      )))
		
		    
		(setf (image-maxpixel image-info) ncolors)
		(setf (image-ximage image-info)
		    (create-image
		     :width width :height height
		     :depth display-depth :bits-per-pixel (if (= display-depth 24) 32 display-depth)
		     :data data :byte-lsb-first-p nil
		     :plist properties :format :z-pixmap))
		image-info)))))))
      
(defun type-of-image-file (pathname)
  ;; Creates an image from a C include file in X11 pixmap format
  (declare (type (or pathname string stream) pathname))
  (declare (values image))
  (setq pathname (merge-pathnames pathname (make-pathname :type "xpm")))
  (with-open-file (fstream pathname :direction :input)
    (let ((line "")
	  (properties nil)
	  (name nil)
	  (name-end nil))
      (declare (type string line)
	       (type stringable name)
	       (type list properties))
      ;; Get properties
      (ignore-errors
	      (loop
		(setq line (read-line fstream))
		(unless (char= (aref line 0) #\#) (return))
		(flet ((read-keyword (line start end)
			 (intern
			  (substitute
			   #\- #\_
			   (string-upcase (subseq line start end))
			   :test #'char=)
			  :keyword)))
		  (when (null name)
		    (setq name-end (position #\_ line :test #'char= :from-end t)
			  name (read-keyword line 8 name-end))
		    (unless (eq name :image)
		      (setf (getf properties :name) name)))
		  (let* ((ind-start (xlib::index1+ name-end))
			 (ind-end (position #\Space line :test #'char=
					    :start ind-start))
			 (ind (read-keyword line ind-start ind-end))
			 (val-start (xlib::index1+ ind-end))
			 (val (parse-integer line :start val-start)))
		    (setf (getf properties ind) val))))
	      (multiple-value-bind (format width height depth left-pad ncolors chars-per-pixel)
		  
		(flet ((extract-property (ind &rest default)
			 (prog1 (apply #'getf properties ind default)
			   (remf properties ind))))
		  (values (extract-property :format)
			  (extract-property :width)
			  (extract-property :height)
			  (extract-property :depth 8)
			  (extract-property :left-pad 0)
			  (extract-property :ncolors)
			  (extract-property :chars-per-pixel 1)))
		(declare (ignore left-pad chars-per-pixel))
		(cond ((and (eq format 1) ncolors width height)
		       (values :xpm width height depth))
		      ((and width height)
		       (values :xbm width height depth))
		      (t nil)))))))

