;;AUTOLOAD: rgb:parse-rgb_txt
;;AUTODOC: rgb:parse-rgb_txt "parse X colormap"
;;(rgb:parse-rgb_txt)
;;
;;Parses the standard X colormap in /usr/lib/X11/rgb.txt and builds a vector of
;;colors, each color being a structure rgb:Color defined by:
;;    (defstruct rgb:Color name red green blue)
;;sets the colormap to rgb:color-table and returns it.
;;options:
;;    :file filename    parses filename (defaults to /usr/lib/X11/rgb.txt)

;;AUTOLOAD: rgb:color-table
;;AUTOLOAD: rgb:Color

(defstruct rgb:Color name red green blue)

(defun rgb:parse-rgb_txt (&key file &aux
    (fd (open (if file file "/usr/lib/X11/rgb.txt")))
    (re (regcomp 
	"^[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+([^ \t].*[^ \t])[ \t]*$"
    ))
    (table (vector))
  )
  (catch 'EOF
    (while t
      (if (regexec re (read-line fd))
	(lappend table (make-rgb:Color
	    :name (regsub re 4)
	    :red (Int (regsub re 1))
	    :green (Int (regsub re 2))
	    :blue (Int (regsub re 3))
  )))))
  (setq rgb:color-table table)
)

;;AUTOLOAD: rgb:closest-color
;;AUTODOC: rgb:closest-color "return closest color in X colormap"
;;(rgb:closest-color red green blue [:table colormap])
;;
;;Takes a RGB value (three ints from 0 to 255) and returns the closest color in
;;colormap (defaults to rgb:color-table). color is returned as a rgb:Color
;;structure

(defun rgb:closest-color (red green blue &key table &aux
    (dist *maxint*)
    newdist
    closest-color
  )
  (if (not table) (setq table rgb:color-table))
  (dolist (color table)
    (if (<= (setq newdist (+ 
	    (** (- red (rgb:Color-red color)) 2)
	    (** (- green (rgb:Color-green color)) 2)
	    (** (- blue (rgb:Color-blue color)) 2)
	))
	dist
      ) 
      (if (or (/= newdist dist)		;of two equal dist, use shorter name
	  (< (length (rgb:Color-name color)) 
	    (length (rgb:Color-name closest-color))
	))
	(setqn dist newdist closest-color color)
  )))
  closest-color
)

;;AUTOLOAD: rgb:closest-colors
;;AUTODOC: rgb:closest-colors "return ordered list of colors in X colormap"
;;(rgb:closest-colors red green blue [:table colormap] [:reverse t])
;;
;;Takes a RGB value (three ints from 0 to 255) and returns the list of colors in
;;colormap (defaults to rgb:color-table) ordered by distance from the color
;;closes first, or closest last if :reverse t is given

(defun rgb:closest-colors (red green blue &key table reverse &aux
    (result (vector))
  )
  (if (not table) (setq table rgb:color-table))
  (dolist (color table)
    (lappend result (vector color (+ 
	  (** (- red (rgb:Color-red color)) 2)
	  (** (- green (rgb:Color-green color)) 2)
	  (** (- blue (rgb:Color-blue color)) 2)
  ))))
  (list! result)
  (sort result (if reverse
      (lambda (v2 v1) (compare (1 v1) (1 v2)))
      (lambda (v1 v2) (compare (1 v1) (1 v2)))
  ))
  (vector! result)
)

;; takes an old #rrggbb form (# optional) and returns a triplet)

(defun rgb:rgb#2values (text &aux
    (offset (mod (length text) 3))
    (len (/ (length text) 3))
  )
  (if (> len 1)
    (vector 
      (xtoi (subseq text offset (+ offset 2)))
      (xtoi (subseq text (+ offset len) (+ offset len 2)))
      (xtoi (subseq text (+ offset len len) (+ offset len len 2)))
    )
    (vector
      (xtoi (+ (subseq text 0 1) "0"))
      (xtoi (+ (subseq text 1 2) "0"))
      (xtoi (+ (subseq text 2 3) "0"))
    )
))

