#!/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)

;;TODO: find and replace #xxx or rgb:r/g/b by symbolic colors in files
;; see man XQueryColor (and rgbi:)
;; should not treat CIE... but may issue a warning

(require 'getopts)

(setq args (getopts "USAGE: colors [options] [files...]
Performs many color-management specific tasks for the typical X user"
    ("-close" () do-close? "interactively reads colors on stdin and print 20
closest colors")
    ("-find" () do-find? "find colors in all files and outputs them one per line
with -v ouputs also the count each time a color is used, sorted by 
usage otherwise sorts in alphabetical order
typical usage:
    colors -find ~/.Xdefaults ~/gwm/.profile.gwm ~/app-defaults/* \\
    /usr/local/lib/X11/app-defaults/* /usr/lib/X11/app-defaults/*")
    ("-clean" () do-clean? "find all usages of RGB color specifications in files
and modifies them in place to replace it by color names
Warning: does no makes backups of files!")
    ("-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")
    ("-v" () verbose "verbose operation")
))

(require 'colors)
(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)
    )))
  )
  (if do-close? (do-close))
  (if do-find?  (do-find))
  (if do-clean? (do-clean))
)

(defun do-close ()
  (catch 'EOF
    (while t 
      (? "##### Color? ")
      (setq name (read-line))
      (if (match "^#?[0-9a-fA-F]+$" name)
	(setq rgb (rgb:rgb#2values name))
	(setq rgb (rgb:name2values name))
      )
      (if rgb (progn
      (setq result (apply rgb:closest-colors (+ rgb (list :table colormap))))
      (PF "Distance  Name                 [RGB] of: %0\n" rgb)
      (setq to-print 20)
      (setq re-excluded-names (regcomp
	  "^(.* .*|gray[0-9]?[1-9]|grey[0-9][0-9]?|grey|.*Grey[0-9]*)$"
      ))
      (catch 'Done
	(dolist (r result)
	  (if (not (regexec re-excluded-names #[r 0 2])) (progn
	      (PF " %5%0   %1 %6[%2 %3 %4]\n" 
		#[r 1] #[r 0 2] #[r 0 3] #[r 0 4] #[r 0 5]
		(make-string (- 6 (length (String #[r 1]))))
		(make-string (- 30 (length (String #[r 0 2]))))
	      )
	      (incf to-print -1)
	      (if (<= to-print 0) (throw 'Done))
	  ))))
	)
	(PF "***** Error! ***** Color %r0 not found!\n" name)
))))

(defun do-find (&aux
    (colors (Hashtable ()))		;ht of [colorname num]
    (re-colors (copy ""))
    re
  )
  ;;build the super-regexp!
  (dolist (color rgb:color-table)
    (nconc re-colors "|" (rgb:Color-name color))
  )
  (setq re-colors (regcomp (+ "(^|[^a-zA_Z_0-9])(" (subseq re-colors 1)
	")($|[^a-zA_Z_0-9])"
  )))

  (dolist (file args)
    (verbose? "%0" file)
    (setq buffer (String (open file)))
    (if (seek buffer 0) (quote-nulls-in-buffer buffer))
    (setq offset 0)
    (while (regexec re-colors buffer offset)
      (setq colorname (regsub re-colors 2))
      (setq offset #[re-colors 2 1])
      (put colors colorname (+ 1 (get colors colorname 0)))
  ))
  
  (verbose? "sorting results ...(%0 colors)" (length colors))
  (setq redcols (Hashtable ()))
  (dohash (name count colors)
    (setq rgb (rgb:name2values name))
    (put redcols rgb (+ (get redcols rgb 0) count))
  )
  (verbose? "%0 unique colors" (length redcols))
  (setq colors-list (list))
  (dohash (rgb count redcols)
    (lappend colors-list 
      (vector (rgb:Color-name 
	  (apply rgb:closest-color (+ rgb (list :table colormap))))
	count))
  )
  (sort colors-list (lambda (c1 c2) (compare #[c1 1] #[c2 1])))
  (if verbose
    (dolist (c colors-list)
      (PF "  %0 %2 %1\n" #[c 0] #[c 1] (make-string (- 30 (length #[c 0]))))
    )
    (with (l (list))
      (dolist (c colors-list) (lappend l #[c 0]))
      (sort l compare-nocase)
      (dolist (c l) (PF "%0\n" c))
    )
  )   
) 

(defun do-clean (&aux
    buffer
    (get-name (lambda (re) 
	(if verbose
	  (verbose? "    %0 ==> %1" (regsub re 2) 
	    (subseq (apply rgb:closest-color 
		(+ (rgb:rgb2values (regsub re 2)) (list :table colormap))) 2)
	))
	(getn (apply rgb:closest-color 
	    (+ (rgb:rgb2values (regsub re 2)) (list :table colormap))
	  ) 2
	)
    ))
    (re# (regcomp rgb:rgb-re#))
    (re-rgb (regcomp rgb:rgb-re-rgb))
    (re-rgbi (regcomp rgb:rgb-re-rgbi))
  )
  (dolist (file args)
    (verbose? "file: %0" file)
    (catch 'ERROR
      (setq buffer (String (open file)))
      (replace-string buffer re# get-name :all t :npar 2)
      (replace-string buffer re-rgb get-name :all t :npar 2)
      (replace-string buffer re-rgbi get-name :all t :npar 2)
      (if (not (setq fd 
	    (open file :direction :output :if-exists :supersede :error ()))
	) (progn
	  (sh chmod u+w ,file)
	  (if (not (setq fd 
		(open file :direction :output :if-exists :supersede :error ()))
	    )
	    (PF *standard-error* "ERROR: cannot write back file %0!\n" file)
      )))
      (if fd (progn
	  (write-string buffer fd)
	  (close fd)
)))))

(defun quote-nulls-in-buffer (buffer &aux (offset 0))
  (while (setq offset (seek buffer 0 offset))
    (put buffer offset 1)
    (incf offset)
))

(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: ***

