;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;; Originally written by meltsner@chipman.crd.ge.com,
;;

;;; CHANGE LOG:
;;;
;;;  9/22/93 Bruno Haible - CLISP doesn't allow declarations in flet
;;;  8/26/93 Andrew Mickish - Added Reset-Pixmap-Images
;;;  6-Apr-93 koz Converted with-*-styles macros to set-*-style fns
;;;               And omitted "clip-mask" as argument to draw function.
;;; 12/01/92 Andrew Mickish - Added bitmap-p switches so pixmaps will work
;;;            on b/w screens
;;; 10/05/92 Martin Sjolin - Removed CMCUL compiler warnings
;;; 09/12/92 Andrew Mickish - Added :xpm-format switch to Write-xpm-File,
;;;            implemented XPM2 output format.
;;; 09/10/92 Andrew Mickish - Repaired bugs introduced when adding pedro-format
;;; 09/09/92 Pedro Szekely - Added :format :z-pixmap parameter to
;;;            xlib:get-image call in Window-To-Pximap-Image; reimplemented
;;;            Write-xpm-File with write-char instead of format
;;; 08/11/92 Andrew Mickish - Added pedro-format to read-xpm-file
;;;


(in-package "OPAL" :use '("LISP" "KR"))

(export '(pixmap write-xpm-file read-xpm-file 
	  create-pixmap-image window-to-pixmap-image))

