;;; package --- summary -*- lexical-binding: t -*-
;;; Commentary:
;;; Code:

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

(-> 'll-window)

(defun fullscreen (&optional verbose) (i)
  (when (gfx)
    (setq frame-resize-pixelwise t)
    (fringe-mode 0)
    (set-frame-width  nil 1280 nil t) ; todo
    (set-frame-height nil  720 nil t) ; todo
    (set-frame-parameter nil 'fullscreen 'fullboth)
    (& verbose ($ "[ %dx%d pxls ]" (frame-pixel-width) (frame-pixel-height)))))

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

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

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

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

(set-face-foreground 'our-black     "#000000")
(set-face-background 'our-black     "#000000")

(set-face-foreground 'our-red       "#d70000")
(set-face-foreground 'our-green     "#008700")
(set-face-foreground 'our-yellow    "#afaf00")
(set-face-foreground 'our-blue      "#005fff")
(set-face-foreground 'our-magenta   "#d75fd7")
(set-face-foreground 'our-cyan      "#00d7d7")
(set-face-foreground 'our-white     "#afafaf")

(set-face-foreground 'our-black-b   "#8787d7")
(set-face-background 'our-black-b   "#000000")

(set-face-foreground 'our-red-b     "#ff0000")
(set-face-foreground 'our-green-b   "#00af00")
(set-face-foreground 'our-yellow-b  "#d7d700")
(set-face-foreground 'our-blue-b    "#87d7ff")
(set-face-foreground 'our-magenta-b "#ff5fff")
(set-face-foreground 'our-cyan-b    "#00ffff")
(set-face-foreground 'our-white-b   "#d7d7d7")

(defun unifont () (i)
  (set-frame-font "-GNU -Unifont-regular-normal-normal-*-*-*-*-*-d-0-iso10646-1"))
;; (unifont)

(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)
      (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   = 4 ; note: smaller DNC
   with h-def = 100
   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 (goto-char (pos-bol)) (setf a (& (lu current-prefix-arg) (1st current-prefix-arg)))
   for f in fs do
   (if (su font)
       (set-face-attribute f nil :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 'unspecified :background 'unspecified))
   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, noticable 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!"))))

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

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

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

(font-lock-add-keywords 'emacs-lisp-mode
 '(
   ("our-black-b"                         . 'font-lock-bracket-face)
   ("our-red-b"                           . 'font-lock-escape-face)
   ("our-green-b"                         . 'font-lock-variable-use-face)
   ("our-yellow-b"                        . 'font-lock-function-call-face)
   ("our-blue-b"                          . 'font-lock-misc-punctuation-face)
   ("our-magenta-b"                       . 'font-lock-number-face)
   ("our-cyan-b"                          . 'font-lock-property-name-face)
   ("our-white-b"                         . 'font-lock-property-use-face)
   ("our-black-b"                         . 'font-lock-regexp-face)

   ("our-black-b"                         . 'font-lock-doc-face)
   ("our-red-b"                           . 'font-lock-constant-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-type-face)
   ("our-cyan-b"                          . 'font-lock-function-name-face)
   ("our-white-b"                         . 'font-lock-operator-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)

   ("\\#'[-[: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))
 t)

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

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

(set-face-attribute 'mode-line-inactive nil
                    :foreground (face-fg 'our-white-b)
                    :background (face-fg 'our-black-b))
(set-face-attribute 'mode-line-active nil
                    :foreground (face-fg 'our-white-b)
                    :background "#5f87af")

(setq-default mode-line-format "%8 %l %16 %*%*%* %b %*%*%* %16 %C")

;; -----------------------------------------------------------------------------
;; faces
;; -----------------------------------------------------------------------------

(set-face 'default (face-fg 'our-white-b) t (face-fg 'our-black))

(load-theme 'tsdh-dark)
;; (custom-theme-visit-theme 'tsdh-dark)

(set-face-attribute 'region                 nil :background "#875fd7")
(set-face-attribute 'show-paren-match       nil :foreground (face-fg 'our-black) :background (face-fg 'our-cyan))
(set-face-attribute 'font-lock-builtin-face nil :foreground (face-fg 'our-cyan-b))

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