;; utilities to parse XPM files
;;=============================================================================
;;                    data structure in memory
;;=============================================================================

;;AUTOLOAD: XPM

(defstruct XPM
  name
  width
  height
  ncolors
  cpp
  x_hotspot
  y_hotspot
  colors				;vector of XPM:Color
  pixels				;vector of rows (vector of pixel strings)
  extensions?
  extensions				;vector of xpm:Extension
  extensions-lines			;raw lines
  comments				;vector of xpm:Comment
  ;; parsing infos
  lines					;source lines as read
  index					;current line
)

(defstruct XPM:Color
  glyph
  mono
  color
  gray4
  gray
  symbolic
)

(defstruct XPM:Extension
  name
  data
)

(defstruct XPM:Comment
  position				;the line it was at
  text
)
  
;;=============================================================================
;;                    parsing a file
;;=============================================================================

;; regular expressions

(with (
    begin "^"
    end "$"
    space "[ \t]"
    space* "[ \t]*"
    space+ "[ \t]+"
    any ".*"
    dquote "[\"]"
    squote "'"
    q quote-string-for-regexp
    c-ident "[a-zA-Z_][a-zA-Z_0-9]*"
    number "-?[0-9]+"
    B "("
    E ")"
    par (lambdam (&rest args) `(+ "(" ,@args ")"))
    opt (lambda (arg) (+ arg "?"))
  )
  (setqn
    xpm:re-comment (regcomp (+ 
	"^" space* (q "/*") any (q "*/") space* "$"
    ))
    xpm:re-open-comment (regcomp (+ "^" space* (q "/*")))
    xpm:re-close-comment (regcomp (+ (q "*/") space* "$"))
    xpm:re-name (regcomp (+
	begin space* "static" space+ "char" space* (q "*") space* (par c-ident)
	space* (q "[") space* (q "]") space* "=" space* "{" space* end
    ))
    xpm:re-name-tolerant (regcomp (+
	begin space* "static" space+ "char" space* (q "*") space* 
	(par "[^ \t*[]+")
	space* (q "[") space* (q "]") space* "=" space* "{" space* end
    ))
    xpm:re-values (regcomp (+
	begin space* dquote
	space* (par number)		; 1 width
	space+ (par number)		; 2 height
	space+ (par number)		; 3 ncolors
	space+ (par number)		; 4 cpp
	(par				; 5 hotspot
	  space+ (par number)		; 6 x_hotspot
	  space+ (par number)		; 7 y_hotspot
	) "?"				; (hotspot is optional)
	space*
	(par "XPMEXT") "?"		; 8 XPMEXT (optional)
	dquote "," space* end
    ))
    xpm:re-colors (regcomp (+
	begin space* dquote (par "([^ \t]+)?[ \t]+" (par any)) 
	dquote space* "," space* end
    ))
    xpm:re-color (regcomp (+
	begin space* 
	(par "c|g|g4|m|s")
	space+
	(par "([ \t]*[-#%a-zA-Z_0-9][-#%a-zA-Z_0-9][-#%a-zA-Z_0-9]+)+")
	space* 
	(par any)			;rest
	end
    ))
    xpm:re-pixel-row (regcomp (+
	begin space* dquote (par any) dquote space* "(,|}[ \t]*;|}|)" space* end
    ))
))

;; the parsing

;;AUTOLOAD: xpm:read
;;AUTODOC: xpm:read "parses an XPM X pixmap file"
;;(xpm:read filename)
;;
;;returns a XPM structure. see source "xpm-format.kl"
;;filename can also be a list of lines (strings) in memory

(defun xpm:read (filename &key verbose &aux
    (xpm (XPM-new))			;result
    (glyph-table (Hashtable ()))
  )
  (if (typep filename List)		;list of lines?
    (XPM-lines xpm filename)
    (catch 'EOF				;else read it
      (with (fd (open filename) lines (XPM-lines xpm))
	(while t (lappend lines (read-line fd)))
  )))
					;header
  (if (/= (XPM-curline xpm) "/* XPM */")
    (xpm:parse-error "bad header (1st line): not /* XPM */, but %0"
      (XPM-curline xpm))
  )
  (xpm:must-match xpm:re-name-tolerant xpm)	;name
  (if (not (regexec xpm:re-name (regsub xpm:re-name-tolerant 0))) (with (
	oldname (regsub xpm:re-name-tolerant 1)
	newname (replace-string (copy oldname)
	  "[^a-zA-Z_0-9]" "_" :all t :quote t)
      )
      (verbose? "Warning: %r0 invalid! should be %r1"	oldname newname)
      (XPM-name xpm newname)
    )
    (XPM-name xpm (regsub xpm:re-name 1))
  )
  
  (xpm:must-match xpm:re-values xpm)	;values
  (XPM-width xpm (Int (regsub xpm:re-values 1)))
  (XPM-height xpm (Int (regsub xpm:re-values 2)))
  (XPM-ncolors xpm (Int (regsub xpm:re-values 3)))
  (XPM-cpp xpm (Int (regsub xpm:re-values 4)))
  (when (> (length (regsub xpm:re-values 6)) 0)
    (XPM-x_hotspot xpm (Int (regsub xpm:re-values 6)))
    (XPM-y_hotspot xpm (Int (regsub xpm:re-values 7)))
  )
  (if (> (length (regsub xpm:re-values 8)) 0) (progn
      (XPM-extensions? xpm t)
      (verbose? "Warning: %0 XPM Extensions not yet supported" (XPM-name xpm))
  ))
  
  (dotimes (i (XPM-ncolors xpm))	;colors
    (xpm:must-match xpm:re-colors xpm)
    (with (color-descs (regsub xpm:re-colors 3)
	name () type () 
	color (make-XPM:Color)
      )
      (put (XPM-colors xpm) i color)
      (XPM:Color-glyph color (subseq (regsub xpm:re-colors 1) 0 (XPM-cpp xpm)))
      (put glyph-table (XPM:Color-glyph color) i)
      (while (regexec xpm:re-color color-descs)
	(setq type (regsub xpm:re-color 1))
	(setq name (regsub xpm:re-color 2))
	(setq color-descs (regsub xpm:re-color 4)) ;rest
	(if (= type "c") (XPM:Color-color color name)
	  (= type "m") (XPM:Color-mono color name)
	  (= type "g") (XPM:Color-gray color name)
	  (= type "g4") (XPM:Color-gray4 color name)
	  (= type "s") (XPM:Color-symbolic color name)
	  (xpm:parse-error "bad color specification: %0, should be: c s m g g4"
	    type
  )))))
  
  (with (cpp (XPM-cpp xpm) width (XPM-width xpm) pixels (XPM-pixels xpm))
    (dotimes (y (XPM-height xpm))		;pixels
      (xpm:must-match xpm:re-pixel-row xpm)
      (with (row (vector) glyphs (regsub xpm:re-pixel-row 1))
	(put pixels y row)	;create row
	(dotimes (x (XPM-width xpm))
	  (put row x (getn glyph-table
	      (subseq glyphs (* cpp x) (* cpp (+ 1 x))
  )))))))
  
  (if (XPM-extensions? xpm) (progn	;extensions
      (XPM-extensions-lines xpm (subseq (XPM-lines xpm) (XPM-index xpm)))
  ))

  xpm
)

;; utils

(defun XPM-new ()
  (make-XPM :lines (vector) :colors (vector) :pixels (vector)
    :extensions (vector) :comments (vector) :index 0
))

  
(defun xpm:must-match (re xpm)
  ;;  (PV "xpm:must-match" (XPM-curline xpm) (XPM-index xpm)) 
  (xpm:skip-comments xpm)
  (if (regexec re (XPM-curline xpm))
    (incf (XPM-index xpm))
    ;; else
    (xpm:parse-error "parse error at line %0: %1,  should have been %r2" 
	(+ 1 (XPM-index xpm)) (XPM-curline xpm) re)
)))

(defun XPM-curline (xpm)
  (get (XPM-lines xpm) (XPM-index xpm) "*** EOF ***")
)

(defun xpm:skip-comments (xpm)
  ;;concatenate multi-line comments if needed
  (if (and (regexec xpm:re-open-comment  (XPM-curline xpm))
      (not (regexec xpm:re-comment (XPM-curline xpm)))
    )
    (with (line (XPM-curline xpm) 
	lines (XPM-lines xpm) 
	i (XPM-index xpm)
      )
      (delete lines i)
      (while (not (regexec xpm:re-close-comment (XPM-curline xpm)))
	(nconc line "\n" (XPM-curline xpm))
	(delete lines i)
      )
      (nconc line "\n" (XPM-curline xpm))
      (put lines i line)
  ))
  (while (regexec xpm:re-comment (XPM-curline xpm))
    ;; (PV "xpm:skip-comments" (XPM-curline xpm) (XPM-index xpm))
    (lappend (XPM-comments xpm) 
      (make-XPM:Comment :position (XPM-index xpm) :text (XPM-curline xpm))
    )
    (incf (XPM-index xpm))
))

(defun xpm:index-of-glyph (xpm glyph &aux
    (colors (XPM-colors xpm))
    (index 0)
  )
  (catch 'Found
    (dolist (color colors)
      (if (= (XPM:Color-glyph color) glyph)
	(throw 'Found index)
	(incf index)
    ))
    (xpm:parse-error "glyph not found in color table: %r0" glyph)
  )
)
  
(defmacro xpm:parse-error (text &rest args)
  `(error ,text ,@args)
)

;;=============================================================================
;;                    writing a file
;;=============================================================================

;;AUTOLOAD: xpm:write
;;AUTODOC: xpm:write "writes an XPM structure to a file"
;;(xpm:write filename xpm-structure)
;;
;;takes an XPM structure. see source "xpm-format.kl" and writes it to filename.

(defun xpm:write (filename xpm &aux
    (fd (open filename :direction :output :if-exists :supersede))
  )
  (print-format fd "/* XPM */\n")	;header
  (XPM-index xpm 1) (xpm:write-comments fd xpm)

  (print-format fd "static char *%0[] = {\n" (XPM-name xpm)) ;name
  (incf (XPM-index xpm)) (xpm:write-comments fd xpm)
    
  (print-format fd "\"%0 %1 %2 %3"	;value
    (XPM-width xpm) (XPM-height xpm) (XPM-ncolors xpm) (XPM-cpp xpm)
  )
  (if (XPM-x_hotspot xpm)
    (print-format fd " %0 %1" (XPM-x_hotspot xpm) (XPM-y_hotspot xpm))
  )
  (if (XPM-extensions? xpm) (print-format fd " XPMEXT"))
  (print-format fd "\",\n")
  (incf (XPM-index)) (xpm:write-comments fd xpm)
  
  (dotimes (i (XPM-ncolors xpm))	;colors
    (with (color (get (XPM-colors xpm) i)
	write-color (lambda (c field) 
	  (if (field color) (print-format fd " %0 %1" c (field color)))
      ))
      (print-format fd "\"%0 " (XPM:Color-glyph color))
      (write-color "c" XPM:Color-color)
      (write-color "m" XPM:Color-mono)
      (write-color "g" XPM:Color-gray)
      (write-color "g4" XPM:Color-gray4)
      (write-color "s" XPM:Color-symbolic)
      (print-format fd "\",\n")
      (incf (XPM-index xpm)) (xpm:write-comments fd xpm)
  ))

  (dotimes (y (XPM-height xpm))		;pixels
    (print-format fd "\"")
    (dotimes (x (XPM-width xpm))
      (write-string 
	(XPM:Color-glyph (getn (XPM-colors xpm) (x (y (XPM-pixels xpm)))))
	fd
      )
    )
    (if (= y (- (XPM-height xpm) 1))
      (print-format fd "\"%0\n" (if (XPM-extensions? xpm) "," "};"))
      (print-format fd "\",\n")
    )
    (incf (XPM-index xpm)) (xpm:write-comments fd xpm)
  )
  ;;flush remaining comments (since now there are no comments in the extensions)
  (dolist (c (XPM-comments xpm))
    (if (< (XPM-index xpm) (XPM:Comment-position c))
      (write-line (XPM:Comment-text c) fd)
  ))
					;extensions
  (dolist (l (XPM-extensions-lines xpm))
    (write-line l fd)
  )
)

(defun xpm:write-comments (fd xpm &aux
    (comments (XPM-comments xpm))
  )
  (dolist (c comments) 
      (if (= (XPM-index xpm) (XPM:Comment-position c))
	(progn
	  (write-line (XPM:Comment-text c) fd)
	  (incf (XPM-index xpm))
))))
