Skip to content

Commit 03d6eb5

Browse files
GatsbyUSTCGatsbyUSTC
authored
[201_98] 实现shift+tab 反缩进，优化缩进能力 (#3101)
1 parent 33b4eca commit 03d6eb5

4 files changed

Lines changed: 354 additions & 77 deletions

File tree

‎TeXmacs/progs/generic/generic-edit.scm‎

Lines changed: 215 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -168,7 +168,9 @@
168168

169169
;; 辅助函数：定义 enumerate-tag-list
170170
(define (enumerate-tag-list)
171-
'(enumerate enumerate-1 enumerate-2 enumerate-3 enumerate-4))
171+
'(enumerate enumerate-numeric enumerate-roman
172+
enumerate-Roman enumerate-alpha enumerate-Alpha
173+
enumerate-circle enumerate-hanzi enumerate-numeric-paren))
172174

173175
;; 辅助函数：定义 itemize-tag-list
174176
(define (itemize-tag-list)
@@ -190,13 +192,10 @@
190192
(define (in-description-context?)
191193
(not (not (tree-search-upwards (focus-tree) (lambda (node) (tree-in? node (description-tag-list)))))))
192194

193-
;; 辅助函数：获取当前列表的类型
194-
(define (get-list-type)
195-
(cond
196-
((in-description-context?) 'description)
197-
((in-itemize-context?) 'itemize)
198-
((in-enumerate-context?) 'enumerate)
199-
(else #f)))
195+
;; 辅助函数：获取当前实际列表的精确标签，保留 itemize-dot 等变体样式
196+
(define (get-current-list-label item)
197+
(and-with list-node (tree-search-upwards item list-node?)
198+
(tree-label list-node)))
200199

201200
;; 辅助函数：查找包含 item 的 concat 包装和真正的 item list
202201
(define (find-item-wrapper-and-list item)
@@ -226,44 +225,223 @@
226225
(let ((item-index (tree-index item)))
227226
(tree-remove! item-list item-index 1))))
228227

228+
(define (list-item-node? t)
229+
(or (tree-is? t 'item)
230+
(tree-is? t 'item*)
231+
(and (tree-is? t 'concat)
232+
(> (tree-arity t) 0)
233+
(or (tree-is? (tree-ref t 0) 'item)
234+
(tree-is? (tree-ref t 0) 'item*)))))
235+
236+
(define (list-node? t)
237+
(and t (tree-in? t (list-tag-list))))
238+
239+
(define (list-family label)
240+
(cond ((in? label (enumerate-tag-list)) 'enumerate)
241+
((in? label (itemize-tag-list)) 'itemize)
242+
((in? label (description-tag-list)) 'description)
243+
(else label)))
244+
245+
(define (same-list-family? lhs rhs)
246+
(and lhs rhs (== (list-family lhs) (list-family rhs))))
247+
248+
(define (find-previous-item-index item-list start)
249+
(let loop ((i (- start 1)))
250+
(cond ((< i 0) #f)
251+
((list-item-node? (tree-ref item-list i)) i)
252+
(else (loop (- i 1))))))
253+
254+
(define (find-following-list-index item-list start end list-type)
255+
(let loop ((i (+ start 1)))
256+
(cond ((>= i end) #f)
257+
((and (list-node? (tree-ref item-list i))
258+
(same-list-family? (tree-label (tree-ref item-list i)) list-type))
259+
i)
260+
(else (loop (+ i 1))))))
261+
262+
(define (append-strees-to-document doc strees)
263+
(if (null? strees) doc
264+
(tree-insert doc (tree-arity doc) strees)))
265+
229266
;; 在有序和无序列表中实现缩进功能
230267
(tm-define (kbd-variant t forwards?)
231268
(:require
232-
(or
233-
;; 有序列表或者无序列表
234-
(and (or in-enumerate-context? in-itemize-context?) (tree-is? (focus-tree) 'item))
235-
;; 描述列表
236-
(and in-description-context? (tree-is? (focus-tree) 'item*))))
269+
(and forwards?
270+
(or
271+
;; 有序列表或者无序列表
272+
(and (or in-enumerate-context? in-itemize-context?) (tree-is? (focus-tree) 'item))
273+
;; 描述列表
274+
(and in-description-context? (tree-is? (focus-tree) 'item*)))))
237275

238276
(let ((item (focus-tree)))
239-
;; 步骤 1: 查找包装和列表
277+
;; 查找包装和列表
240278
(call-with-values (lambda () (find-item-wrapper-and-list item))
241279
(lambda (wrapper item-list)
242280
(if (and item item-list)
243-
(let ((item-index (if wrapper (tree-index wrapper) (tree-index item))))
281+
(let* ((item-index (if wrapper (tree-index wrapper) (tree-index item)))
282+
(list-type (list-family (or (get-current-list-label item) 'enumerate)))
283+
(item-stree (tree->stree (if wrapper wrapper item)))
284+
(next-index (+ item-index 1))
285+
(attached-sublist-idx
286+
(and (< next-index (tree-arity item-list))
287+
(let ((next-node (tree-ref item-list next-index)))
288+
;; 当前 item 后面如果紧跟同一大类的子列表，缩进时一并并入目标子列表。
289+
(and (list-node? next-node)
290+
(same-list-family? (tree-label next-node) list-type)
291+
next-index)))))
244292
(if (> item-index 0)
245-
(let ((prev-item (tree-ref item-list (- item-index 1))))
246-
;; 步骤 2: 提取内容
247-
(let ((item-content (extract-item-content wrapper)))
248-
;; 步骤 3: 创建子列表并移动内容
249-
(tree-go-to prev-item :end)
250-
(insert-return)
251-
(let ((list-type (get-list-type)))
252-
(if list-type
253-
(make-tmlist list-type)
254-
(make-tmlist 'enumerate))) ; 默认使用有序列表
255-
;; 步骤4：拷贝内容
256-
(if item-content
257-
(let ((new-item (focus-tree))
258-
(list-type (get-list-type)))
259-
260-
(let ((content-stree (tree->stree item-content)))
261-
(if (eq? list-type 'description)
262-
(tree-set! new-item `(concat (item*), content-stree))
263-
(tree-set! new-item `(concat (item), content-stree)))
264-
(tree-go-to new-item))))
265-
;; 步骤 5: 从原列表中移除
266-
(remove-item-from-list item wrapper item-list))))))))))
293+
(let* ((prev-item-index (find-previous-item-index item-list item-index))
294+
(target-sublist-idx
295+
(and prev-item-index
296+
;; 优先复用前一个 item 已有的同一大类子列表，避免制造相邻碎片列表。
297+
(find-following-list-index item-list prev-item-index
298+
item-index list-type))))
299+
(when prev-item-index
300+
;; 当前一个 item 还没有子列表时，才在当前 item 前插入一个空子列表。
301+
(when (not target-sublist-idx)
302+
(set! item-list
303+
(tree-insert item-list item-index
304+
(list `(,list-type (document)))))
305+
(set! target-sublist-idx item-index)
306+
(set! item-index (+ item-index 1))
307+
;; 新插入的空子列表会让原 item 和其后置子列表整体右移一位。
308+
(if attached-sublist-idx
309+
(set! attached-sublist-idx (+ attached-sublist-idx 1))))
310+
311+
(let* ((target-sublist (tree-ref item-list target-sublist-idx))
312+
(target-doc (tree-ref target-sublist 0))
313+
(target-pos (tree-arity target-doc))
314+
(attached-items
315+
(if attached-sublist-idx
316+
(map (lambda (i)
317+
(tree->stree
318+
(tree-copy
319+
(tree-ref (tree-ref (tree-ref item-list attached-sublist-idx) 0) i))))
320+
(iota (tree-arity (tree-ref (tree-ref item-list attached-sublist-idx) 0))))
321+
'())))
322+
;; 目标子列表依次接收：当前 item，以及它后面原来挂着的同类型子列表内容。
323+
(set! target-doc
324+
(append-strees-to-document target-doc
325+
(append (list item-stree) attached-items)))
326+
;; 从右往左删除，避免索引漂移。
327+
(when attached-sublist-idx
328+
(set! item-list (tree-remove! item-list attached-sublist-idx 1)))
329+
(set! item-list (tree-remove! item-list item-index 1))
330+
;; concat 包装的 item 需要落到第 0 个子元素末尾，普通 item 直接定位。
331+
(let ((moved-item (tree-ref target-doc target-pos)))
332+
(if (tree-is? moved-item 'concat)
333+
(tree-go-to moved-item 0 :end)
334+
(tree-go-to target-doc target-pos :end)))))))))))))
335+
336+
;; 在有序和无序列表中实现反缩进功能
337+
;;
338+
;; 处理逻辑：
339+
;; 当用户按 Shift+Tab 时，将当前 item 从当前子列表中移出到外层列表。
340+
;; 如果当前列表已经是最外层列表，则不再继续反缩进。
341+
;;
342+
;; 两种 Case：
343+
;; 1. NOT first item: 当前 item 前面还有其他 items
344+
;; - 保留原 sublist（因为前面还有 items）
345+
;; - 从当前 sublist 的 document 中移除当前 item 和后续 items
346+
;; - 在 parent-list 中 sublist 之后插入当前 item
347+
;; - 如有后续 items，在当前 item 后面重建一个同类型 sublist
348+
;;
349+
;; 2. FIRST item: 当前 item 是第一个，后面可能有 items
350+
;; - 从当前 sublist 的 document 中移除当前 item（保留后续 items）
351+
;; - 从 parent-list 中移除整个 sublist
352+
;; - 在 parent-list 中原 sublist 位置插入当前 item
353+
;; - 如有后续 items，在当前 item 后面重建一个同类型 sublist
354+
;;
355+
(tm-define (kbd-variant t forwards?)
356+
(:require
357+
(and (not forwards?)
358+
(or
359+
(and (or in-enumerate-context? in-itemize-context?) (tree-is? (focus-tree) 'item))
360+
(and in-description-context? (tree-is? (focus-tree) 'item*)))))
361+
362+
(let* ((item (focus-tree))
363+
(item-stree (tree->stree item))
364+
(wrapper #f)
365+
(doc (tree-outer item)))
366+
367+
;; 处理 concat 包装
368+
(when (tree-is? doc 'concat)
369+
(set! wrapper doc)
370+
(set! doc (tree-outer wrapper))
371+
(set! item-stree (tree->stree wrapper)))
372+
373+
;; 仅在 item 直接位于列表 document 中时才执行反缩进。
374+
(when (tree-is? doc 'document)
375+
(let* ((sublist (tree-outer doc))
376+
(parent-list (if sublist (tree-outer sublist) #f))
377+
;; 只有在当前子列表外面还能找到另一层列表时，才允许继续反缩进；
378+
;; 这样最外层列表会直接止住。
379+
(outer-list (and parent-list
380+
(tree-search-upwards parent-list list-node?))))
381+
382+
(when (and parent-list outer-list)
383+
(let* ((sublist-idx (tree-index sublist))
384+
(doc-arity (tree-arity doc))
385+
(item-idx (if wrapper (tree-index wrapper) (tree-index item)))
386+
(items-before-count item-idx)
387+
(items-after-count (- doc-arity item-idx 1)))
388+
389+
;; 先保存当前 item 后面的所有兄弟节点，后面需要重建 trailing sublist。
390+
(with items-after-stree
391+
(if (> items-after-count 0)
392+
(map (lambda (i)
393+
(tree->stree (tree-copy (tree-ref doc (+ item-idx 1 i)))))
394+
(iota items-after-count))
395+
'())
396+
397+
;; 两个 case 都会得到同样的结果：更新后的 parent-list 和插入位置。
398+
(let* ((current-doc (tree-ref sublist 0))
399+
(current-parent (tree-outer sublist))
400+
(item-insert-pos #f))
401+
402+
;; 先处理“原 sublist 要保留还是删除”这部分差异。
403+
(if (> items-before-count 0)
404+
;; Case 1: 不是第一个 item，保留 sublist
405+
(begin
406+
;; 从 doc 中移除当前 item 和后续 items
407+
(let loop ((i (- doc-arity 1))
408+
(cd current-doc))
409+
(when (>= i item-idx)
410+
(set! cd (tree-remove! cd i 1))
411+
(loop (- i 1) cd)))
412+
;; 重新获取 current-doc（修改后）
413+
(set! current-doc (tree-ref sublist 0))
414+
;; item 插入位置：sublist 之后
415+
(set! item-insert-pos (+ sublist-idx 1)))
416+
417+
;; Case 2: 是第一个 item，删除 sublist
418+
(begin
419+
;; 从 doc 中移除当前 item
420+
(set! current-doc (tree-remove! current-doc item-idx 1))
421+
;; 从 parent-list 中移除 sublist
422+
(set! current-parent (tree-remove! current-parent sublist-idx 1))
423+
;; item 插入位置：原 sublist 位置
424+
(set! item-insert-pos sublist-idx)))
425+
426+
;; 共同逻辑：在 parent-list 中插入当前 item
427+
(set! current-parent (tree-insert current-parent item-insert-pos (list item-stree)))
428+
429+
;; 如有后续 items，则在当前 item 后面重建一个同类型 sublist。
430+
(when (> (length items-after-stree) 0)
431+
(let ((new-sublist-stree `(,(tree-label sublist) (document ,@items-after-stree)))
432+
(sublist-pos (+ item-insert-pos 1)))
433+
(set! current-parent (tree-insert current-parent sublist-pos (list new-sublist-stree)))))
434+
435+
;; 共同逻辑：移动光标到新插入的 item
436+
(with moved-item (tree-ref current-parent item-insert-pos)
437+
;; 根据 moved-item 类型决定光标位置
438+
(if (tree-is? moved-item 'concat)
439+
;; concat 包装：定位到第0个子元素（document）的结束位置
440+
(tree-go-to moved-item 0 :end)
441+
;; item: 从 parent 定位
442+
(begin
443+
(tree-go-to current-parent item-insert-pos :end))))))))))))
444+
267445

268446
(tm-define (kbd-variant t forwards?)
269447
(:require (and (tree-in? t '(label reference pageref eqref smart-ref))

‎TeXmacs/progs/utils/library/tree.scm‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,8 @@
2525
(tm-define (tree-insert t pos x)
2626
(cond ((string? x) (tree-var-insert t pos x))
2727
((list? x) (tree-var-insert t pos (cons 'tuple x)))
28-
(else (texmacs-error "tree-insert" "~S is not a string or a list" x))))
28+
((tree? x) (tree-var-insert t pos x))
29+
(else (texmacs-error "tree-insert" "~S is not a string, list, or tree" x))))
2930

3031
(tm-define tree-insert! tree-insert)
3132
(tm-define tree-remove! tree-remove)

‎TeXmacs/tests/tmu/201_98.tmu‎

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
<TMU|<tuple|1.1.0|2026.2.1-rc5>>
2+
3+
<style|<tuple|generic|chinese|table-captions-above|number-europe|preview-ref>>
4+
5+
<\body>
6+
<\enumerate>
7+
<item>
8+
9+
<item>
10+
11+
<\enumerate>
12+
<item>
13+
14+
<item>
15+
16+
<item>
17+
18+
<item>
19+
20+
<item>
21+
22+
<item>
23+
24+
<\enumerate>
25+
<item>
26+
27+
<item>
28+
29+
<item>sadf
30+
</enumerate>
31+
32+
<item>
33+
34+
<item>
35+
36+
<item>asfsad
37+
38+
<item>
39+
40+
<item>
41+
</enumerate>
42+
43+
<item>
44+
45+
<item>
46+
</enumerate>
47+
</body>
48+
49+
<\initial>
50+
<\collection>
51+
<associate|page-medium|paper>
52+
<associate|page-screen-margin|false>
53+
</collection>
54+
</initial>

0 commit comments

Comments
 (0)