又遇到一个表处理难题，请高手解决。顺带学习学习。

`中微子

想把其中连续而且颜色一样的线组合成一条线。
(setq waco1 '((0 1 1) (1 1 1) (3 2 2) (5 3 3) (9 1 4) (10 2 4) (12 1 5)))
如图：说明(12 1 5) 12是开始距离，1是线长，5是颜色
输出应该是((0 2 1) (3 2 2) (5 3 3) (9 3 4) (12 1 5))
下面的我写的，几乎成功，但最后一组没法加进去。（如果最后一组线和前面线是连续的颜色也一样就不需要）
(defun c:tt ( / d e waco waco1)
  (setq waco1 '((0 1 1) (1 1 1) (3 2 2) (5 3 3) (9 1 4) (10 2 4) (12 1 5)))
  (setq d 1)
  (setq e (nth (- d 1) waco1))
  (while (<= d (- (length waco1) 1))
   
    (if (and (= (+ (car e) (cadr e)) (car (nth d waco1))) (= (caddr e) (caddr (nth d waco1))))
      (progn
        (setq e (list (car e) (+ (cadr e) (cadr (nth d waco1))) (caddr e)))
       
        (setq waco (cons e waco))
        )
      (progn
        (setq waco (cons e waco))
        (setq e (nth d waco1))
        )
      )
      (setq d (+ d 1))
    )
  (setq waco (vl-sort waco '(lambda (s1 s2)(< (car s1) (car s2)))))
  (print waco)

  (princ)
  )
先谢谢各位大神！代码写得又长又烂，请多多指教。

gaics

保留完全相同的元素

2. (defun c:t8 (/ d e e2 waco i)
   
3.   (setq waco '((0 1 1)(1 1 1)(3 2 2)(5 3 3)(9 1 4)(10 2 4)(12 1 5)))
   
4.   (setq waco (vl-sort waco '(lambda (s1 s2) (< (car s1) (car s2)))))
   
5.   (setq d 0)
   
6.   (while (< d (length waco))
   
7.     (setq e (nth d waco))
   
8.     (setq i 0)
   
9.     (while (< i (length waco))
   
10.       (if (and (= (+ (car e) (cadr e)) (car (nth (+ d i 1) waco)))
    
11.          (= (caddr e) (caddr (nth (+ d i 1) waco)))
    
12.     )
    
13.   (progn
    
14.     (setq e2 (list (car e)(+ (cadr e)(cadr (nth (+ d i 1) waco)))(caddr e)))
    
15.     ;;(setq waco (subst e2 e (vl-remove (nth (+ d i 1) waco) waco)))
    
16.     (setq waco (subst e2 e (BF-List-RemoveIndex waco (+ d i 1))))
    
17.     (setq e e2)
    
18.   )
    
19.   (setq i (1+ i))
    
20.       )
    
21.     )
    
22.     (setq d (1+ d))
    
23.   )
    
24.   (print waco)
    
25.   (setq waco (vl-sort waco '(lambda (s1 s2) (< (car s1) (car s2)))))
    
26.   (princ)
    
27. )
    
28. (defun BF-List-RemoveIndex (lst index / i)
    
29.   (setq i -1)
    
30.   (vl-remove-if '(lambda (x) (= (setq i (1+ i)) index)) lst)
    
31. )

(defun c:t8 (/ d e e2 waco i)<br />   (setq waco '((0 1 1)(1 1 1)(3 2 2)(5 3 3)(9 1 4)(10 2 4)(12 1 5)))<br />   (setq waco (vl-sort waco '(lambda (s1 s2) (< (car s1) (car s2)))))<br />   (setq d 0)<br />   (while (< d (length waco))<br />     (setq e (nth d waco))<br />     (setq i 0)<br />     (while (< i (length waco))<br />       (if (and (= (+ (car e) (cadr e)) (car (nth (+ d i 1) waco)))<br />          (= (caddr e) (caddr (nth (+ d i 1) waco)))<br />     )<br />   (progn<br />     (setq e2 (list (car e)(+ (cadr e)(cadr (nth (+ d i 1) waco)))(caddr e)))<br />     ;;(setq waco (subst e2 e (vl-remove (nth (+ d i 1) waco) waco)))<br />     (setq waco (subst e2 e (BF-List-RemoveIndex waco (+ d i 1))))<br />     (setq e e2)<br />   )<br />   (setq i (1+ i))<br />       )<br />     )<br />     (setq d (1+ d))<br />   )<br />   (print waco)<br />   (setq waco (vl-sort waco '(lambda (s1 s2) (< (car s1) (car s2)))))<br />   (princ)<br /> )<br /> (defun BF-List-RemoveIndex (lst index / i)<br />   (setq i -1)<br />   (vl-remove-if '(lambda (x) (= (setq i (1+ i)) index)) lst)<br /> )

vitalgg

1. (setq waco1
   
2. '((0 468.548 1) (468.548 1332.85 1) (3041.5 675.413 4) (5396.91 547.939 3) (5944.85 360.787 3) (7145.64 278.132 3) (7423.77 991.957 3) (8415.73 468.926 4)))
   
3. (princ "原表:")(princ waco1)
   
4. ;; 按色号排序并分组
   
5. (setq waco1 (vl-sort
   
6.               waco1
   
7.               '(lambda (x y)
   
8.                  (<
   
9.                    (last x)
   
10.                    (last y)))))
    
11. (setq waco1 (list:group-by
    
12.               waco1
    
13.               '(lambda (x y)
    
14.                  (=
    
15.                    (last x)
    
16.                    (last y)))))
    
17. ;; 组内起点从小到大排序
    
18. (setq waco1 (mapcar
    
19.               '(lambda (x)
    
20.                  (vl-sort
    
21.                    x
    
22.                    '(lambda (m n)
    
23.                       (< (car m) (car n)))))
    
24.               waco1))
    
25. ;; (princ "\n排序表:")(princ waco1)
    
26. 
    
27. ;; 合并同色且连续的，即前一个的起点+长度 >= 紧临表的起点
    
28. (defun join-line (lst / res fuzz)
    
29.   (setq fuzz 0.01)
    
30.   (setq res (cons (car lst) nil))
    
31.   (while (setq lst (cdr lst))
    
32.     (if
    
33.       (and
    
34.         (setq f (car res))
    
35.         (>= (+ (+ (car f) (cadr f)) fuzz) (caar lst)))
    
36.       (setq res (cons
    
37.                   (list
    
38.                     (caar res)
    
39.                     (max
    
40.                       (+ (cadar lst) (- (caar lst) (caar res)))
    
41.                       (cadar res))
    
42.                     (last (car res)))
    
43.                   (cdr res)))
    
44.       (setq res (cons (car lst) res))))
    
45.   (reverse res)
    
46. )
    
47. (princ "\n结果:")(princ (apply 'append (mapcar 'join-line waco1)))
    
48. (princ)

(setq waco1 <br /> '((0 468.548 1) (468.548 1332.85 1) (3041.5 675.413 4) (5396.91 547.939 3) (5944.85 360.787 3) (7145.64 278.132 3) (7423.77 991.957 3) (8415.73 468.926 4)))<br /> (princ "原表:")(princ waco1)<br /> ;; 按色号排序并分组<br /> (setq waco1 (vl-sort <br />               waco1<br />               '(lambda (x y) <br />                  (< <br />                    (last x)<br />                    (last y)))))<br /> (setq waco1 (list:group-by <br />               waco1<br />               '(lambda (x y) <br />                  (= <br />                    (last x)<br />                    (last y)))))<br /> ;; 组内起点从小到大排序<br /> (setq waco1 (mapcar <br />               '(lambda (x) <br />                  (vl-sort <br />                    x<br />                    '(lambda (m n) <br />                       (< (car m) (car n)))))<br />               waco1))<br /> ;; (princ "\n排序表:")(princ waco1)<br /> <br /> ;; 合并同色且连续的，即前一个的起点+长度 >= 紧临表的起点<br /> (defun join-line (lst / res fuzz) <br />   (setq fuzz 0.01)<br />   (setq res (cons (car lst) nil))<br />   (while (setq lst (cdr lst)) <br />     (if <br />       (and <br />         (setq f (car res))<br />         (>= (+ (+ (car f) (cadr f)) fuzz) (caar lst)))<br />       (setq res (cons <br />                   (list <br />                     (caar res)<br />                     (max <br />                       (+ (cadar lst) (- (caar lst) (caar res)))<br />                       (cadar res))<br />                     (last (car res)))<br />                   (cdr res)))<br />       (setq res (cons (car lst) res))))<br />   (reverse res)<br /> )<br /> (princ "\n结果:")(princ (apply 'append (mapcar 'join-line waco1)))<br /> (princ)

非得有现成的函数才会用容差吗？
(>= (+ (+ (car f) (cadr f)) fuzz) (caar lst)))

vitalgg

1. (setq waco1 '((0 1 1) (1 1 1) (3 2 2) (5 3 3) (9 1 4) (10 2 4) (12 1 5)))
   
2. (princ "原表:")(princ waco1)
   
3. ;; 按色号排序并分组
   
4. (setq waco1 (vl-sort
   
5.               waco1
   
6.               '(lambda (x y)
   
7.                  (<
   
8.                    (last x)
   
9.                    (last y)))))
   
10. (setq waco1 (list:group-by
    
11.               waco1
    
12.               '(lambda (x y)
    
13.                  (=
    
14.                    (last x)
    
15.                    (last y)))))
    
16. ;; 组内起点从小到大排序
    
17. (setq waco1 (mapcar
    
18.               '(lambda (x)
    
19.                  (vl-sort
    
20.                    x
    
21.                    '(lambda (m n)
    
22.                       (< (car m) (car n)))))
    
23.               waco1))
    
24. ;; 合并同色且连续的，即前一个的起点+长度 >= 紧临表的起点
    
25. (defun join-line (lst / res)
    
26.   (setq res (cons (car lst) nil))
    
27.   (while (setq lst (cdr lst))
    
28.     (if
    
29.       (and
    
30.         (setq f (car res))
    
31.         (>= (+ (car f) (cadr f)) (caar lst)))
    
32.       (setq res (cons
    
33.                   (list
    
34.                     (caar res)
    
35.                     (max
    
36.                       (+ (cadar lst) (- (caar lst) (caar res)))
    
37.                       (cadar res))
    
38.                     (last (car res)))
    
39.                   (cdr res)))
    
40.       (setq res (cons (car lst) res))))
    
41.   (reverse res)
    
42. )
    
43. (princ "\n结果:")(princ (apply 'append (mapcar 'join-line waco1)))
    
44. (princ)

(setq waco1 '((0 1 1) (1 1 1) (3 2 2) (5 3 3) (9 1 4) (10 2 4) (12 1 5)))<br /> (princ "原表:")(princ waco1)<br /> ;; 按色号排序并分组<br /> (setq waco1 (vl-sort <br />               waco1<br />               '(lambda (x y) <br />                  (< <br />                    (last x)<br />                    (last y)))))<br /> (setq waco1 (list:group-by <br />               waco1<br />               '(lambda (x y) <br />                  (= <br />                    (last x)<br />                    (last y)))))<br /> ;; 组内起点从小到大排序<br /> (setq waco1 (mapcar <br />               '(lambda (x) <br />                  (vl-sort <br />                    x<br />                    '(lambda (m n) <br />                       (< (car m) (car n)))))<br />               waco1))<br /> ;; 合并同色且连续的，即前一个的起点+长度 >= 紧临表的起点<br /> (defun join-line (lst / res) <br />   (setq res (cons (car lst) nil))<br />   (while (setq lst (cdr lst)) <br />     (if <br />       (and <br />         (setq f (car res))<br />         (>= (+ (car f) (cadr f)) (caar lst)))<br />       (setq res (cons <br />                   (list <br />                     (caar res)<br />                     (max <br />                       (+ (cadar lst) (- (caar lst) (caar res)))<br />                       (cadar res))<br />                     (last (car res)))<br />                   (cdr res)))<br />       (setq res (cons (car lst) res))))<br />   (reverse res)<br /> )<br /> (princ "\n结果:")(princ (apply 'append (mapcar 'join-line waco1)))<br /> (princ)

gaics

(setq d 1)，最后已经超出范围了

`中微子

