;;; -*- lexical-binding: t -*-
;;
;; -----------------------------------------------------------------------------
;;
;;  this file:
;;    https://dataswamp.org/~incal/emacs-init/ll/ll-face.el
;;
;; -----------------------------------------------------------------------------

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

;; --------------------------------------------------------------------------

(-> 'apropos)
(-> 'compile)
(-> 'css-mode)
(-> 'cus-edit)
(-> 'diff-mode)
(-> 'faces)
(-> 'ffap)
(-> 'info)
(-> 'man)
(-> 'sh-script)
(-> 'time)

;; --------------------------------------------------------------------------

(defvar our-black)
(defvar our-red)
(defvar our-green)
(defvar our-yellow)
(defvar our-blue)
(defvar our-magenta)
(defvar our-cyan)
(defvar our-white)

(defvar our-black-b)
(defvar our-red-b)
(defvar our-green-b)
(defvar our-yellow-b)
(defvar our-blue-b)
(defvar our-magenta-b)
(defvar our-cyan-b)
(defvar our-white-b)

(setq our-black     "#000000")
(setq our-red       "#d75f00")
(setq our-green     "#878787")
(setq our-yellow    "#d7d700")
(setq our-blue      "#5f87ff")
(setq our-magenta   "#d75fd7")
(setq our-cyan      "#00d7d7")
(setq our-white     "#afafd7")

(setq our-black-b   "#878787")
(setq our-red-b     "#ff8700")
(setq our-green-b   "#00d700")
(setq our-yellow-b  "#ffff00")
(setq our-blue-b    "#8787ff")
(setq our-magenta-b "#ff5fff")
(setq our-cyan-b    "#00ffff")
(setq our-white-b   "#d7d7d7")

;; --------------------------------------------------------------------------

(defun get-color (x vt)
 (if (gfx)
   (x-get-resource (@f "color%d" x) "*")
  vt))
;; (and (gfx) (x-get-resource (@f "color%d" 0) "*"))

;; -----------------------------------------------------------------------------

(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 (monospace-fonts))
      (i 0))

  (defun next-monospace (&optional step) (i)
    (or step (setf step 1))
    (when-let* ((font (nth (m (++ i step) (--- fonts)) fonts)))
      (set-frame-font font t)
      (set-frame-width  nil 1280 nil 'pixelwise)
      (set-frame-height nil  720 nil 'pixelwise)
      (set-frame-parameter nil 'fullscreen 'fullboth)
      ($ "font: %s" font)))

  (defun prev-monospace (&optional step)
    (next-monospace (if step (- step) -1)))

  (declare-function next-monospace nil)
  (declare-function prev-monospace nil))

;; (next-monospace)

;; -----------------------------------------------------------------------------

(defun set-all-faces (&optional monospace)
  (cl-loop
   with faces
   initially (if monospace
                 (setf faces (monospace-fonts))
               (mapatoms (L (s)
                            (when (facep s)
                              (push (symbol-name s) faces)))))
   for f in faces
   do (set-face-attribute (intern f) nil
                          :height 100)
   finally return (--- faces)))

;; -----------------------------------------------------------------------------

;; (set-all-faces)
;; (set-all-faces t)

;; -----------------------------------------------------------------------------

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

;; --------------------------------------------------------------------------

(defun set-face (face fg &optional bold bg)
 (setf bold (if bold 'bold 'normal))
 (unless bg (setf bg our-black))
 (set-face-attribute face nil
                     :foreground fg
                     :background bg
                     :weight   bold))

(defalias 'sfa #'set-face)

;; --------------------------------------------------------------------------

(defun copy-face-attributes (src dst &rest more-faces)
  (when (& (facep src)
           (facep dst))
    (dolist (d (cons dst more-faces))
      (let ((fg  (face-attribute src :foreground nil 'default))
            (bg  (face-attribute src :background nil 'default))
            (bld (face-attribute src :weight     nil 'default)))
        (set-face-attribute d nil :foreground fg :background bg :weight bld)))))

(defalias 'cpf #'copy-face-attributes)

;; --------------------------------------------------------------------------

(font-lock-add-keywords 'emacs-lisp-mode
 '(
   ("our-black-b"   . 'font-lock-doc-face)
   ("our-red-b"     . 'font-lock-type-face)
   ("our-green-b"   . 'font-lock-keyword-face)
   ("our-yellow-b"  . 'font-lock-preprocessor-face)
   ("our-blue-b"    . 'font-lock-comment-face)
   ("our-magenta-b" . 'font-lock-constant-face)
   ("our-cyan-b"    . 'font-lock-function-name-face)
   ("our-white-b"   . 'font-lock-operator-face)
   ("\\#'[-[:alnum:]]+" . 'font-lock-function-name-face)
   ("1-"                . 'font-lock-preprocessor-face)
   ("1\\+"              . 'font-lock-keyword-face)
   ("?[\\]\\{,1\\}."    . 'font-lock-constant-face)
   ("\\#[[:digit:]]="   . 'font-lock-preprocessor-face)
   ("\\#[[:digit:]]\\#" . 'font-lock-doc-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-doc-face"                  . 'font-lock-doc-face)
   ("font-lock-function-name-face"        . 'font-lock-function-name-face)
   ("font-lock-keyword-face"              . 'font-lock-keyword-face)
   ("font-lock-negation-char-face"        . 'font-lock-negation-char-face)
   ("font-lcok-operator-face"             . 'font-lock-operator-face)
   ("font-lock-preprocessor-face"         . 'font-lock-preprocessor-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-warning-face"              . 'font-lock-warning-face))
 t)

(sfa 'bold              our-white-b    t)
(sfa 'bold-italic       our-yellow-b   t)
(sfa 'button            our-green-b    t)
(sfa 'cursor            our-white-b    t our-white)
(sfa 'default           our-white      t)
(sfa 'ffap              our-black-b    nil our-cyan)
(sfa 'homoglyph         our-magenta-b)
(sfa 'icon-button       our-green-b    t)
(sfa 'italic            our-green-b    t)
(sfa 'match             our-black-b    nil our-cyan)
(sfa 'minibuffer-prompt our-cyan-b)
(sfa 'nobreak-space     our-black-b    t)
(sfa 'region            our-white-b    t   our-blue-b)
(sfa 'shadow            our-magenta-b)
(sfa 'underline         our-yellow-b   t)
(sfa 'warning           our-red-b      t)

(sfa 'font-lock-builtin-face              our-cyan    t)
(sfa 'font-lock-comment-face              our-blue    t)
(sfa 'font-lock-constant-face             our-magenta t)
(sfa 'font-lock-doc-face                  our-black-b t)
(sfa 'font-lock-function-name-face        our-cyan    t)
(sfa 'font-lock-keyword-face              our-green   t)
(sfa 'font-lock-negation-char-face        our-black-b t)
(sfa 'font-lock-operator-face             our-white   t)
(sfa 'font-lock-preprocessor-face         our-yellow  t)
(sfa 'font-lock-string-face               our-magenta t)
(sfa 'font-lock-type-face                 our-red     t)
(sfa 'font-lock-variable-name-face        our-cyan    t)
(sfa 'font-lock-regexp-grouping-backslash our-blue    t)
(sfa 'font-lock-regexp-grouping-construct our-yellow  t)

(cpf 'font-lock-comment-face 'font-lock-comment-delimiter-face)
(cpf 'warning 'font-lock-warning-face)

;; --------------------------------------------------------------------------
;; unsorted

(sfa 'escape-glyph                      our-yellow)
(sfa 'eldoc-highlight-function-argument our-cyan  t)
(sfa 'sh-escaped-newline                our-red   t)
(sfa 'world-clock-label                 our-cyan  t)

;; --------------------------------------------------------------------------
;; diff
(sfa 'diff-refine-added   our-black   nil our-green)
(sfa 'diff-refine-removed our-black   nil our-red)
(sfa 'diff-removed        our-black-b t)

;; --------------------------------------------------------------------------
;; apropos

(sfa 'apropos-function-button our-green   t)
(sfa 'apropos-misc-button     our-yellow)
(sfa 'apropos-property        our-cyan    t)
(sfa 'apropos-symbol          our-blue    t)
(sfa 'apropos-variable-button our-magenta t)

(cpf 'apropos-variable-button 'apropos-user-option-button)

;; --------------------------------------------------------------------------
;; ispell / isearch

(sfa 'isearch        our-black nil our-yellow)
(sfa 'lazy-highlight our-black nil our-yellow)

;; --------------------------------------------------------------------------
;; man

(sfa 'Man-overstrike our-cyan)
(sfa 'Man-underline  our-yellow t)

;; --------------------------------------------------------------------------
;; compilation

(sfa 'compilation-error our-red  t)
(sfa 'compilation-info our-green t)

;; --------------------------------------------------------------------------
;; help

(sfa 'help-argument-name   our-magenta)
(sfa 'help-for-help-header our-green t)
(sfa 'help-key-binding     our-cyan)

(cpf 'help-key-binding 'apropos-keybinding)

;; --------------------------------------------------------------------------
;; header

(sfa 'header-line                our-black-b)
(sfa 'tabulated-list-fake-header our-black-b t)

;; --------------------------------------------------------------------------
;; css

(sfa 'css-selector our-yellow)
(sfa 'css-property our-green t)

;; --------------------------------------------------------------------------
;; completion

(sfa 'completions-common-part      our-green)
(sfa 'completions-first-difference our-yellow)
(sfa 'completions-highlight        our-cyan t)

;; --------------------------------------------------------------------------
;; package

(sfa 'package-description       our-cyan)
(sfa 'package-help-section-name our-blue    t)
(sfa 'package-name              our-cyan    t)
(sfa 'package-status-available  our-yellow  t)
(sfa 'package-status-built-in   our-yellow)
(sfa 'package-status-dependency our-black-b t)
(sfa 'package-status-installed  our-green   t)
(sfa 'package-status-new        our-cyan)

;; --------------------------------------------------------------------------
;; mode line

(sfa 'mode-line-buffer-id 'unspecified t 'unspecified)
(sfa 'mode-line-emphasis   our-red     t  our-black)
(sfa 'mode-line-highlight  our-red     t  our-black)

(set-face-attribute 'mode-line-inactive nil
                    :foreground our-white-b
                    :background our-black-b
                    :box (& (gfx) (list :line-width (cons -1 1) :color our-white))
                    :height 100)

(set-face-attribute 'mode-line-active nil
                    :foreground our-white-b
                    :background our-blue-b
                    :box (& (gfx) (list :line-width (cons -1 1) :color our-white-b :style 'flat-button))
                    :height 100
                    :weight 'bold)

;; --------------------------------------------------------------------------
;; paren

(sfa 'show-paren-match    our-black  t our-blue-b)
(sfa 'show-paren-mismatch our-yellow t our-red)

;; --------------------------------------------------------------------------
;; dired

(sfa 'dired-perm-write our-cyan    t)
(sfa 'dired-directory  our-blue    t)
(sfa 'dired-header     our-green)
(sfa 'dired-ignored    our-black-b t)
(sfa 'dired-mark       our-yellow  t)
(sfa 'dired-perm-write our-red     t)
(sfa 'dired-set-id     our-black   nil our-yellow)
(sfa 'dired-symlink    our-cyan)

(cpf 'dired-mark 'dired-flagged 'dired-marked)

;; --------------------------------------------------------------------------
;; w3m [ TODO: `w3m-anchor' `w3m-arrived-anchor' `w3m-bold' `w3m-italic' `w3m-underline' ]

(when (featurep 'w3m)
  (sfa 'w3m-current-anchor          our-yellow)
  (sfa 'w3m-form                    our-cyan  t) ; DNC?
  (sfa 'w3m-form-button             our-black nil our-yellow)
  (sfa 'w3m-image                   our-black nil our-cyan)
  (sfa 'w3m-image-anchor            our-black nil our-cyan)
  (sfa 'w3m-tab-background          our-black)
  (sfa 'w3m-tab-selected            our-black t   our-white-b)
  (sfa 'w3m-tab-selected-background our-white-b)
  (sfa 'w3m-tab-selected-retrieving our-black nil our-cyan)
  (sfa 'w3m-tab-unselected          our-black t)

  (cpf 'w3m-tab-unselected
       'w3m-tab-unselected-retrieving
       'w3m-tab-unselected-unseen))

;; --------------------------------------------------------------------------
;; comint

(sfa 'comint-highlight-input  our-magenta t)
(sfa 'comint-highlight-prompt our-green   t)

;; --------------------------------------------------------------------------
;; Info / info

(sfa 'Info-quoted our-magenta t)

(sfa 'info-header-node our-yellow)
(sfa 'info-menu-header our-magenta t)
(sfa 'info-menu-star   our-cyan)
(sfa 'info-title-1     our-yellow)
(sfa 'info-title-2     our-blue    t)
(sfa 'info-title-3     our-green   t)
(sfa 'info-title-4     our-cyan)
(sfa 'info-xref        our-cyan)

(cpf 'info-xref
     'info-header-xref
     'info-xref-visited)

;; --------------------------------------------------------------------------
;; bold

(cpf 'bold 'ansi-color-bold)

;; --------------------------------------------------------------------------
;; button

(sfa 'custom-button our-black-b t our-black)
(cpf 'button
     'apropos-button
     'browse-url-button
     'link)

;; --------------------------------------------------------------------------
;; warning

(cpf 'warning 'dired-perm-write)

;; --------------------------------------------------------------------------

(<- 'll-face)