summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
authorLars Ingebrigtsen <larsi@gnus.org>2022-04-14 01:00:44 +0200
committerLars Ingebrigtsen <larsi@gnus.org>2022-04-14 01:00:44 +0200
commit800998808a1ebf83263ffbdea833c155fcbae7a6 (patch)
tree681525e5aa9743eaef1369b34e896888cec79f71 /lisp/emacs-lisp
parent864c8013fdd0a548d98d81dd21af2f88f207858a (diff)
downloademacs-800998808a1ebf83263ffbdea833c155fcbae7a6.tar.gz
emacs-800998808a1ebf83263ffbdea833c155fcbae7a6.tar.bz2
emacs-800998808a1ebf83263ffbdea833c155fcbae7a6.zip
Allow putting alternating colors on vtable rows
* doc/misc/vtable.texi (Making A Table): Document it. * lisp/emacs-lisp/vtable.el (vtable): Add :row-colors. (make-vtable): Ditto. (vtable--compute-colors, vtable--color-blend): New functions. (vtable--insert-line): Take a line number argument and adjust callers.
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/vtable.el61
1 files changed, 50 insertions, 11 deletions
diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el
index 3e521c94a5c..e0010434447 100644
--- a/lisp/emacs-lisp/vtable.el
+++ b/lisp/emacs-lisp/vtable.el
@@ -64,6 +64,8 @@
(sort-by :initarg :sort-by :accessor vtable-sort-by)
(ellipsis :initarg :ellipsis :accessor vtable-ellipsis)
(column-colors :initarg :column-colors :accessor vtable-column-colors)
+ (row-colors :initarg :row-colors :accessor vtable-row-colors)
+ (-cached-colors :initform nil :accessor vtable--cached-colors)
(-cache :initform (make-hash-table :test #'equal)))
"A object to hold the data for a table.")
@@ -91,6 +93,7 @@
sort-by
(ellipsis t)
(insert t)
+ row-colors
column-colors)
"Create and insert a vtable at point.
The vtable object is returned. If INSERT is nil, the table won't
@@ -130,10 +133,15 @@ be inserted."
:keymap keymap
:separator-width separator-width
:sort-by sort-by
+ :row-colors row-colors
:column-colors column-colors
:ellipsis ellipsis)))
;; Compute missing column data.
(setf (vtable-columns table) (vtable--compute-columns table))
+ ;; Compute colors if we have to mix them.
+ (when (and row-colors column-colors)
+ (setf (vtable--cached-colors table)
+ (vtable--compute-colors row-colors column-colors)))
(unless sort-by
(seq-do-indexed (lambda (column index)
(when (vtable-column-primary column)
@@ -144,6 +152,20 @@ be inserted."
(vtable-insert table))
table))
+(defun vtable--compute-colors (row-colors column-colors)
+ (cl-loop for row in row-colors
+ collect (cl-loop for column in column-colors
+ collect (vtable--color-blend row column))))
+
+;;; FIXME: This is probably not the right way to blend two colors, is
+;;; it?
+(defun vtable--color-blend (color1 color2)
+ (cl-destructuring-bind (r g b)
+ (mapcar (lambda (n) (* (/ n 2) 255.0))
+ (cl-mapcar #'+ (color-name-to-rgb color1)
+ (color-name-to-rgb color2)))
+ (format "#%02X%02X%02X" r g b)))
+
;;; Interface utility functions.
(defun vtable-current-table ()
@@ -219,7 +241,8 @@ If it can't be found, return nil and don't move point."
(error "Can't find the old object"))
(setcar (cdr objects) object))
;; Then update the cache...
- (let ((line (assq old-object (car (vtable--cache table)))))
+ (let* ((line-number (seq-position old-object (car (vtable--cache table))))
+ (line (elt (car (vtable--cache table)) line-number)))
(unless line
(error "Can't find cached object"))
(setcar line object)
@@ -230,7 +253,8 @@ If it can't be found, return nil and don't move point."
(let ((keymap (get-text-property (point) 'keymap))
(start (point)))
(delete-line)
- (vtable--insert-line table line (nth 1 (vtable--cache table))
+ (vtable--insert-line table line line-number
+ (nth 1 (vtable--cache table))
(vtable--spacer table))
(add-text-properties start (point) (list 'keymap keymap
'vtable table))))
@@ -285,7 +309,10 @@ This also updates the displayed table."
(unless (vtable-goto-object after-object)
(vtable-end-of-table))))
(let ((start (point)))
- (vtable--insert-line table line (nth 1 cache) (vtable--spacer table))
+ ;; FIXME: We have to adjust colors in lines below this if we
+ ;; have :row-colors.
+ (vtable--insert-line table line 0
+ (nth 1 cache) (vtable--spacer table))
(add-text-properties start (point) (list 'keymap keymap
'vtable table)))
;; We may have inserted a non-numerical value into a previously
@@ -374,20 +401,26 @@ This also updates the displayed table."
(setq start (point)))
(vtable--sort table)
;; Insert the data.
- (dolist (line (car (vtable--cache table)))
- (vtable--insert-line table line widths spacer
- ellipsis ellipsis-width))
+ (let ((line-number 0))
+ (dolist (line (car (vtable--cache table)))
+ (vtable--insert-line table line line-number widths spacer
+ ellipsis ellipsis-width)
+ (setq line-number (1+ line-number))))
(add-text-properties start (point)
(list 'keymap (vtable--make-keymap table)
'rear-nonsticky t
'vtable table))
(goto-char start)))
-(defun vtable--insert-line (table line widths spacer
+(defun vtable--insert-line (table line line-number widths spacer
&optional ellipsis ellipsis-width)
(let ((start (point))
(columns (vtable-columns table))
- (colors (vtable-column-colors table)))
+ (column-colors
+ (if (vtable-row-colors table)
+ (elt (vtable--cached-colors table)
+ (mod line-number (length (vtable-row-colors table))))
+ (vtable-column-colors table))))
(seq-do-indexed
(lambda (elem index)
(let ((value (nth 0 elem))
@@ -449,14 +482,20 @@ This also updates the displayed table."
(list 'space
:width (list spacer)))))
(put-text-property start (point) 'vtable-column index)
- (when colors
+ (when column-colors
(add-face-text-property
start (point)
(list :background
- (elt colors (mod index (length colors)))))))))
+ (elt column-colors (mod index (length column-colors)))))))))
(cdr line))
(insert "\n")
- (put-text-property start (point) 'vtable-object (car line))))
+ (put-text-property start (point) 'vtable-object (car line))
+ (unless column-colors
+ (when-let ((row-colors (vtable-row-colors table)))
+ (add-face-text-property
+ start (point)
+ (list :background
+ (elt row-colors (mod line-number (length row-colors)))))))))
(defun vtable--cache-key ()
(cons (frame-terminal) (window-width)))