;;; -*- lexical-binding: t -*- ;; ;; -------------------------------------------------------------------------- (require 'cl-lib) (cl-pushnew "." load-path :test #'string=) (require 'luki-lisp) ;; -------------------------------------------------------------------------- (-> 'cl-lib) (-> 'facemenu) ;; -------------------------------------------------------------------------- (defun bad-bg-random () (seq-random-elt (bad-bg-colors))) (defun bad-fg-random () (seq-random-elt (bad-fg-colors))) ;; -------------------------------------------------------------------------- (defun bad-color-sum (col) (pcase-let ((`(,r ,g ,b) (mapcar (L (e) (/ e (** 2 8))) (color-values col)))) (/ (+ r g b) 3))) ;; (bad-color-sum "azure") ; 250 ;; (bad-color-sum "gray33") ; 84 ;; (bad-color-sum "black") ; 0 (let ((fg-cols) (too-dark 96)) ; (* 6 (// 1 16) (** 2 8)) (defun bad-fg-colors () (or fg-cols (setq fg-cols (cl-remove-if-not (L (e) (< too-dark (bad-color-sum e))) (defined-colors)))))) (let ((bg-cols) (too-bright 192) ; (* 12 (// 1 16) (** 2 8)) (too-dark 80)) ; (* 5 (// 1 16) (** 2 8)) (defun bad-bg-colors () (or bg-cols (setq bg-cols (cl-remove-if-not (L (e) (< too-dark (bad-color-sum e) too-bright)) (defined-colors)))))) (declare-function bad-fg-colors nil) (declare-function bad-bg-colors nil) ;; -------------------------------------------------------------------------- (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 "#00ff00") (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 "#5fff5f") (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") ;; -------------------------------------------------------------------------- ;; [back to normal Elisp - try this 1] ;; ~ the ANSI 6x6x6 color cubes ~ ;; ;; screenshot: https://dataswamp.org/~incal/bad-el/bad-4/img/cl-elisp-ansi.png ;; ;; the ANSI steps: 0 1 2 3 4 5 ;; --------------- x00 x5f x87 xaf xd7 xff ;; 95 135 175 215 255)_10 (defun bad-color-ansi (&optional str) (i) (when-let* ((buf (get-buffer-create "*ansi-buffer*"))) (with-current-buffer buf (erase-buffer) (cl-loop with str = (or str " ") with pts = (number-sequence 0 1 (/ 1.0 5)) for r in pts do (cl-loop for g in pts do (cl-loop for b in pts for ansi = (color-rgb-to-hex r g b) do (insert (propertize str 'face `(:background ,ansi)))) (insert " ") finally do (delete-char -1) (insert "\n")))) (pop-to-buffer buf))) ; (bad-color-ansi) ;; -------------------------------------------------------------------------- (defun icac () (i) (when-let* ((buf (get-buffer-create "*ansi-buffer*"))) (with-current-buffer buf (cl-loop with label = "insert color as color" initially do (erase-buffer) (insert label ?\n (make-string (--- label) ?\-) ?\n) with cols = '(our-black our-red our-green our-yellow our-blue our-magenta our-cyan our-white our-black-b our-red-b our-green-b our-yellow-b our-blue-b our-magenta-b our-cyan-b our-white-b) with pad = 13 with spc = (make-string pad ?\s) for c in cols for nom = (symbol-name c) for col = (symbol-value c) do (insert (@f " %s %s %s\n" (string-pad (propertize nom 'face `(:weight bold :foreground ,col)) pad) (propertize col 'face `(:foreground ,col)) (propertize spc 'face `(:background ,col))))) (pop-to-buffer buf)))) ; (icac) ;; -------------------------------------------------------------------------- (defun bad-use-x-resources-colors () (i) (when (gfx) (cl-loop with cols = 16 for i from 0 to cols collect (x-get-resource (@f "color%d" i) "*") into x-cols finally do (when (= cols (--- x-cols)) (setq our-black (pop x-cols)) (setq our-red (pop x-cols)) (setq our-green (pop x-cols)) (setq our-yellow (pop x-cols)) (setq our-blue (pop x-cols)) (setq our-magenta (pop x-cols)) (setq our-cyan (pop x-cols)) (setq our-white (pop x-cols)) (setq our-black-b (pop x-cols)) (setq our-red-b (pop x-cols)) (setq our-green-b (pop x-cols)) (setq our-yellow-b (pop x-cols)) (setq our-blue-b (pop x-cols)) (setq our-magenta-b (pop x-cols)) (setq our-cyan-b (pop x-cols)) (setq our-white-b (pop x-cols)))))) ;; -------------------------------------------------------------------------- (defun bad-draw-fg-color (&optional fg beg stay end) (i) (or fg (setq fg our-green)) (or beg (setq beg (point))) (or end (setq end (1+ beg))) (put-text-property beg end 'face `(:foreground ,fg :background ,(background-color-at-point))) (unless stay (forward-char))) (defun bad-draw-bg-color (&optional bg beg stay end) (i) (or bg (setq bg our-magenta)) (or beg (setq beg (point))) (or end (setq end (1+ beg))) (put-text-property beg end 'face `(:foreground ,(foreground-color-at-point) :background ,bg)) (unless stay (forward-char))) (defun bad-put-color-at-point (&optional colors) (i) (or colors (setq colors (defined-colors))) (let ((c (if (lu colors) (seq-random-elt colors) colors))) (bad-draw-bg-color c (point)))) (defun bad-cursor-pos (&optional w) (or w (setq w (1+ (frame-width)))) (when-let* ((pos (mouse-position)) (lin (2i pos)) (col (1i pos))) (+ 1 col (* lin w)))) (defun bad-test-area () (i) (let ((len (- (frame-width) 4)) (beg (point))) (insert ?\n (make-string len ?█) ?\n (make-string len ?▓) ?\n (make-string len ?▒) ?\n (make-string len ?░) ?\n "(font-lock-mode -1)") (comment-region beg (point)))) ;; (font-lock-mode -1) ;; █████████████████████████████████████████████████████████████████████████████████████████ ;; ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓ ;; ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ ;; ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ;; (font-lock-mode -1) (defun get-colors (&optional n) "Originally found in facemenu.el code." (or n (setq n 16)) (when (< 0 (display-color-cells)) (let ((lst (list-colors-duplicates (defined-colors)))) (when list-colors-sort (setq lst (mapcar #'car ; NOTE: OK (sort (delq nil (mapcar (L (e) (when-let* ((key (list-colors-sort-key (1st e)))) (cons e (if (consp key) key (list key))))) lst)) (L (a b) (let* ((a-keys (cdr a)) (b-keys (cdr b)) (a-key (1st a-keys)) (b-key (1st b-keys))) (while (& a-key b-key (l= a-key b-key)) (setq a-keys (cdr a-keys)) (setq a-key (1st a-keys)) (setq b-keys (cdr b-keys)) (setq b-key (1st b-keys))) (cond ((& (n a-key) (n b-key)) (< a-key b-key)) ((& (s a-key) (s b-key)) (string< a-key b-key))))))))) (take n lst)))) ;; (get-colors) ;; (--- (get-colors 8)) ; 8 ;; (--- (get-colors)) ; 16 ;; (--- (get-colors 800)) ; 256 (here in VT/-nw Emacs; in X it is 548) (defun pick-close-color (&optional col n ps) (or ps (setq ps "color: ")) (or col (setq col (read-color ps))) (or n (setq n 8)) (when (color-defined-p col) (pcase-let* ((list-colors-sort (cons 'rgb-dist col)) (`(,r ,g ,b) (color-name-to-rgb (1st (seq-random-elt (get-colors n)))))) (color-rgb-to-hex r g b 2)))) ;; (pick-close-color our-white) ;; (pick-close-color) (defun bad-color-get () (i) `(,(face-attribute 'default :foreground) ,(face-attribute 'default :background))) (defun bad-color-echo () (i) (pcase-let* ((`(,fg ,bg) (bad-color-get)) (`(,fg-r ,fg-g ,fg-b) (color-values fg)) ; trust `color-values'? [1] (`(,bg-r ,bg-g ,bg-b) (color-values bg))) ($ "%4s[fg %5d %5d %5d %s]%4s[bg %5d %5d %5d %s]" " " fg-r fg-g fg-b fg " " bg-r bg-g bg-b bg))) (defun bad-color-cycle (&optional prev fg-mode) (i) (pcase-let* ((cols (defined-colors-with-face-attributes)) (len (--- cols)) (`(,fg ,bg) (bad-color-get)) (`(,col ,cfun) (if fg-mode (list fg #'set-foreground-color) (list bg #'set-background-color))) (pos (cl-position col cols :test #'s=)) (step 1) (incv (if prev (* -1 step) step))) (if pos (setq pos (m (++ pos incv) len)) (setq pos 0)) (funcall cfun (nth pos cols))) (bad-color-echo)) ;; -------------------------------------------------------------------------- (defun bad-color-values (c) (let ((col-str-len 2)) (unless (s= (substring c 0 1) "#") (pcase-let* ((col (color-name-to-rgb c)) (`(,r ,g ,b) col)) (setq c (color-rgb-to-hex r g b col-str-len)))) (mapcar (L (s) (s2n s 16)) (list (substring c #1=1 #2=(+ #1# col-str-len)) (substring c #2# #3=(+ #2# col-str-len)) (substring c #3# (+ #3# col-str-len)))))) ;; (bad-color-values "#e5e5e5") ;; (bad-color-values "white") (defun bad-color-clamp (val &optional mini maxi) (or mini (setq mini 0)) ; (1- (** 2 0)) (or maxi (setq maxi 255)) ; (1- (** 2 8)) (min maxi (max mini val))) ;; (bad-color-clamp 255) ;; -------------------------------------------------------------------------- (defun bad-color-norm (c &optional to-str) (let* ((as-str (s c)) (col-vals (if as-str (bad-color-values c) c))) (when (& (lu col-vals) (= 3 (--- col-vals)) (cl-every (L (e) (n e)) col-vals)) (when-let* ((cols (mapcar #'bad-color-clamp col-vals))) (if to-str (pcase-let ((`(,r ,g ,b) cols)) (@f "#%x%x%x" r g b)) cols))))) ;; (bad-color-norm '(0 1 200000)) ;; (bad-color-norm "#fffffff") (defun col+ (c1 c2 &optional mult) (setq c1 (bad-color-norm c1)) (setq c2 (bad-color-norm c2)) (when (& c1 c2) (pcase-let ((`(,r1 ,g1 ,b1) c1) (`(,r2 ,g2 ,b2) c2)) (bad-color-norm (if mult (list (* r1 r2) (* g1 g2) (* b1 b2)) (list (+ r1 r2) (+ g1 g2) (+ b1 b2))))))) ;; (col+ '(1 2 3) '( 4 5 6)) ; (5 7 9) ;; (col+ '(1 2 3) '( 4 5 6) 'mult) ; (4 10 18) (defun col* (k col) (when (& col k) (if (n k) (bad-color-norm (mapcar (L (e) (* k e)) (bad-color-norm col))) (col+ k col 'mult)))) ;; (col* '(1 2 3) '( 4 5 6)) ; (4 10 18) ;; (col* 0.2 '( 4 5 6)) ; (0.8 1.0 1.2) ;; -------------------------------------------------------------------------- ;; [1] (color-defined-p "#ff02f0") ; `t' so expected (255 2 240) but ;; (color-name-to-rgb "#ff02f0") ; (1.0 0.0 1.0) ;; (color-values "#ff02f0") ; (65535 0 65535) ;; edit: Ah, now in X I get (1.0 0.00784313725490196 0.9411764705882353) ;; ^^^^^ and (65535 514 61680); maybe a VT/-nw Emacs thing then. ;; -------------------------------------------------------------------------- (<- 'bad-color)