;    This function was originally written to handle two types of pixmaps --
; those of the meltsner-format (XPM2) and those not of the meltsner-format
; (XPM1).  I added the pedro-format, which is a subset of the meltsner-format
; (an XPM2 format from the Sun Icon Editor).
; Non-metlsner (XPM1) format files look like
;     #define foo_format 1
;     #define foo_width  32
;     #define foo_height 32
;     #define foo_ncolors 4
;     #define foo_chars_per_pixel 1
;     static char *foo_colors[] = {
;        " ", "#FFFFFFFFFFFF",
;     ...
; Meltsner-format files look like
;     /* XPM */
;     static char * move_3xpm[] = {
;     "16 16 3 1",
;     " 	c #FFFFFFFFFFFF",
;     ...
; while pedro-format files look like
;     ! XPM2  
;     16 16 3 1
;       c #FFFFFFFFFFFF
;     ...
;
;    Some files have garbage between the color information and the pixel
; information, and care should be taken to ignore the garbage only after
; ascertaining that it is definitely not data!  This may be difficult,
; because spaces that are garbage and spaces that are data tend to look
; similar.

(defun read-xpm-file (pathname)
  ;; Creates an image from a C include file in standard X11 format
  ;; core of this taken from CLX image.lisp file
  (declare (type (or pathname string stream) pathname))
  (declare (values xlib:image))
  (with-open-file (fstream pathname :direction :input)
    (let ((line "")
	  (properties nil)
	  (name nil)
	  (name-end nil)
	  (meltsner-format nil)
	  (pedro-format nil))
      (declare ; (type string line)
       (type xlib:stringable name)
       (type list properties))
      ;; Get properties
      (loop
	(setq line (read-line fstream))
	(unless (search "XPM" line) (return)))
      (setq meltsner-format (not (eq #\# (aref line 0))))
      ;; The pedro-format does not have a line that begins with "static char"
      (setq pedro-format (not (search "static char" line)))
      (flet ((read-keyword (line start end)
	       (xlib::kintern
		(substitute
		 #\- #\_
		 (string-upcase
		  (subseq line start end))
		 :test #'char=))))
	(when (null name)
	  (if meltsner-format
	      (if pedro-format
		  ; In the pedro-format, the line that usually gives you the
		  ; name of the pixmap does not exist
		  (setq name :untitled)
		  (setq name-end (position #\[ line :test #'char= :from-end t)
			name (read-keyword line 13 name-end)))
	      (setq name-end (search "_format " line)
		    name (read-keyword line 8 name-end)))
	  (unless (eq name :image)
	    (setf (getf properties :name) name))))

      ;; Calculate sizes
      ; In the meltsner-format, read until you get to a line beginning with
      ; a #\".  In the pedro-format, the desired line is already current,
      ; and #\" characters aren't used anyway.
      (when (and meltsner-format (not pedro-format))
	(loop
	  (when (char= (aref line 0) #\") (return))
	  (setq line (read-line fstream)))
	(setq line (read-from-string line)))
      (let ((bitmap-p (not (g-value opal:color :color-p)))
	    width height ncolors depth left-pad chars-per-pixel)
	(declare (type (or null xlib:card16) width height)
		 (type (or null xlib:image-depth) depth)
		 (type (or null xlib:card8) left-pad))
	(if meltsner-format
	    (with-input-from-string (params line)
	      (setq width (read params))
	      (setq height (read params))
	      (setq ncolors  (read params))
	      (setq depth (if bitmap-p 1 8))
	      (setq chars-per-pixel (read params))
	      (setq left-pad 0))
	    (progn
	      (setq line (read-line fstream))
	      (setq width (read-from-string (subseq line (1+ (position #\space line :from-end t)))))
	      (setq line (read-line fstream))
	      (setq height (read-from-string (subseq line (1+ (position #\space line :from-end t)))))
	      (setq line (read-line fstream))
	      (setq ncolors (read-from-string (subseq line (1+ (position #\space line :from-end t)))))
	      (setq depth (if bitmap-p 1 8))
	      (setq line (read-line fstream))
	      (setq chars-per-pixel (read-from-string (subseq line (1+ (position #\space line :from-end t)))))
	      (setq left-pad 0)))

	(unless (and width height) (error "Not a BITMAP file"))
	(let* ((color-sequence (make-array ncolors))
	       (chars-sequence (make-array ncolors))
	       (bits-per-pixel (if bitmap-p 1 8))
	       (bits-per-line (xlib::index* width bits-per-pixel))
	       (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
				 (if bitmap-p
				     'xlib::pixarray-1-element-type
				     'xlib::pixarray-8-element-type)))
	       (pixel (make-sequence 'string chars-per-pixel)))

	  (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))))
	    #-clisp
	    (declare (inline parse-hex))

	    (dotimes (cind ncolors)
	      ; Eat garbage until we get to a line like 
	      ; " c #FFFFFFFFFFFF...",
	      (loop
	       (setq line (read-line fstream))
	       (when (or (search "\"," line)
			 (and (not (search "static" line))
			      (search "c " line)))
		 (return)))

	      (if meltsner-format
		  (progn
		    ; If not in pedro-format, line is currently a string of
		    ; a string -- remove one layer of stringness
		    (unless pedro-format
		      (setq line (read-from-string line)))
		    ;  Got the pixel characters
		    (setf (aref chars-sequence cind)
			  (subseq line 0 chars-per-pixel))
		    (setq line
			  (subseq line (+ 2 (position #\c line
					      :start chars-per-pixel))))
		    )
		  (progn
		    (setf (aref chars-sequence cind) (read-from-string line))
		    (setq line
			  (read-from-string (subseq line (1+ (position #\, line)))))
		  ))
	      
	      (cond
	       ((char-equal #\# (aref line 0))
		(let* ((vals (map 'list #'parse-hex
				  (subseq line 1
					  (position #\space line :start 2))))
		       (clength (/ (length vals) 3))
		       (divisor (- (expt 16 clength) 1)))
		  
		  (setf (aref color-sequence cind)
			(xlib:alloc-color 
			 opal::*default-x-colormap*
			 (xlib:make-color
			  :red (/ (let ((accum 0))
				    (dotimes (mm clength accum)
				      (setq accum
					    (+ (* 16 accum) (pop vals)))))
				  divisor)
			  :green (/ (let ((accum 0))
				      (dotimes (mm clength accum)
					(setq accum
					      (+ (* 16 accum) (pop vals)))))
				    divisor)
			  :blue (/ (let ((accum 0))
				     (dotimes (mm clength accum)
				       (setq accum
					     (+ (* 16 accum) (pop vals)))))
				   divisor))))
		  ;; end of setf
		  ))
	       
	       (t (when meltsner-format
		    (setq line
		      (read-from-string line)))
		  (setf (aref color-sequence cind)
			(xlib:alloc-color opal::*default-x-colormap*
					  (xlib:lookup-color
					   opal::*default-x-colormap* line)))
		  ;; end of setf
		  ))
	      )

	    ;; Eat garbage between color information and pixels.
	    ;; Some pixmap files have no garbage, some have a single line
	    ;; of the comment /* pixels */, and non-meltsner-format files
	    ;; have two lines of garbage.
	    (if meltsner-format
		;; Only eat the line if it is a /* pixel */ comment
		(when (char= #\/ (peek-char NIL fstream))
		  (setq line (read-line fstream)))
		(setq line (read-line fstream)
		      line (read-line fstream)))

	    ;; Read data
	    ;; Note: using read-line instead of read-char would be 20% faster,
	    ;;       but would cons a lot of garbage...
	    ;; I'm not sure I should follow the above -- egc might be faster.
	    (dotimes (i height)
	      (when (char= #\" (peek-char NIL fstream))
		(read-char fstream)) ;burn quote mark
	      (dotimes (j width)
		(dotimes (k chars-per-pixel)
		  (setf (aref pixel k)
			(read-char fstream)))
		(let* ((value (aref color-sequence
				    (position pixel chars-sequence
					      :test #'string=)))
		       (adjusted-value (if bitmap-p
					   (if (eql value 0) value 1)
					   value)))
		  (setf (aref data i j) adjusted-value)))
	      (read-line fstream)	;burn junk at end
	      ))

	  ;; Compensate for left-pad in width and x-hot
	  (xlib::index-decf width left-pad)
	  (when (getf properties :x-hot)
	    (xlib::index-decf (getf properties :x-hot) left-pad))
	  (xlib:create-image
	   :width width :height height
	   :depth depth :bits-per-pixel bits-per-pixel
	   :data data :plist properties
	   :format :z-pixmap

	   :bytes-per-line padded-bytes-per-line
	   :unit 32 :pad 32 :left-pad left-pad
	   :byte-lsb-first-p t :bit-lsb-first-p t))))))

(defun digit-to-hex (n)
  (character (+ (if (< n 10) 48 55) n)))

(defun print-hex (f n)
  (format f "~A~A~A~A" (digit-to-hex (mod (floor n 4096) 16))
		       (digit-to-hex (mod (floor n 256) 16))
		       (digit-to-hex (mod (floor n 16) 16))
		       (digit-to-hex (mod n 16))))

(defun write-xpm-file (pixmap pathname &key (xpm-format :xpm1))
  (let ((f (open pathname :direction :output :if-exists :supersede))
	(name (substitute #\_ #\- (pathname-name pathname)))
	(image (g-value pixmap :image)))
    (let ((width (xlib:image-width image))
	  (height (xlib:image-height image))
	  (pixarray (xlib:image-z-pixarray image))
	  (indices (make-array 256 :element-type 'character
				   :initial-element #\null))
	  (ncolors 0))
      (dotimes (i height)
        (dotimes (j width)
	  (when (eq #\null (aref indices (aref pixarray i j)))
	    (setf (aref indices (aref pixarray i j))
		  (character (+ (if (< ncolors 2) 32 33) ncolors)))
	    (incf ncolors))))
      (case xpm-format
	(:xpm1 (format f "#define ~A_format 1~%" name)
	       (format f "#define ~A_width  ~A~%" name width)
	       (format f "#define ~A_height ~A~%" name height)
	       (format f "#define ~A_ncolors ~A~%" name ncolors)
	       (format f "#define ~A_chars_per_pixel 1~%" name)
	       (format f "static char *~A_colors[] = {~%" name))
	(:xpm2 (format f "/* XPM2 C */~%")
	       (format f "static char * ~A[] = {~%" name)
	       (format f "/* ~A pixmap~%" name)
	       (format f " * width height ncolors chars_per_pixel */~%")
	       (format f "\"~A ~A ~A 1 \",~%" width height ncolors)))
      (dotimes (n 256)
	(unless (eq #\null (aref indices n))
	  (let* ((color (car (xlib:query-colors opal::*default-x-colormap* (list n))))
		 (red (floor (* 65535 (xlib:color-red color))))
		 (green (floor (* 65535 (xlib:color-green color))))
		 (blue (floor (* 65535 (xlib:color-blue color)))))
	    (case xpm-format
	      (:xpm1 (format f "   \"~A\", \"#" (aref indices n))
		     (print-hex f red)
		     (print-hex f green)
		     (print-hex f blue)
		     (format f "\",~%"))
	      (:xpm2 (let ((index (aref indices n)))
		       (format f "\"~A  c #~X~X~X~30,5ts s_~X~X~X \",~%"
			       index red green blue red green blue)))))))
      (case xpm-format
	(:xpm1 (format f "};~%")
	       (format f "static char *~A_pixels[] = {~%" name))
	(:xpm2 (format f "/* pixels */~%")))
      (dotimes (i height)
	(write-char #\" f)
	(dotimes (j width)
	  (write-char (aref indices (aref pixarray i j)) f)
	  )
	(write-char #\" f)
	(unless (eq i (1- height))
	  (write-char #\, f)
	  )
	(terpri f)
	)
      (format f "};~%")
      (close f))))

(create-instance 'opal:pixmap opal:bitmap
  :declare ((:parameters :left :top :image :line-style :draw-function :visible)
	    ;; Have to recompute the image when you change displays
	    (:maybe-constant T :except :image))
  (:line-style opal:default-line-style)
  (:pixarray (o-formula (if (gvl :image) (xlib:image-z-pixarray (gvl :image))))))

(define-method :draw opal:pixmap (gob line-style-gc filling-style-gc
				  drawable root-window)
  (declare (ignore filling-style-gc))
  (let* ((update-vals (get-local-value gob :update-slots-values))
	 (xlib-gc-line (opal-gc-gcontext line-style-gc))
	 (x-draw-fn  (get (aref update-vals *bm-draw-function*)
			 :x-draw-function))
	 (image (aref update-vals *bm-image*))
	 (bitmap-p (= (xlib:image-depth image) 1))
	 (line-style (aref update-vals *bm-lstyle*))
	 (left (aref update-vals *bm-left*))
	 (top (aref update-vals *bm-top*))
	 (width (xlib:image-width image))
	 (height (xlib:image-height image)))
   (when (and image line-style)
       (set-line-style line-style line-style-gc xlib-gc-line root-window
			x-draw-fn)
       (if (or bitmap-p (g-value opal:color :color-p))
	   (xlib:put-image drawable xlib-gc-line image :x left :y top
			   :width width :height height :bitmap-p bitmap-p)
	   (xlib:draw-rectangle drawable xlib-gc-line left top width height T)
	   ))))


(defun create-pixmap-image (width height &optional color)
  (xlib:create-image :depth 8
		     :width width
		     :height height
		     :format :z-pixmap
		     :data (make-array (list height width)
			     :element-type 'xlib::pixarray-8-element-type
			     :initial-element (if color 
						  (g-value color :colormap-index)
						  opal::*white*))))

;;; Creates a pixmap image containing whatever is in the window.
(defun window-to-pixmap-image (window &key left top width height)
  (let ((drawable (g-value window :drawable)))
    (when drawable
      (xlib:get-image drawable
		      :format :z-pixmap
		      :x (or left 0)
		      :y (or top 0)
		      :width (or width (g-value window :width))
		      :height (or height (g-value window :height))))))



(defun reset-pixmap-images ()
  (opal::do-all-instances opal::pixmap
    #'(lambda (p)
	(recompute-formula p :image))))

(push #'reset-pixmap-images opal::*auxilliary-reconnect-routines*)
