;;; font-lock-color-test.el --- Tool to test new font lock colors.
;;
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Created: 2009-07-31 Fri
;; Last-Updated: 2009-07-31 Fri
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Just for testing new font lock colors. Run the command
;; `test-font-lock-colors'.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defconst test-font-lock-suggestions
  '(("chong1" ((font-lock-builtin-face "MediumOrchid4")
               (font-lock-constant-face "dark cyan")
               (font-lock-string-face  "VioletRed4")
               (font-lock-variable-name-face "OrangeRed4")))))

(defun test-font-lock-colors (suggestion)
  (interactive (list
                (completing-read "Try suggestion: "
                                 test-font-lock-suggestions
                                 nil ;; pred
                                 t   ;; require match
                                 )))
  (if (string= "" suggestion)
      (message (propertize "You did not choose any suggestion" 'face 'secondary-selection)*gensym-counter*)
    (let ((flf
           '(;; Order these so that faces that are hard to distinguish
             ;; are shown close to each other.
             font-lock-builtin-face
             font-lock-keyword-face
             font-lock-preprocessor-face

             font-lock-comment-delimiter-face
             font-lock-comment-face
             font-lock-warning-face

             font-lock-constant-face
             font-lock-type-face

             font-lock-doc-face
             font-lock-string-face
             font-lock-variable-name-face

             font-lock-function-name-face
             font-lock-negation-char-face
             font-lock-regexp-grouping-backslash
             font-lock-regexp-grouping-construct
             ))
          (buf (generate-new-buffer "Font lock face test"))
          (try-these (cadr (assoc suggestion test-font-lock-suggestions)))
          (background-color "white") ;; fix-me
          )
      (with-current-buffer buf
        (setq show-trailing-whitespace nil)
        (insert "
Faces contrast ration towards current background color. A contrast ratio higher than 4.5:1 is ok.
See for example http://www.snook.ca/technical/colour_contrast/colour.html

")
        (dolist (f flf)
          (insert
           (format "%-36s" f)
           (propertize "abcdef" 'face f)
           (let* ((try-this (assoc f try-these))
                  (new-face (cadr try-this)))
             (concat
              (if new-face
                  (concat " " (propertize "abcdef" 'face `(:foreground ,new-face)))
                "       ")
              "  "
              (display-color-contrast-ratio background-color (face-foreground f))
              "  "
              (if new-face
                  (display-color-contrast-ratio background-color new-face)
                "     "))
             )
           "\n")))
      (display-buffer buf)
      )))

;;(face-foreground 'font-lock-function-name-face)
;;(face-foreground 'font-lock-preprocessor-face)
;;(face-foreground 'font-lock-doc-face)

(defun face-foreground (face)
  (let ((color (face-attribute face :foreground))
        (inherit (face-attribute face :inherit)))
    (while (and (eq color 'unspecified)
                (not (eq inherit 'unspecified)))
      (setq face inherit)
      (setq color (face-attribute face :foreground))
      (setq inherit (face-attribute face :inherit)))
    ;; Fix-me:
    (if (eq color 'unspecified) "black" color)))

(defun relative-luminance (color-str)
  "Relative luminance of color COLOR-STR.
The relative brightness of any point in a colorspace, normalized
to 0 for darkest black and 1 for lightest white.

Note 1: For the sRGB colorspace, the relative luminance of a
color is defined as L = 0.2126 * R + 0.7152 * G + 0.0722 * B
where R, G and B are defined as:

  if RsRGB <= 0.03928 then R = RsRGB/12.92 else R = ((RsRGB+0.055)/1.055) ^ 2.4
  if GsRGB <= 0.03928 then G = GsRGB/12.92 else G = ((GsRGB+0.055)/1.055) ^ 2.4
  if BsRGB <= 0.03928 then B = BsRGB/12.92 else B = ((BsRGB+0.055)/1.055) ^ 2.4

and RsRGB, GsRGB, and BsRGB are defined as:

  RsRGB = R8bit/255
  GsRGB = G8bit/255
  BsRGB = B8bit/255

See URL `http://www.w3.org/TR/2008/REC-WCAG20-20081211/#relativeluminancedef'."
  (let* ((rgb (mapcar (lambda (val)
                        (let ((v255 (/ val 255)))
                          (if (<= v255 0.03928)
                              (/ v255 12.92)
                            (expt (/ (+ v255 0.055)
                                     1.055)
                                  2.4))))
                      (color-values color-str)))
         (r (nth 0 rgb))
         (g (nth 1 rgb))
         (b (nth 2 rgb)))
    (+ (* 0.2126 r)
       (* 0.7152 g)
       (* 0.0722 b))))

(defun luminance-contrast-ratio (l1 l2)
  "Contrast ratio between relative luminances L1 and L2.
Defined as

  (L1 + 0.05) / (L2 + 0.05)

where

  L1 is the relative luminance of the lighter of the colors, and
  L2 is the relative luminance of the darker of the colors.

See URL `http://www.w3.org/TR/2008/REC-WCAG20-20081211/#contrast-ratiodef'."
  (let* ((l-dark (if (> l1 l2) l2 l1))
         (l-bright (if (> l1 l2) l1 l2))
         (ratio (/ (+ l-bright 0.05)
                   (+ l-dark   0.05))))
    ;; Fix-me: There is something wrong in the formulas, ratio max is
    ;; 21...?
    (if (> ratio 21.0) 21.0 ratio)))

(defun color-contrast-ratio (color1 color2)
  (let ((lum1 (relative-luminance color1))
        (lum2 (relative-luminance color2)))
    (luminance-contrast-ratio lum1 lum2)))

(defun display-color-contrast-ratio (color1 color2)
  (let* ((ratio (color-contrast-ratio color1 color2))
        (str (format "%.1f" ratio)))
    (if (< ratio 4.5)
        (propertize str 'face 'font-lock-warning-face)
      str)))

;; (color-contrast-ratio "white" "DarkGoldenrod")
;; (color-contrast-ratio "white" "black")
;; (color-contrast-ratio "white" "#050505")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; font-lock-color-test.el ends here