vitalgg 发表于 2023-8-15 08:27

大神，这里出错了。抱歉新手不会改。
错误: no function definition: LIST:GROUP-BY

你的是一种全新的思路，但我没看懂，不好意思。

vitalgg

看注释了解思路就行。
带冒号的都是@lisp函数库中的函数。
这个支持重叠的线。不知道你的需求中有没有重叠的情况。

@lisp函数库全面开源
https://gitee.com/atlisp/atlisp-lib

https://gitee.com/atlisp/atlisp- ... c/list/group-by.lsp

`中微子

vitalgg 发表于 2023-8-15 10:41
看注释了解思路就行。
带冒号的都是@lisp函数库中的函数。
这个支持重叠的线。不知道你的需求中有没有重 ...

非常感谢！学习了。运行成功。谢谢！！

gaics

我也来试一下

2. (defun c:t7 (/ d e e2 waco i)
   
3.   (setq waco '((0 1 1)(1 1 1)(3 2 2)(5 3 3)(9 1 4)(10 2 4)(12 1 5)))
   
4.   (setq waco (vl-sort waco '(lambda (s1 s2) (< (car s1) (car s2)))))
   
5.   (setq d 0)
   
6.   (while (< d (length waco))
   
7.     (setq e (nth d waco))
   
8.     (setq i 0)
   
9.     (while (< i (length waco))
   
10.       (if (and (= (+ (car e) (cadr e)) (car (nth (+ d i 1) waco)))
    
11.          (= (caddr e) (caddr (nth (+ d i 1) waco)))
    
12.     )
    
13.   (progn
    
14.     (setq e2 (list (car e)(+ (cadr e)(cadr (nth (+ d i 1) waco)))(caddr e)))
    
15.     (setq waco (subst e2 e (vl-remove (nth (+ d i 1) waco) waco)))
    
16.     (setq e e2)
    
17.   )
    
18.   (setq i (1+ i))
    
19.       )
    
20.     )
    
21.     (setq d (1+ d))
    
22.   )
    
23.   (print waco)
    
24.   (setq waco (vl-sort waco '(lambda (s1 s2) (< (car s1) (car s2)))))
    
25.   (princ)
    
26. )

(defun c:t7 (/ d e e2 waco i)<br />   (setq waco '((0 1 1)(1 1 1)(3 2 2)(5 3 3)(9 1 4)(10 2 4)(12 1 5)))<br />   (setq waco (vl-sort waco '(lambda (s1 s2) (< (car s1) (car s2)))))<br />   (setq d 0)<br />   (while (< d (length waco))<br />     (setq e (nth d waco))<br />     (setq i 0)<br />     (while (< i (length waco))<br />       (if (and (= (+ (car e) (cadr e)) (car (nth (+ d i 1) waco)))<br />          (= (caddr e) (caddr (nth (+ d i 1) waco)))<br />     )<br />   (progn<br />     (setq e2 (list (car e)(+ (cadr e)(cadr (nth (+ d i 1) waco)))(caddr e)))<br />     (setq waco (subst e2 e (vl-remove (nth (+ d i 1) waco) waco)))<br />     (setq e e2)<br />   )<br />   (setq i (1+ i))<br />       )<br />     )<br />     (setq d (1+ d))<br />   )<br />   (print waco)<br />   (setq waco (vl-sort waco '(lambda (s1 s2) (< (car s1) (car s2)))))<br />   (princ)<br /> )

`中微子

vitalgg 发表于 2023-8-15 10:41
看注释了解思路就行。
带冒号的都是@lisp函数库中的函数。
这个支持重叠的线。不知道你的需求中有没有重 ...

刚试了，希望能加入一点容差进去。把表换成((0 468.548 1) (468.548 1332.85 1) (3041.5 675.413 4) (5396.91 547.939 3) (5944.85 360.787 3) (7145.64 278.132 3) (7423.77 991.957 3) (8415.73 468.926 4))
输出应该是：((0 1801.4 1) (3041.5 675.413 4) (5396.91 908.726 3) (7145.64 1270.09 3))(8415.73 468.926 4)
我把IF条件改成(>= (atof(rtos(+ (car f) (cadr f))2 2)) (atof(rtos(caar lst)2 2)))只保留后二位还是不行
输出是((0 1801.4 1) (3041.5 675.413 4) (5396.91 908.727 3) (7423.77 991.957 3) (8415.73 468.926 4))。
这一项是差的(7423.77 991.957 3)

`中微子

gaics 发表于 2023-8-15 13:24
保留完全相同的元素

请看9楼，也有同样的容差问题。求解决。辛苦了！！