;; This was hacked together from sources taken from the Garnet distribution,
;; the CLX distribution, etc.  It was written by Ken Meltsner, who doesn't
;; claim a copyright since the code is mostly swiped from other places.

;; This file is badly written since it patches several packages.  Feel free
;; to fix it.

(in-package :opal)

(define-method :draw opal:bitmap (gob line-style-gc filling-style-gc
				  drawable root-window clip-mask)
  (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*)))
   (when image
    (with-line-styles ((aref update-vals *bm-lstyle*) line-style-gc
		       xlib-gc-line root-window x-draw-fn clip-mask)
     (xlib::put-image drawable xlib-gc-line
		     image
		     :x (aref update-vals *bm-left*)
		     :y (aref update-vals *bm-top*)
		     :width (xlib:image-width image)
		     :height (xlib:image-height image)
		     :bitmap-p (= (xlib:image-depth image) 1)))
     )))

(defun build-pixmap (drawable image width height bitmap-p)
    (format t "~%building pixmap.")
    (let* ((pixmap (xlib:create-pixmap :width width :height height
                                     :drawable drawable
                                     :depth (xlib:image-depth image)))
         (gc (xlib:create-gcontext :drawable pixmap :function boole-1
                                   :foreground opal::*black*
                                   :background opal::*white*
                                   )))

    (xlib:put-image pixmap gc image
		    :x 0 :y 0 :width width :height height :bitmap-p bitmap-p)
    (xlib:free-gcontext gc)
    pixmap))

(in-package :user)

(create-instance 'pixmap opal:bitmap
  (:line-style opal:default-line-style)
  (:filling-style nil)
  (:image (o-formula (xlib::read-xpm-file (merge-pathnames (gvl :filename)))))
  (:ignored-slots :depended-slots :update-slots :update-slots-values
		  :root-pixmap-plist :image)
  (:update-slots '(:visible :fast-redraw-p :image :top :left
		   :line-style :filling-style :draw-function)))

(create-instance 'named-color opal:color
  (:red (o-formula (xlib:color-red (gvl :xcolor)) 1.0))
  (:green (o-formula (xlib:color-green (gvl :xcolor)) 1.0))
  (:blue (o-formula (xlib:color-blue (gvl :xcolor)) 1.0))
  (:xcolor (o-formula (cond ((gvl :color-name) (xlib:lookup-color
						opal::*default-x-colormap*
						(gvl :color-name)))
;; lookup-color will fail with an error if the color doesn't exist.  Should
;; probably learn how to use the condition system to avoid this.
			    ((and (gvl :red) (gvl :green) (gvl :blue))
			     (xlib:make-color :red (gvl :red)
					      :green (gvl :green)
					      :blue (gvl :blue)))
			    (t nil)))))
(in-package :xlib)

(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 image))
  (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
      (loop
       (setq line (read-line fstream))
       (unless (search "XPM" line) (return)))
      (flet ((read-keyword (line start end)
	       (kintern
	 	(substitute
		 #\- #\_
		 (#-excl string-upcase
			 #+excl correct-case
			 (subseq line start end))
		 :test #'char=))))
	(when (null name)
	  (setq name-end (position #\[ line :test #'char= :from-end t)
		name (read-keyword line 13 name-end))
	  (unless (eq name :image)
	    (setf (getf properties :name) name))))
    ;; Calculate sizes
    (loop
     (when (char= (aref line 0) #\") (return))
     (setq line (read-line fstream)))
    (setq line (read-from-string line))
    (let (width height ncolors depth left-pad chars-per-pixel)
      (declare (type (or null card16) width height)
	       (type image-depth depth)
	       (type card8 left-pad))
      (with-input-from-string (params line)
	(setq width (read params))
	(setq height (read params))
	(setq ncolors  (read params))
	(setq depth 8)
	(setq chars-per-pixel (read params))
	(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 8)
	     (bits-per-line (index* width bits-per-pixel))
	     (padded-bits-per-line
	      (index* (index-ceiling bits-per-line 32) 32))
	     (padded-bytes-per-line
	      (index-ceiling padded-bits-per-line 8))
	     (data (make-array (list height width)
			       :element-type '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))))
	    (declare (inline parse-hex))
	    ;; read color specifications -- KJM
	    (loop
	     (setq line (read-line fstream))
	     (when (char= (aref line 0) #\") (return))
	     )

	    (dotimes (cind ncolors)
	      (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))))

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

		   ;; We're hooked into Garnet for colormap management.
		   (setf (aref color-sequence cind)
			 (kr:g-value
			  (kr:create-instance
			  nil opal: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)))
			  :colormap-index))))

		(t (setq line
			 (read-from-string line))
		   (setf (aref color-sequence cind)
			 (kr:g-value
			  ;; check for named colors which already are in use
			  ;; this doesn't help with unnamed colors, which
			  ;; would be a useful improvement
			  (dolist
			   (nc (kr:get-values user::named-color :is-a-inv)
			       (kr:create-instance nil user::named-color
						   (:color-name line)))
			   (when (string= line (kr:g-value nc line))
				 (return nc)))
			  :colormap-index))))
	      (setq line (read-line fstream)))
	     ;; assumes one line between colors and data
	    ;; 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)
	      (read-char fstream)	;burn quote mark
	      (dotimes (j width)

		(dotimes (k chars-per-pixel)
		  (setf (aref pixel k)
			(read-char fstream)))

		(setf (aref data i j)

		      (aref color-sequence
			    (position pixel chars-sequence
				      :test #'string=))))

		

	      (read-line fstream)	;burn junk at end
	      ))
	;; Compensate for left-pad in width and x-hot
	(index-decf width left-pad)
	(when (getf properties :x-hot)
	  (index-decf (getf properties :x-hot) left-pad))
	(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))))))




