From 9fd5ba552f32c79dda34ab687559f463978087cc Mon Sep 17 00:00:00 2001
From: Kinneyzhang <kinneyzhang666@gmail.com>
Date: Mon, 13 Oct 2025 00:15:18 +0800
Subject: [PATCH] first commit

---
 tp-tests-utils.el |  59 ++++++++++++
 tp-tests.el       |  84 +++++++++++++++++
 tp.el             | 231 ++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 374 insertions(+)
 create mode 100644 tp-tests-utils.el
 create mode 100644 tp-tests.el
 create mode 100644 tp.el

diff --git a/tp-tests-utils.el b/tp-tests-utils.el
new file mode 100644
index 0000000..7c484a3
--- /dev/null
+++ b/tp-tests-utils.el
@@ -0,0 +1,59 @@
+(defvar pop-buffer-insert-buffer
+  "*pop-buffer-insert*")
+
+(defvar pop-buffer-win-conf nil)
+
+(defun my-pop-to-buffer (buffer-or-name &optional action norecord)
+  (declare (indent defun))
+  (let ((buffer (pop-to-buffer buffer-or-name action norecord)))
+    (with-current-buffer buffer
+      (local-set-key "q" 'pop-buffer-quit))
+    buffer))
+
+(defun remove-from-list (list-var element)
+  (set list-var (delete element (symbol-value list-var))))
+
+(defun pop-buffer-quit ()
+  (interactive)
+  (let ((win-conf pop-buffer-win-conf))
+    (local-unset-key "q")
+    (setq-local pop-buffer-win-conf nil)
+    (remove-from-list 'margin-work-modes 'quick-buffer-mode)
+    (set-window-configuration win-conf)))
+
+(defmacro with-pop-buffer (buffer-or-name height &rest body)
+  (declare (indent defun))
+  `(let* ((win-conf (current-window-configuration))
+          (height ,height)
+          (buffer (my-pop-to-buffer ,buffer-or-name
+                    `(,@(if height
+                            `(display-buffer-at-bottom
+                              (cons window-height height))
+                          `(display-buffer-full-frame))))))
+     (add-to-list 'margin-work-modes 'quick-buffer-mode)
+     (with-current-buffer buffer
+       (setq major-mode 'quick-buffer-mode)
+       (setq-local pop-buffer-win-conf win-conf)
+       (let ((inhibit-read-only t))
+         (erase-buffer)
+         ,@body)
+       (read-only-mode 1))))
+
+(defun pop-buffer-insert (height &rest body)
+  (declare (indent defun))
+  (if (member pop-buffer-insert-buffer
+              (mapcar #'buffer-name (window-buffers)))
+      (let ((inhibit-read-only t))
+        (select-window (get-buffer-window
+                        pop-buffer-insert-buffer))
+        (erase-buffer)
+        (apply #'insert body))
+    (with-pop-buffer pop-buffer-insert-buffer height
+      (apply #'insert body))))
+
+(defmacro pop-buffer-do (height &rest body)
+  (declare (indent defun))
+  `(with-pop-buffer ,pop-buffer-insert-buffer ,height
+     ,@body))
+
+(provide 'tp-tests-utils)
diff --git a/tp-tests.el b/tp-tests.el
new file mode 100644
index 0000000..34b78e0
--- /dev/null
+++ b/tp-tests.el
@@ -0,0 +1,84 @@
+(require 'tp-tests-utils)
+
+;; tp-layer-alist
+;; tp-layer-groups
+
+(tp-layer-define 'test1
+  '(face link :foreground "orange"))
+
+(tp-layer-define 'test2
+  '(face link :foreground "cyan"))
+
+(tp-layer-group-define 'test-group
+  '(test1 display "this is top layer"
+          face (:background "red" :foreground "#000"))
+  '(test2 display "this is middle layer"
+          face (:background "green" :foreground "#000"))
+  '(test3 display "this is bottom layer"
+          face (:background "cyan" :foreground "#000")))
+
+(tp-layer-propertize "emacs" 'test1)
+(tp-layer-group-propertize "emacs" 'test-group)
+
+(defun tp-tests-layer-rotate (&optional btn)
+  (interactive)
+  (let ((inhibit-read-only t))
+    (save-excursion
+      (goto-char (point-min))
+      (tp-layer-rotate (line-beginning-position)
+                       (line-end-position)))))
+
+(pop-buffer-do nil
+  (insert (tp-layer-group-propertize "emacs" 'test-group)
+          "\n\n")
+  (insert-text-button
+   " eval (tp-tests-layer-rotate) "
+   'action 'tp-tests-layer-rotate
+   'face '(:box t)
+   'follow-link t))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(pop-buffer-insert nil
+  (propertize
+   " "
+   'display ""
+   'face '(:underline (:position t :color "grey")))
+  " "
+  (propertize
+   "hacking"
+   'face '(:foreground "cyan"))
+  " "
+  (propertize
+   "emacs"
+   'face '(:slant italic :background "orange")))
+
+(with-current-buffer pop-buffer-insert-buffer
+  (erase-buffer)
+  (tp-tests-run))
+
+(with-current-buffer pop-buffer-insert-buffer
+  (let ((inhibit-read-only 1))
+    ;; (tp-all (point-min) (point-max))
+    (tp-layer-set 'default (point-min) (point-max))
+    (tp-layer-push 1
+      (point-min) (point-max)
+      '( face (:background "green" :foreground "grey")
+         display (height 1.2)))
+    
+    (tp-layer-push 2
+      (point-min) (point-max)
+      '(face (:background "orange" :foreground "#000")))
+
+    (tp-layer-push 3
+      (point-min) (point-max)
+      '(face (:weight bold :background "SlateBlue2")))))
+
+(with-current-buffer pop-buffer-insert-buffer
+  (let ((inhibit-read-only 1))
+    ;; (tp-layer-demote (point-min) (point-max))
+    ;; (tp-layer-rotate (point-min) (point-max))
+    ;; (tp-layer-delete 2 (point-min) (point-max))
+    ;; (tp-layer-pin 1 (point-min) (point-max))
+    ;; (tp-layer-pin '3 1 16)
+    ))
diff --git a/tp.el b/tp.el
new file mode 100644
index 0000000..9c5de59
--- /dev/null
+++ b/tp.el
@@ -0,0 +1,231 @@
+;; 对 text properties 的封装
+;; elisp 原生的 text properties 函数的局限性
+;; https://github.com/emacsorphanage/ov
+
+(require 'dash)
+
+;;; tp layer
+
+(defun tp-top-layer-props (properties)
+  "获取最上面的属性层，也就是实际要渲染的层"
+  (if-let ((idx (-elem-index 'tp-layers properties)))
+      (-remove-at-indices (list idx (1+ idx)) properties)
+    properties))
+
+(defun tp-below-layers-props (properties)
+  "获取最上层以下的属性层列表"
+  (plist-get properties 'tp-layers))
+
+(defun tp-all (start end &optional object)
+  "获取 OBJECT 的 start 到 end 范围内文本的所有 text properties。
+OBJECT 可以为 buffer 或 string，nil 默认为当前 buffer。
+point 从 0 开始。"
+  (let ((object (or object (current-buffer))))
+    (cond
+     ((stringp object)
+      (object-intervals (substring object start end)))
+     ((bufferp object)
+      (with-current-buffer (get-buffer-create object)
+        (object-intervals (buffer-substring start end))))
+     (t (error "Invalid format of object: %S"
+               (type-of object))))))
+
+(defun tp-empty-p (object)
+  (null (object-intervals object)))
+
+(defun tp-intervals-map (function start end &optional object)
+  "处理 start，end 之间的所有 intervals 的文本属性
+function 的四个参数分别为:区间开始位置，区间结束位置，顶层属性和下层属性列表"
+  (remove
+   nil
+   (mapcar
+    (lambda (tp)
+      (let* ((interval-start (nth 0 tp)) ;; start from 0
+             (interval-end (nth 1 tp))
+             (interval-props (nth 2 tp))
+             (top-props (tp-top-layer-props interval-props))
+             (below-props-lst (tp-below-layers-props interval-props)))
+        (funcall function
+                 interval-start interval-end
+                 top-props below-props-lst)))
+    (tp-all start end object))))
+
+(defun tp-layer-props (name start end &optional object)
+  "返回 object 的 start 和 end 之间文本属性层为 name 的属性列表"
+  (tp-intervals-map
+   (lambda (i-start i-end top belows)
+     (when-let ((props (seq-find
+                        (lambda (props)
+                          (equal name (plist-get props 'tp-name)))
+                        (append (list top) belows))))
+       (list (+ start i-start) (+ start i-end) props)))
+   start end object))
+
+;; (defun tp-layers-names (start end &optional object)
+;;   "返回当前所有 layers 的名称"
+;;   (seq-uniq
+;;    (apply 'append
+;;           (tp-intervals-map
+;;            (lambda (i-start i-end top belows)
+;;              (remove nil (mapcar (lambda (props)
+;;                                    (plist-get props 'tp-name))
+;;                                  (append (list top) belows))))
+;;            start end object))))
+
+(defun tp-layer-set (name start end &optional object)
+  "将 object 的 start 和 end 之间的文本当前的属性层命名为 name"
+  (if (tp-empty-p object)
+      (add-text-properties
+       start end (list 'tp-name name) end object)
+    (tp-intervals-map
+     (lambda (i-start i-end top belows)
+       (set-text-properties
+        (+ start i-start) (+ start i-end)
+        (append (plist-put top 'tp-name name)
+                (list 'tp-layers belows))
+        object))
+     start end object))
+  object)
+
+(defun tp-layer-push (name start end properties &optional object)
+  "设置 properties 为最上面的 prop 层，name 是 layer 的名字"
+  ;; 当前顶层放到 tp-layers 开头，properties 设置为当前顶层。
+  ;; FIXME: 需要检查 name 是否已经存在，存在则报错
+  (declare (indent defun))
+  (when (tp-layer-props name start end object)
+    (error "Already exist layer named %S" name))
+  (if (tp-empty-p object)
+      (set-text-properties
+       start end (append properties (list 'tp-name name))
+       object)
+    (tp-intervals-map
+     (lambda (i-start i-end top belows)
+       (set-text-properties
+        (+ start i-start) (+ start i-end)
+        (append (append properties (list 'tp-name name))
+                (list 'tp-layers (append (list top) belows)))
+        object))
+     start end object))
+  object)
+
+(defun tp-layer-delete (name start end &optional object)
+  "移除 object 的 start 和 end 之间文本的名称为 name 的层"
+  ;; 当前顶层放到 tp-layers 开头，properties 设置为当前顶层。
+  ;; FIXME: 需要检查 name 是否已经存在，存在则报错
+  (declare (indent defun))
+  (tp-intervals-map
+   (lambda (i-start i-end top belows)
+     (set-text-properties
+      (+ start i-start) (+ start i-end)
+      ;; name 是顶层，删除该层后，下一层上移
+      (if (equal name (plist-get top 'tp-name))
+          (append (nth 0 belows)
+                  (list 'tp-layers (seq-drop belows 1)))
+        ;; name 不是顶层，直接删除
+        (append top
+                (list 'tp-layers
+                      (-remove (lambda (props)
+                                 (equal name (plist-get
+                                              props 'tp-name)))
+                               belows))))
+      object))
+   start end object)
+  nil)
+
+(defun tp-layer-rotate (start end &optional object)
+  "将 start 和 end 之间的顶层文本属性移到最后一层，相当于循环显示不同层。"
+  (tp-intervals-map
+   (lambda (i-start i-end top belows)
+     (set-text-properties
+      (+ start i-start) (+ start i-end)
+      (append (nth 0 belows)
+              (list 'tp-layers
+                    (append (seq-drop belows 1)
+                            (list top))))
+      object))
+   start end object)
+  nil)
+
+(defun tp-layer-pin (name start end &optional object)
+  "将 start 和 end 之间名称为 name 的层移动最上面。"
+  (unless (tp-layer-props name start end object)
+    (error "Doesn't exist a layer named %S" name))
+  (tp-intervals-map
+   (lambda (i-start i-end top belows)
+     ;; name layer 本身就位于最上层时，无需操作
+     (unless (equal (plist-get top 'tp-name) name)
+       (set-text-properties
+        (+ start i-start) (+ start i-end)
+        (let ((new-top
+               ;; 获取新的置顶层
+               (seq-find (lambda (props)
+                           (equal (plist-get props 'tp-name)
+                                  name))
+                         belows))
+              ;; 移除掉被置顶的层
+              (rest-belows
+               (-remove (lambda (props)
+                          (equal (plist-get props 'tp-name)
+                                 name))
+                        belows)))
+          (append new-top
+                  (list 'tp-layers
+                        (append (list top) rest-belows))))
+        object)))
+   start end object)
+  nil)
+
+;;; propertize string
+
+(defvar tp-layer-alist nil
+  "Alist 的每个元素是单个 layer")
+
+(defvar tp-layer-groups nil
+  "group 的每个元素是 layer 组，组中存储的是多个 layer")
+
+(defun tp-layer-define (name properties)
+  "定义一个名称为 name 的文本属性层，数据存放在 tp-layer-alist 中"
+  (declare (indent defun))
+  (if (assoc name tp-layer-alist)
+      (setf (cdr (assoc name tp-layer-alist)) properties)
+    (push (cons name properties) tp-layer-alist))
+  (assoc name tp-layer-alist))
+
+(defun tp-layer-group-define (name &rest layers)
+  "每个属性层在 tp-layer-alist 中，属性组指在 tp-layer-groups 中存储属性层的名称
+层级关系与layers定义顺序一致。最上面的定义表示顶层，渲染时会显示出来。"
+  (declare (indent defun))
+  (let ((layer-names
+         (nreverse
+          (mapcar (lambda (layer)
+                    (let ((layer-name (car layer)))
+                      (tp-layer-define layer-name (cdr layer))
+                      layer-name))
+                  layers))))
+    (if (assoc name tp-layer-groups)
+        (setf (cdr (assoc name tp-layer-groups)) layer-names)
+      (push (cons name layer-names) tp-layer-groups))))
+
+(defun tp-propertize (string properties &optional layer)
+  (declare (indent defun))
+  (let ((layer (or layer (org-id-uuid))))
+    (tp-layer-push layer
+      0 (length string) properties string)
+    string))
+
+(defun tp-layer-propertize (string layer)
+  (if-let ((layer-info (assoc layer tp-layer-alist)))
+      (tp-propertize string
+        (cdr layer-info) (car layer-info))
+    (error "layer %S doesn't exist!" layer)))
+
+(defun tp-layer-group-propertize (string layer-group)
+  (if-let* ((group-info (assoc layer-group tp-layer-groups))
+            (layers (cdr group-info)))
+      (progn
+        (dolist (layer layers)
+          (setq string (tp-layer-propertize string layer)))
+        string)
+    (error "layer group %S doesn't exist!" layer-group)))
+
+(provide 'tp)