;;; ll-icac --- luki icac -*- lexical-binding: t -*-
;;
;;; Commentary:
;;
;;; Code:

(require 'cl-lib)
(cl-pushnew "." load-path :test #'string=)
(require 'll)

(-> 'll-face)

(defun ll-part-to-string (part)
  (if (z part)                "0.00"
    (if (< (- 1.0 part) 0.01) "1.00"
      (@f "%.2f" part))))

(cl-defstruct ll-vector-color
  (red   0.0 :type float)
  (green 0.0 :type float)
  (blue  0.0 :type float)
  (from  ""  :type string))

(cl-defmethod ll-vector-color-vector ((c ll-vector-color))
  (vector
   (ll-vector-color-red   c)
   (ll-vector-color-green c)
   (ll-vector-color-blue  c)))

(cl-defmethod ll-vector-color-normalize ((c ll-vector-color))
  (let ((decimal (seq--into-vector (mapcar (L (e) (color-clamp (// e (1- (** 2 16))))) (ll-vector-color-vector c)))))
    (setf (ll-vector-color-red   c) (aref decimal 0))
    (setf (ll-vector-color-green c) (aref decimal 1))
    (setf (ll-vector-color-blue  c) (aref decimal 2))))

(defun ll-colors-from-faces ()
  (cl-loop
   with faces      = (face-list)
   with faces-fg   = (cl-remove-if-not #'face-foreground faces)
   with faces-bg   = (cl-remove-if-not #'face-background faces)
   with colors-fg  = (mapcar #'face-foreground faces-fg)
   with colors-bg  = (mapcar #'face-background faces-bg)
   with colors     = (seq-union colors-fg colors-bg)
   with colors-str = (cl-remove-if-not #'stringp colors)
   for c-str in colors-str
   for (r g b) = (color-values c-str)
   for col     = (make-ll-vector-color :red r :green g :blue b :from c-str)
   collect (ll-vector-color-normalize col)))

(defun ll-icac ()
  (cl-loop
   with faces-fg = (sort (cl-remove-if-not #'face-foreground (face-list)))
   initially (new-buf "*ll-draw*")
   for f in faces-fg
   for i from 0
   for face-fg       = (ll-col-norm (face-fg f))
   for c             = (color-values face-fg)
   for rgb           = (mapcar (L (e) (min 255 (max 0 (1- (// e 255))))) c)
   for rgbs          = (mapcar (L (d) (@f "%\ 3.0f" d)) rgb )
   for (rs gs bs)    = rgbs
   for rgbf          = (mapcar (L (e) (max 0.0 (// (- e 1) 255))) rgb )
   for (rf gf bf)    = rgbf
   for rgbfs         = (mapcar (L (d) (ll-part-to-string d)) rgbf)
   for (rfs gfs bfs) = rgbfs
   for ll-sum        = (ll-col-sum face-fg)
   for sum           = (@f " %3d%% " (max 0.0 (r (* 100.0 ll-sum ))))
   for red           = (@f " %3d "   (max 0.0 (r (* 100.0 rf     ))))
   for grn           = (@f " %3d "   (max 0.0 (r (* 100.0 gf     ))))
   for blu           = (@f " %3d "   (max 0.0 (r (* 100.0 bf     ))))
   for fg            = (pad (propertize (@f " %s " face-fg) 'face (list :foreground (if (< ll-sum 0.1) (face-fg 'default) face-fg) :box (list :color (if (< ll-sum 0.1) 'default (ll-col* 1.16 face-fg)) :line-width '(-3 . -1)))) 10)
   for norm-red      = (ll-col-norm (vector     rf      (//    gf 4.5) (// bf 2.5) ))
   for norm-grn      = (ll-col-norm (vector (// rf 5.5) (- 1.0 gf)     (// bf 6.5) ))
   for norm-blu      = (ll-col-norm (vector (// rf 3.5) (//    gf 4.5)     bf      ))
   for sum-clr       = (ll-col-norm (if (< ll-sum 0.1) (face-fg 'default) (if (ll-colorp face-fg) face-fg c)))
   for bar-sum       = (propertize sum 'face `(:foreground "grey36" :background ,face-fg))
   for bar-red       = (propertize red 'face `(:foreground ,sum-clr :background ,norm-red))
   for bar-grn       = (propertize grn 'face `(:foreground ,sum-clr :background ,norm-grn))
   for bar-blu       = (propertize blu 'face `(:foreground ,sum-clr :background ,norm-blu))
   for nms           = (pad (propertize (symbol-name f) 'face (list :foreground (if (< ll-sum 0.1) 'default face-fg))) 36)
   for str           = (@f "%s%s%s %s%s%s %s %s\n" nms fg bar-sum bar-red bar-grn bar-blu
                           (propertize (@f " %s %s %s " rs  gs  bs ) 'face (list :foreground "gray69" :background "gray35" :inverse-video (evenp i)))
                           (propertize (@f " %s %s %s " rfs gfs bfs) 'face (list :foreground "gray53" :background "gray27" :box           (list :line-width `(-5 . ,(if (or (zerop i) (oddp i)) 0 0)) :color "#22aaee"))))
   do      (@i (or str i))
   finally (& (goto-beg)
              (re-search-forward "^font-lock-" (point-max) t)
              (goto-char (match-beginning 0))
              (recenter 0))))

;; (progn (eval-buffer) (ll-icac))

(<- 'll-icac)
;;; ll-icac.el ends here