[LISP函数]：将表中相同的元素分组

eachy

2. 
   
3. (defun xdl-lst-getdups (lst / n nl same)
   
4.   (while lst
   
5.     (setq n (car lst))
   
6.     (if        (not nl)
   
7.       (setq nl (list (list n)))
   
8.       (if (setq same (assoc n nl))
   
9.         (setq nl (subst (append (list n) same) same nl))
   
10.         (setq nl (append (list (list n)) nl))
    
11.       )
    
12.     )
    
13.     (setq lst (cdr lst))
    
14.   )
    
15.   (reverse nl)
    
16. )

<br /> (defun xdl-lst-getdups (lst / n nl same)<br />   (while lst<br />     (setq n (car lst))<br />     (if        (not nl)<br />       (setq nl (list (list n)))<br />       (if (setq same (assoc n nl))<br />         (setq nl (subst (append (list n) same) same nl))<br />         (setq nl (append (list (list n)) nl))<br />       )<br />     )<br />     (setq lst (cdr lst))<br />   )<br />   (reverse nl)<br /> )

转换为元素、数量格式

2. 
   
3. (defun xdl-lst-getdup (lst)
   
4.   (mapcar '(lambda (x) (cons (caar x) (length x)))
   
5.           (xdl-lst-getdups lst)
   
6.   )
   
7. )

<br /> (defun xdl-lst-getdup (lst)<br />   (mapcar '(lambda (x) (cons (caar x) (length x)))<br />           (xdl-lst-getdups lst)<br />   )<br /> )

;;测试
_$ (xdl-lst-getdups '(1 2 3 4 1 1 1 1 1 1 5 5 5 55 5  6 7 8))
((1 1 1 1 1 1 1) (2) (3) (4) (5 5 5 5) (55) (6) (7) (8))
_$ (xdl-lst-getdups '(1 2 3 4 (1) (1) 1 1 1 1 5 5 5 55 5  6 7 8))
((1 1 1 1 1) (2) (3) (4) ((1) (1)) (5 5 5 5) (55) (6) (7) (8))
_$ (xdl-lst-getdup (xdl-lst-getdups '(1 2 3 4 (1) (1) 1 1 1 1 5 5 5 55 5  6 7 8)))
(((1 1 1 1 1) . 1) ((2) . 1) ((3) . 1) ((4) . 1) (((1) (1)) . 1) ((5 5 5 5) . 1) ((55) . 1) ((6) . 1) ((7) . 1) ((8) . 1))
_$ (xdl-lst-getdup (xdl-lst-getdups '(1 2 3 4 (1) (1) 1 1 1 1 5 5 5 55 5  6 7 8)))
((1 . 1) (2 . 1) (3 . 1) (4 . 1) ((1) . 1) (5 . 1) (55 . 1) (6 . 1) (7 . 1) (8 . 1))
_$

eachy

2. 
   
3. (defun xdl-lst-getdups (lst / n nl same)
   
4.   (while lst
   
5.     (if        (setq same (assoc (setq n (car lst)) nl))
   
6.       (setq nl (subst (append (list n) same) same nl))
   
7.       (setq nl (cons (list n) nl))
   
8.     )
   
9.     (setq lst (cdr lst))
   
10.   )
    
11.   (vl-remove-if '(lambda (x) (= (length x) 1)) (reverse nl))
    
12. )

<br /> (defun xdl-lst-getdups (lst / n nl same)<br />   (while lst<br />     (if        (setq same (assoc (setq n (car lst)) nl))<br />       (setq nl (subst (append (list n) same) same nl))<br />       (setq nl (cons (list n) nl))<br />     )<br />     (setq lst (cdr lst))<br />   )<br />   (vl-remove-if '(lambda (x) (= (length x) 1)) (reverse nl))<br /> )

aeo

2. 
   
3. ;;;统计个数.  
   
4. ;;;'("A""B""C""A""B""A")  --> '(("A" . 3)("B" . 2)("C" . 1"))
   
5. (defun test(lst / l new no)               
   
6. (foreach no lst
   
7.    (if(setq l(assoc no new))
   
8.       (setq new(subst (cons no(1+(cdr l)))l new))
   
9.       (setq new(cons(cons no 1)new))
   
10.     )
    
11. )new
    
12. )
    

<br /> ;;;统计个数.  <br /> ;;;'("A""B""C""A""B""A")  --> '(("A" . 3)("B" . 2)("C" . 1"))<br /> (defun test(lst / l new no)               <br /> (foreach no lst<br />    (if(setq l(assoc no new))<br />       (setq new(subst (cons no(1+(cdr l)))l new))<br />       (setq new(cons(cons no 1)new))<br />     )<br /> )new<br /> )<br />

有重复的:
(mapcar 'car (vl-remove-if '(lambda(x)(= (cdr x)1)) (test lst)))

cable2004

源码是好东西

lifei18

源码不错，写的好