#!/bin/sh
: ; exec klone $0 "$@"
; The above line finds the klone executable in the $PATH
;;Skeleton of a typical klone script
;;(stack-dump-on-error t)
(kdb t)

(setq args (getopts "USAGE: xpm-clean files...
cleans the colormap of the xpm files: modifies in place files (no backup is 
done), by forcing colors to be the closest ones in a colormap (defaults rgb.txt)
respecting symbolic, mono and greyscale informations"
    ("-c" file colormap-file "use colormap in file. colormap is a file with 
color names, one per line. the file name \"anthony\" is special: 
it uses a built-in version of the recommended 30-colors colormap 
used in Anthony Thyssen X Icons library")
    ("-n" () numeric? "save colors under the form #rrggbb, to be able to use
the pixmap in localized environments where the colormap wont 
understand the english color names. these colors are still those 
found in rgb.txt (or the colormap given by -c), though")
    ("-v" () verbose "verbose operation")
))

(require 'colors)
(require 'xpm-format)
(rgb:parse-rgb_txt)

(defun main (&aux
  )
  (if					;set colormap
    (= colormap-file "anthony")
    (set-colormap "anthony")

    colormap-file
    (load-colormap colormap-file)

    (progn
      (setq colormap (vector))
      (dolist (color rgb:color-table)
	(if (not (regexec {regcomp
	      "^(.* .*|gray[0-9]?[1-9]|grey[0-9][0-9]?|grey|.*Grey[0-9]*)$"
	      } (rgb:Color-name color))
	  )
	  (lappend colormap color)
    )))
  )
  (dolist (file args)
    (clean-xpm-file file)
  )
)

(defun clean-xpm-file (file)
  (verbose? "file: %0" file)
  (setq xpm (xpm:read file :verbose verbose))
  (setq orig-ncolors (XPM-ncolors xpm))
  
  ;;round colors to colormap
  (dotimes (i (XPM-ncolors xpm))
    (with (color #[(XPM-colors xpm) i])
      (if (is-color? (XPM:Color-color color))
	(progn
	  (if (= (get (XPM:Color-color color) 0) #\#) 
	    (setq rgb (rgb:rgb#2values (XPM:Color-color color)))
	    (if (not (setq rgb (rgb:name2values (XPM:Color-color color))))
	      (setq rgb (rgb:name2values-nocase (XPM:Color-color color))))
	  )
	  (if rgb (progn
	      (setq color (apply rgb:closest-color (+ rgb (list :table colormap))))
	      (XPM:Color-color  #[(XPM-colors xpm) i]  (rgb:Color-name color))
	    )
	    (error "file: %1 Color not found! %0" (XPM:Color-color color) file)
	  )
	)
  )))
  ;;now collapse same colors together
  (setq recolor-list (vector)) ; build list in reverse
  (dotimes (i (XPM-ncolors xpm))
    (with (color (XPM:Color-color  #[(XPM-colors xpm) i]))
      (if (is-color? color)
	(catch 'Done
	  (dotimes (j i)			;look a preceding colors
	    (with (prevcol (XPM:Color-color  #[(XPM-colors xpm) j]))
	      (if (= color prevcol)
		(if (same-XPM:Color #[(XPM-colors xpm) j] #[(XPM-colors xpm) i]) (progn
		    (insert recolor-list 0 (vector i j))
		    (throw 'Done)
		  )
		  (verbose? "Warning: keeping the following two entries separate for the same color %0:
    %r1\n    %r2" color (print-XPM:Color #[(XPM-colors xpm) i])
		    (print-XPM:Color #[(XPM-colors xpm) j])
  )))))))))
  (dolist (l recolor-list)
    (dolist (row (XPM-pixels xpm))
      (dotimes (x (XPM-width xpm))
	(if 
	  (= #[row x] #[l 0])
	  (put row x #[l 1])
	  
	  (> #[row x] #[l 0])
	  (put row x (- #[row x] 1))
    )))
    (delete (XPM-colors xpm) #[l 0])
    (XPM-ncolors xpm (- (XPM-ncolors xpm) 1))
  )
  
  (if (/= orig-ncolors (XPM-ncolors xpm))
    (verbose? "colors reduced from %0 to %1 (reduced by %2)"
      orig-ncolors (XPM-ncolors xpm) (- orig-ncolors (XPM-ncolors xpm))
  ))

  (if numeric? (numerize-xpm-color xpm))

  ;;write back file
  (xpm:write file xpm)
)

(defun is-color? (color)
  (and color (not (regexec {regcomp "^[nN][oO][nN][eE]$"} color)))
)

(defun print-XPM:Color (c &aux res)
  (setq res (copy (XPM:Color-glyph c)))
  (if (XPM:Color-mono c) (nconc res "  m " (XPM:Color-mono c)))
  (if (XPM:Color-gray c) (nconc res "  g " (XPM:Color-gray c)))
  (if (XPM:Color-gray4 c) (nconc res "  g4 " (XPM:Color-gray4 c)))
  (if (XPM:Color-color c) (nconc res "  c " (XPM:Color-color c)))
  (if (XPM:Color-symbolic c) (nconc res "  s " (XPM:Color-symbolic c)))
  res
)

(defun same-XPM:Color (c c2 &aux res)
  (and 
    (= (XPM:Color-mono c) (XPM:Color-mono c2))
    (= (XPM:Color-gray c) (XPM:Color-gray c2))
    (= (XPM:Color-gray4 c) (XPM:Color-gray4 c2))
    (= (XPM:Color-symbolic c) (XPM:Color-symbolic c2))
))

(defun numerize-xpm-color (xpm &aux
  )
  (dotimes (i (XPM-ncolors xpm))
    (with (color (XPM:Color-color  #[(XPM-colors xpm) i]))
      (if (and (is-color? color)
	  (/= #\# (get color 0))
	)				;color name, not None, not #rrggbb
	(XPM:Color-color  #[(XPM-colors xpm) i]
	  (apply sharp-notation (rgb:name2values color))
))))))

(defun sharp-notation (red green blue &aux
    (tab ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "a" "b" "c" "d" "e" "f"])
    (itox2 {lambda (n) (+
	  (if (< n 16) "0" (get tab (/ n 16) "0"))
	  (get tab (mod n 16) "0")
    )})
  )
  (+ "#" (itox2 red) (itox2 green) (itox2 blue))
)

(defun load-colormap (file &aux
    (fd (open file))
    name
    rgb
  )
  (setq colormap (vector))
  (catch 'EOF (while t 
      (setq name (match {regcomp "^[ \t]*(.*)[ \t]*$"} (read-line fd) 1))
      (setq rgb (rgb:name2values name))
      (lappend colormap (make-rgb:Color
	  :name name
	  :red #[rgb 0]
	  :green #[rgb 1]
	  :blue #[rgb 2]
)))))

;;use a built-in colormap
(defun set-colormap (name &aux
    (parse-color (lambda (name &aux (rgb (rgb:name2values name)))
	(lappend colormap (make-rgb:Color :name name :red #[rgb 0]
	  :green #[rgb 1] :blue #[rgb 2]
    ))))
  )
  (setq colormap (vector))
  (if (= name "anthony")		;Anthony Thyssen X Icons library
    (map () parse-color '(
	"black" "DarkSlateGrey" "SlateGrey" "grey" "gainsboro" "white" "purple" 
	"magenta" "violet" "firebrick" "red" "tomato" "orange" "gold" "yellow" 
	"sienna" "peru" "tan" "wheat" "LemonChiffon" "SeaGreen" "LimeGreen" 
	"green" "PaleGreen" "navy" "blue" "DodgerBlue" "SkyBlue" "lavender" 
	"cyan"
  )))
)

(main)

;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***