;; general function: takes an X rgb specification in the forms:
;; #rrggbb (1/2/3/4 chars per colors)
;; rgb:red/green/blue    values in hex (1/2/3/4 chars per colors)
;; rgbi:red/green/blu    values in reals, 0 <= x <= 1.0

(with (h "[0-9a-fA-F]"			;hex char
    H (+ h "|" h h "|" h h h "|" h h h h) ;hex number
    h3 (+ h h h)
    R "[+-]?[0-9]+[.]?[0-9]*([eE][+-]?[0-9]+)?"
  )
  (setq rgb:rgb-re (regcomp (+ 
	"^(" h3 "|" h3 h3 "|" h3 h3 h3 "|" h3 h3 h3 h3 ")$"
  )))
  (setq rgb:rgb-re# (regcomp (+ 
	"(^|[^a-zA-Z0-9#])(#" "(" h3 "|" h3 h3 "|" h3 h3 h3 "|" h3 h3 h3 h3 "))"
	"($|[^a-zA-Z0-9])"
  )))
  (setq rgb:rgb-re-rgb (regcomp (+ 
	"(^|[^a-zA-Z0-9])(rgb:(" H ")[/](" H ")[/](" H "))($|[^a-zA-Z0-9])"
  )))
  (setq rgb:rgb-re-rgbi (regcomp (+ 
	"(^|[^a-zA-Z0-9])(rgbi:(" R ")[/](" R ")[/](" R "))($|[^a-zA-Z0-9])"
  )))
)
(defun rgb:rgb2values (text &aux
  )
  (if 
    (regexec rgb:rgb-re text)
    (rgb:rgb#2values (regsub rgb:rgb-re 1))

    (regexec rgb:rgb-re# text) 
    (rgb:rgb#2values (regsub rgb:rgb-re# 2))
    
    (regexec rgb:rgb-re-rgb text)
    (with (s () 
	mval {lambda (s) (xtoi (subseq "ffff" 0 (length s)))}
      )
      (vector 
	(with (s (regsub rgb:rgb-re-rgb 3)) (/ (* 255 (xtoi s)) (mval s)))
	(with (s (regsub rgb:rgb-re-rgb 4)) (/ (* 255 (xtoi s)) (mval s)))
	(with (s (regsub rgb:rgb-re-rgb 5)) (/ (* 255 (xtoi s)) (mval s)))
      )
    )

    (regexec rgb:rgb-re-rgbi text)
    (vector 
      (Int (* 255 (Real (regsub rgb:rgb-re-rgbi 3))))
      (Int (* 255 (Real (regsub rgb:rgb-re-rgbi 5))))
      (Int (* 255 (Real (regsub rgb:rgb-re-rgbi 7))))
    )
))

(defun rgb:name2values (text &aux
  )
  (catch 'Found
    (dolist (color rgb:color-table)
      (if (= (rgb:Color-name color) text)
	(throw 'Found (vector (rgb:Color-red color) (rgb:Color-green color)
	    (rgb:Color-blue color)
    ))))
    ()
  )
)

(defun rgb:name2values-nocase (text &aux
  )
  (catch 'Found
    (dolist (color rgb:color-table)
      (if (= 0 (compare-nocase (rgb:Color-name color) text))
	(throw 'Found (vector (rgb:Color-red color) (rgb:Color-green color)
	    (rgb:Color-blue color)
    ))))
    ()
  )
)


(defun rgb:dist (c1 c2)
  (+ 
    (** (- (rgb:Color-red c1) (rgb:Color-red c2)) 2)
    (** (- (rgb:Color-green c1) (rgb:Color-green c2)) 2)
    (** (- (rgb:Color-blue c1) (rgb:Color-blue c2)) 2)
))
