;;; ll-face --- ll face -*- lexical-binding: t -*-
;;
;;; Commentary:
;;
;;; Code:

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

(require 'juv       nil t)
(require 'll        nil t)
(require 'll-list   nil t)
(require 'll-window nil t)

(defalias 'face-bg #'face-background)
(defalias 'face-fg #'face-foreground)
(defalias 'gfx     #'display-graphic-p)
(defalias 'set-bg  #'set-background-color)
(defalias 'set-fg  #'set-foreground-color)
(defalias 'sfa     #'set-face-attribute)

(defun face-all-words (&optional top-n)
  (or top-n (setf top-n 10))
  (cl-loop
   with res
   with fl = (face-list)
   with f2 = (mapcar #'symbol-name fl)
   with f3 = (flatten-list (mapcar (L (s) (split-string s "-")) f2))
   with f4 = (sort f3 :lessp #'string<)
   for l   = (--- f4)
   for w   = (1st f4)
   while f4 do (setf f4 (seq-remove (L (s) (s= w s)) f4))
   (cl-pushnew (cons (- l (--- f4)) w) res)
   finally return (take top-n (sort res :key #'car :lessp #'>))))

;; the most common words in Emacs faces:
;; 1. gnus  (76) #1 gold
;; 2. face  (47) #2 silver
;; 3. line  (41) #3 bronze
;; 4. tab   (38)
;; 5. w3m   (31)
;; 6. lock  (29)
;; 7. group (29)
;; 8. font  (29)

(defun ll-fullscreen (&optional quiet) (i)
  (when (gfx)
    (setq frame-resize-pixelwise t)
    (fringe-mode         0)
    (set-frame-size      nil 1920 1080 t)
    (set-frame-position  nil 0 0)
    (set-frame-parameter nil 'fullscreen 'fullboth))
  (unless quiet
      (let* ((w  (frame-pixel-width))
             (h  (frame-pixel-height))
             (px (* w h)))
        ($ " [ w %d ] [ h %d ] [ pixels %d ] " w h px ))))

;; _____________________
;;  0  1   2   3   4   5
;; 00 5f  87  af  d7  ff
;;  0 95 135 175 215 255
;; ---------------------

(defun monospace-fonts ()
  (seq-filter
   (L (f)
      (when-let* ((info (font-info f)))
        (string-match-p "spacing=100" (aref info 1))))
   (font-family-list)))

;; (monospace-fonts))
;; (font-info "Intel One Mono")

(let ((fonts (cl-delete-duplicates (monospace-fonts)))
      (i 0))
  (defun next-monospace (&optional n) (i)
    (when fonts
      (or n (setf n 1))
      (when-let* ((fnt (nth (m (++ i n) (--- fonts)) fonts)))
        (set-all-faces nil fnt)
        (ll-fullscreen)
        ($ "font: %s" fnt))))
  (defun prev-monospace (&optional n) (i) (next-monospace (if n (- n) -1)))
  (declare-function next-monospace nil)
  (declare-function prev-monospace nil)
  (keymap-global-set "M--" #'prev-monospace)
  (keymap-global-set "M-=" #'next-monospace))

;; ---------------------------------------------------------------------------yx
;; the ys are at col 79
;; ---------------------------------------------------------------------------yx

(defun set-all-faces (&optional a fnt) (i)
  (or fnt (setf fnt "OCRB"))
  (& (gfx)
     (cl-loop
      with old    = (face-attribute 'default :height)
      with font   = fnt
      with weight = 'bold
      with w      = 'regular
      with stp    = 4
      with h-def  = 177
      with hf     =
      (cond
       ((ni a) (cond                                 ; INTEGER:
                ((< a (- stp))    (- old (abs a)))   ; reduce x on -x
                ((< a 0)          (- old stp))       ; reduce stp
                ((= a 0)             old)            ; (see ZERO below)
                ((< 0 a (1+ stp)) (+ stp old))       ; increase stp
                (a)))                                ; set to a
       ((nf a) (floor a))                            ; FLOAT: crash on e.g. 107.5
       ((functionp a) (funcall a old)))              ; FUNCTION: set to a(old)
      with h  = (or (& (ni hf) (< stp hf) hf) h-def) ; SAFE: reduce then start over
      with fs = (face-list)                          ; ZERO: unspecify fg and bg
      initially (setf a (& (lu current-prefix-arg) (1st current-prefix-arg)))
      for f in fs do
      (& (su font) (set-face-attribute f nil :font font))
      (& (z a)     (set-face-attribute f nil :foreground (juv-col* "white") :background (juv-col* "black")))
      (set-face-attribute f nil :height h :width w :weight weight :underline nil)
      finally (prog1 h ($ " %s (%d%%)" (window-char-resolution nil t t) h)))))

(keymap-global-set "C-0"        #'set-all-faces)
(keymap-global-set "C-M-0" (L () (set-all-faces   200 "Kode Mono" )))
(keymap-global-set "C-M-9" (L () (set-all-faces   140 "Kode Mono" )))
(keymap-global-set "C-)"   (L () (set-all-faces   100             )))
(keymap-global-set "C--"   (L () (set-all-faces    -1             )))
(keymap-global-set "C-="   (L () (set-all-faces     1             )))

(& (gfx) (setq line-spacing 4))

;; ----------------------------------------------------------------------------x
;; test area 51                                                       col 80 ->x
;; ----------------------------------------------------------------------------x
;; (set-all-faces)     ; set to the default value, 100
;; (set-all-faces nil) ; ..
;; (set-all-faces t)   ; ..
;; (let ((current-prefix-arg '(120))) (call-interactively #'set-all-faces)) ; set to 120
;; (let ((current-prefix-arg '(110))) (call-interactively #'set-all-faces)) ; ..  .. 110
;; (let ((current-prefix-arg '(-10))) (call-interactively #'set-all-faces)) ; reduce  10
;; (set-all-faces -50)  ; reduce 50
;; (set-all-faces  -5)  ; ..      5
;; (set-all-faces  -3)  ; ..      3
;; (set-all-faces  -2)  ; as -2 is too small, treat it as -3
;; (set-all-faces  -1)  ; ..
;; (set-all-faces   0)  ; still set it to the old value
;; (set-all-faces   1)  ; as +1 is too small, treat it as 3
;; (set-all-faces   2)  ; ..
;; (set-all-faces   3)  ; increase 3
;; (set-all-faces 105)  ; set to 105
;; (set-all-faces 107)  ; ..  .. 107, noticeable from 108 to 107, but not from 105
;; (set-all-faces 108)  ; ..  .. 108
;; (set-all-faces #'1-) ; nothing happens as +/- 1 is too small
;; (set-all-faces #'1+) ; ..
;; (set-all-faces (L (e) (++ e  8))) ; +8
;; (set-all-faces (L (e) (-- e 16))) ; -16

(defun what-face (pos)
  (interactive "d")
  (or (when-let* ((face (or (get-char-property pos 'face)
                        (get-char-property pos 'read-cf-name)))
                  (face-str (@f "%s" face)))
        (kill-new face-str)
        ($ face-str))
      ($ "no face")))

(font-lock-add-keywords 'emacs-lisp-mode
 '(
   ("font-lock-bracket-face"              . 'font-lock-bracket-face)
   ("font-lock-builtin-face"              . 'font-lock-builtin-face)
   ("font-lock-comment-delimiter-face"    . 'font-lock-comment-delimiter-face)
   ("font-lock-comment-face"              . 'font-lock-comment-face)
   ("font-lock-constant-face"             . 'font-lock-constant-face)
   ("font-lock-delimiter-face"            . 'font-lock-delimiter-face)
   ("font-lock-doc-face"                  . 'font-lock-doc-face)
   ("font-lock-doc-markup-face"           . 'font-lock-doc-markup-face)
   ("font-lock-escape-face"               . 'font-lock-escape-face)
   ("font-lock-function-call-face"        . 'font-lock-function-call-face)
   ("font-lock-function-name-face"        . 'font-lock-function-name-face)
   ("font-lock-keyword-face"              . 'font-lock-keyword-face)
   ("font-lock-misc-punctuation-face"     . 'font-lock-misc-punctuation-face)
   ("font-lock-negation-char-face"        . 'font-lock-negation-char-face)
   ("font-lock-number-face"               . 'font-lock-number-face)
   ("font-lock-operator-face"             . 'font-lock-operator-face)
   ("font-lock-preprocessor-face"         . 'font-lock-preprocessor-face)
   ("font-lock-property-name-face"        . 'font-lock-property-name-face)
   ("font-lock-property-use-face"         . 'font-lock-property-use-face)
   ("font-lock-punctuation-face"          . 'font-lock-punctuation-face)
   ("font-lock-regexp-face"               . 'font-lock-regexp-face)
   ("font-lock-regexp-grouping-backslash" . 'font-lock-regexp-grouping-backslash)
   ("font-lock-regexp-grouping-construct" . 'font-lock-regexp-grouping-construct)
   ("font-lock-string-face"               . 'font-lock-string-face)
   ("font-lock-type-face"                 . 'font-lock-type-face)
   ("font-lock-variable-name-face"        . 'font-lock-variable-name-face)
   ("font-lock-variable-use-face"         . 'font-lock-variable-use-face)
   ("font-lock-warning-face"              . 'font-lock-warning-face))
 t)

(defun ll-col (r g b)
  (let* ((red-lumi 0.2126)
         (grn-lumi 0.7152)
         (blu-lumi 0.0722)
         (red-unit (sqrt (// 1 red-lumi)))
         (grn-unit (sqrt (// 1 grn-lumi)))
         (blu-unit (sqrt (// 1 blu-lumi)))
         (ref-unit (max (* r red-unit) (* g grn-unit) (* b blu-unit))))
    (@f "#%02x%02x%02x"
        (* 255 (// (* r red-unit) ref-unit))
        (* 255 (// (* g grn-unit) ref-unit))
        (* 255 (// (* b blu-unit) ref-unit)))
    ))

(sfa 'default            nil :background (juv-col* "gold"      0.2) :foreground (juv-col* "white" 0.8 ))
(sfa 'region             nil :background (juv-col* "magenta"   0.5) :foreground 'unspecified           )
(sfa 'mode-line-active   nil :background (juv-col* "dark cyan" 0.8) :foreground (juv-col* "white" 0.9 ))
(sfa 'mode-line-inactive nil :background (juv-col* "gray"      0.6) :foreground (juv-col* "white" 0.9 ))
(sfa 'show-paren-match   nil :background (juv-col* "white"     0.9) :foreground (juv-col* "cyan"  0.9 ))
(setq-default mode-line-format "%8 %l %16 %*%*%* %b %*%*%* %16 %C")

(defun cursor-init ()
  (blink-cursor-mode 0)
  (set-cursor-color (juv-col* "gray" 96))
  (set-mouse-color  (juv-col* "red"  96))
  (setq-default cursor-type 'box)
  (setq-default cursor-in-non-selected-windows '(hbar . 8)))

(defun tui-init () (i)
  (cursor-init)
  (menu-bar-mode 0))

(defun gui-init () (i)
  (tui-init)
  (set-all-faces)
  (scroll-bar-mode 0)
  (tool-bar-mode   0)
  (tooltip-mode    0)
  (ll-fullscreen))

(provide 'll-face)
;;; ll-face.el ends here