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

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

(-> 'll-window)

(defun face-all-words (&optional top-n)
  (or top-n (setf top-n 8))
  (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 #'>)))) ; (face-all-words)

;;; BEG 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)
;;
;;; END fascinating statistics

(defun ll-fullscreen (&optional verbose) (i)
  (when (gfx)
    (setq frame-resize-pixelwise t)
    (fringe-mode 0)
    (set-frame-width  nil 1920 nil t)
    (set-frame-height nil 1080 nil t)
    (set-frame-parameter nil 'fullscreen 'fullboth)
    (& verbose ($ "[ %d x %d ]" (frame-pixel-width) (frame-pixel-height)))))

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

(defgroup bad-faces nil
  "The `bad' faces."
  :group 'bad
  :group 'faces)

(defface bad-black     '((( (class color) ))) "Our black face."  )
(defface bad-red       '((( (class color) ))) "Our red face."    )
(defface bad-green     '((( (class color) ))) "Our green face."  )
(defface bad-yellow    '((( (class color) ))) "Our yellow face." )
(defface bad-blue      '((( (class color) ))) "Our blue face."   )
(defface bad-magenta   '((( (class color) ))) "Our magenta face.")
(defface bad-cyan      '((( (class color) ))) "Our cyan face."   )
(defface bad-white     '((( (class color) ))) "Our white face."  )

(defface bad-black-b   '((( (class color) ))) "Our black bright face."  )
(defface bad-red-b     '((( (class color) ))) "Our red bright face."    )
(defface bad-green-b   '((( (class color) ))) "Our green bright face."  )
(defface bad-yellow-b  '((( (class color) ))) "Our yellow bright face." )
(defface bad-blue-b    '((( (class color) ))) "Our blue bright face."   )
(defface bad-magenta-b '((( (class color) ))) "Our magenta bright face.")
(defface bad-cyan-b    '((( (class color) ))) "Our cyan bright face."   )
(defface bad-white-b   '((( (class color) ))) "Our white bright face."  )

;; _______________________________
;; 0  1  2  3  4  5  6  7  8  9 10
;; 0 19 32 4b 64 7b 96 af c8 e1 ff
;; -------------------------------
;; (progn (eval-buffer) (push "/home/efti/src/bad-6" load-path) (push "/home/efti/src/bad-6/extra-lisp" load-path) (load "bad-demo.el") (bad-demo-icac))

(defconst bad-black     "#191919") (& nil bad-black     )
(defconst bad-red       "#af7b32") (& nil bad-red       )
(defconst bad-green     "#7b9664") (& nil bad-green     )
(defconst bad-yellow    "#ff9632") (& nil bad-yellow    )
(defconst bad-blue      "#7b96ff") (& nil bad-blue      )
(defconst bad-magenta   "#9664e1") (& nil bad-magenta   )
(defconst bad-cyan      "#6496af") (& nil bad-cyan      )
(defconst bad-white     "#afc8ff") (& nil bad-white     )

(defconst bad-black-b   "#969696") (& nil bad-black-b   )
(defconst bad-red-b     "#ffaf32") (& nil bad-red-b     )
(defconst bad-green-b   "#afaf4b") (& nil bad-green-b   )
(defconst bad-yellow-b  "#969632") (& nil bad-yellow-b  )
(defconst bad-blue-b    "#967be1") (& nil bad-blue-b    )
(defconst bad-magenta-b "#c864af") (& nil bad-magenta-b )
(defconst bad-cyan-b    "#64ffff") (& nil bad-cyan-b    )
(defconst bad-white-b   "#ffffff") (& nil bad-white-b   )

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

(let ((fonts (cl-delete-duplicates (monospace-fonts)))
      (i 0))
  (defun next-monospace (&optional n) (i)
    (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 "OCRABold"))
  (cl-loop
   with old   = (face-attribute 'default :height)
   with font  = fnt
   with w     = 'wide
   with stp   = 5 ; 5 is min
   with h-def = 149
   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
     (if (su font)
         (set-face-attribute f nil :weight 'normal :height h :width w :font font :underline nil :overline nil)
       (set-face-attribute f nil :height h :width w))
     (& (z a) (set-face-attribute f nil :foreground bad-white :background bad-black))
   finally (prog1 h ($ " %s (%d%%)" (window-char-resolution nil t t) h))))
;
(keymap-global-set "C-0" #'set-all-faces)
(keymap-global-set "C-)" (L () (set-all-faces  0   )))
(keymap-global-set "C--" (L () (set-all-faces -1 t )))
(keymap-global-set "C-=" (L () (set-all-faces  1 t )))

;; ----------------------------------------------------------------------------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) (++ e8)))   ; +8
;; (set-all-faces (L (e) (-- e 16))) ; -16

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

(font-lock-add-keywords 'emacs-lisp-mode
 '(
   ("bad-black"     . 'bad-black)
   ("bad-red"       . 'bad-red)
   ("bad-green"     . 'bad-green)
   ("bad-yellow"    . 'bad-yellow)
   ("bad-blue"      . 'bad-blue)
   ("bad-magenta"   . 'bad-magenta)
   ("bad-cyan"      . 'bad-cyan)
   ("bad-white"     . 'bad-white)

   ("bad-black-b"   . 'bad-black-b)
   ("bad-red-b"     . 'bad-red-b)
   ("bad-green-b"   . 'bad-green-b)
   ("bad-yellow-b"  . 'bad-yellow-b)
   ("bad-blue-b"    . 'bad-blue-b)
   ("bad-magenta-b" . 'bad-magenta-b)
   ("bad-cyan-b"    . 'bad-cyan-b)

   ("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)

(set-face-attribute 'font-lock-bracket-face              nil :foreground bad-blue     )
(set-face-attribute 'font-lock-builtin-face              nil :foreground bad-blue     )
(set-face-attribute 'font-lock-comment-face              nil :foreground bad-blue     )
(set-face-attribute 'font-lock-comment-delimiter-face    nil :foreground bad-white    )
(set-face-attribute 'font-lock-function-name-face        nil :foreground bad-blue     )
(set-face-attribute 'font-lock-constant-face             nil :foreground bad-magenta  )
(set-face-attribute 'font-lock-delimiter-face            nil :foreground bad-cyan     )
(set-face-attribute 'font-lock-doc-face                  nil :foreground bad-black     :background bad-white)
(set-face-attribute 'font-lock-doc-markup-face           nil :foreground bad-white    )
(set-face-attribute 'font-lock-escape-face               nil :foreground bad-red      )
(set-face-attribute 'font-lock-function-call-face        nil :foreground bad-blue     )
(set-face-attribute 'font-lock-keyword-face              nil :foreground bad-blue     )
(set-face-attribute 'font-lock-misc-punctuation-face     nil :foreground bad-magenta  )
(set-face-attribute 'font-lock-negation-char-face        nil :foreground bad-cyan     )
(set-face-attribute 'font-lock-number-face               nil :foreground bad-black-b  )
(set-face-attribute 'font-lock-operator-face             nil :foreground bad-white    )
(set-face-attribute 'font-lock-preprocessor-face         nil :foreground bad-red      )
(set-face-attribute 'font-lock-property-name-face        nil :foreground bad-blue     )
(set-face-attribute 'font-lock-property-use-face         nil :foreground bad-yellow   )
(set-face-attribute 'font-lock-punctuation-face          nil :foreground bad-blue     )
(set-face-attribute 'font-lock-regexp-face               nil :foreground bad-magenta  )
(set-face-attribute 'font-lock-regexp-grouping-backslash nil :foreground bad-cyan     )
(set-face-attribute 'font-lock-regexp-grouping-construct nil :foreground bad-blue     )
(set-face-attribute 'font-lock-string-face               nil :foreground bad-white    )
(set-face-attribute 'font-lock-type-face                 nil :foreground bad-red      )
(set-face-attribute 'font-lock-variable-name-face        nil :foreground bad-blue     )
(set-face-attribute 'font-lock-variable-use-face         nil :foreground bad-yellow   )

(set-face-attribute 'default            nil :background 'unspecified :foreground bad-white
                                                                                           :weight 'bold)
(set-face-attribute 'region             nil :background "#875fff"  :foreground 'unspecified)
(set-face-attribute 'mode-line-active   nil :background "#008787"  :foreground bad-white)
(set-face-attribute 'mode-line-inactive nil :background bad-blue   :foreground bad-white)
(set-face-attribute 'show-paren-match   nil :background bad-cyan-b :foreground 'unspecified)
(setq-default mode-line-format "%8 %l %16 %*%*%* %b %*%*%* %16 %C")

(defun cursor-init ()
  (blink-cursor-mode 0)
  (set-cursor-color bad-white)
  (set-mouse-color  bad-red)
  (let ((type 'box))
    (setq-default cursor-type                    type)
    (setq-default cursor-type-no-selected-window type)))

(defun gui-init () (i)
  (cursor-init)
  (font-lock-mode)
  (menu-bar-mode   0)
  (scroll-bar-mode 0)
  (tool-bar-mode   0)
  (tooltip-mode    0)
  (set-foreground-color bad-white)
  (set-background-color bad-black)
  (set-all-faces)
  (ll-fullscreen))

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