学习 lisp 递归

q3_2006

lanjqka 发表于 2014-1-11 12:46
;;ourappend;;ourlist

明经群里别人的问题

'((6 7) (4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8))
->
(((6 7) (7 8) (6 5) (8 "B") ("B" 10)) ((4 "A") ("A" 9) (1 2) (2 3) (3 4)))

只要x或y有相等的情况就分为同一组...
感觉用递归写比较方便...但我还是写不好...拜托大师抽空指点下...谢谢了!

lanjqka

希望对你有所帮助

2. ;|
   
3. _$$ (-f1 '(6 7) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))
   
4. ((6 5) (7 8))
   
5. |;
   
6. (defun -f1 (at lst)
   
7.   (if (null at)
   
8.     nil
   
9.     (if        (null lst)
   
10.       nil
    
11.       (if (or (equal (car at) (caar lst))
    
12.               (equal (cadr at) (cadar lst))
    
13.               (equal (car at) (cadar lst))
    
14.               (equal (cadr at) (caar lst)))
    
15.         (cons (car lst) (-f1 at (cdr lst)))
    
16.         (-f1 at (cdr lst))))))
    
17. (defun -f12 (at lst) (vl-remove-if-not '(lambda (x) (or (member (car at) x) (member (cadr at) x))) lst))
    
18. ;|
    
19. _$$ (-f2 '(6 7) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))
    
20. ((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10))
    
21. |;
    
22. (defun -f2 (at lst)
    
23.   (if (null at)
    
24.     (list lst)
    
25.     (if        (null lst)
    
26.       nil
    
27.       (if (or (equal (car at) (caar lst))
    
28.               (equal (cadr at) (cadar lst))
    
29.               (equal (car at) (cadar lst))
    
30.               (equal (cadr at) (caar lst)))
    
31.         (-f2 at (cdr lst))
    
32.         (cons (car lst) (-f2 at (cdr lst)))))))
    
33. (defun -f22 (at lst) (vl-remove-if '(lambda (x) (or (member (car at) x) (member (cadr at) x))) lst))
    
34. ;|
    
35. _$$ (-f3 '((6 7) (6 5) (7 8)) '((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10)))
    
36. ((8 "B"))
    
37. |;
    
38. (defun -f3 (atl lst)
    
39.   (if (null atl)
    
40.     nil
    
41.     (if        (null (-f1 (car atl) lst))
    
42.       (-f3 (cdr atl) (-f2 (car atl) lst))
    
43.       (append (-f1 (car atl) lst) (-f3 (cdr atl) (-f2 (car atl) lst))))))
    
44. (defun -f32 (atl lst) (apply 'append (mapcar '(lambda (x) (-f12 x lst)) atl)))
    
45. ;|
    
46. _$$ (-f4 '((6 7) (6 5) (7 8)) '((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10)))
    
47. ((4 "A") (1 2) (3 4) (2 3) ("A" 9) ("B" 10))
    
48. |;
    
49. (defun -f4 (atl lst)
    
50.   (if (null atl)
    
51.     (list lst)
    
52.     (if        (null lst)
    
53.       nil
    
54.       (if (null (-f1 (car lst) atl))
    
55.         (cons (car lst) (-f4 atl (cdr lst)))
    
56.         (-f4 atl (cdr lst))))))
    
57. (defun -f42 (atl lst / tmp ret)
    
58.   (setq tmp (-f32 atl lst))
    
59.   (while lst
    
60.     (if (null (member (car lst) tmp))
    
61.       (setq ret (append ret (list (car lst)))))
    
62.     (setq lst (cdr lst)))
    
63.   ret
    
64.   )
    
65. ;|
    
66. _$$ (-f5 '((6 7)) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))
    
67. (((6 7) (6 5) (7 8) (8 "B") ("B" 10)) ((4 "A") (1 2) (3 4) (2 3) ("A" 9)))
    
68. _$$ (-f5 '((4 "A")) '((1 2) (3 4) (2 3) ("A" 9)))
    
69. (((4 "A") (3 4) ("A" 9) (2 3) (1 2)))
    
70. |;
    
71. (defun -f5 (l1 l2)
    
72.   (if (null l2)
    
73.     (list l1)
    
74.     (if        (null (-f3 l1 l2))
    
75.       (list l1 l2)
    
76.       (-f5 (append l1 (-f3 l1 l2)) (-f4 l1 l2)))))
    
77. (defun -f52  (l1 l2 / tmp)
    
78.   (while (setq tmp (-f32 l1 l2))
    
79.     (setq l2 (-f42 l1 l2)
    
80.           l1 (append l1 tmp)))
    
81.   (if (null l2)
    
82.     (list l1)
    
83.     (list l1 l2)))
    
84. ;|
    
85. _$$ (-f6 '((6 7) (4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))
    
86. (((6 7) (6 5) (7 8) (8 "B") ("B" 10)) ((4 "A") (3 4) ("A" 9) (2 3) (1 2)))
    
87. |;
    
88. (defun -f6 (lst / tmp)
    
89.   (if (null (cdr lst))
    
90.     (list lst)
    
91.     (progn (setq tmp (-f5 (list (car lst)) (cdr lst)))
    
92.            (if (null (cdr tmp))
    
93.              tmp
    
94.              (append (list (car tmp)) (-f6 (cadr tmp)))))))
    
95. (defun -f62  (lst / tmp ret)
    
96.   (while (and lst (setq tmp (-f52 (list (car lst)) (cdr lst))))
    
97.     (setq ret (append ret (list (car tmp)))
    
98.           lst (cadr tmp)))
    
99.   ret)
    

;|<br /> _$$ (-f1 '(6 7) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))<br /> ((6 5) (7 8))<br /> |;<br /> (defun -f1 (at lst)<br />   (if (null at)<br />     nil<br />     (if        (null lst)<br />       nil<br />       (if (or (equal (car at) (caar lst))<br />               (equal (cadr at) (cadar lst))<br />               (equal (car at) (cadar lst))<br />               (equal (cadr at) (caar lst)))<br />         (cons (car lst) (-f1 at (cdr lst)))<br />         (-f1 at (cdr lst))))))<br /> (defun -f12 (at lst) (vl-remove-if-not '(lambda (x) (or (member (car at) x) (member (cadr at) x))) lst))<br /> ;|<br /> _$$ (-f2 '(6 7) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))<br /> ((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10))<br /> |;<br /> (defun -f2 (at lst)<br />   (if (null at)<br />     (list lst)<br />     (if        (null lst)<br />       nil<br />       (if (or (equal (car at) (caar lst))<br />               (equal (cadr at) (cadar lst))<br />               (equal (car at) (cadar lst))<br />               (equal (cadr at) (caar lst)))<br />         (-f2 at (cdr lst))<br />         (cons (car lst) (-f2 at (cdr lst)))))))<br /> (defun -f22 (at lst) (vl-remove-if '(lambda (x) (or (member (car at) x) (member (cadr at) x))) lst))<br /> ;|<br /> _$$ (-f3 '((6 7) (6 5) (7 8)) '((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10)))<br /> ((8 "B"))<br /> |;<br /> (defun -f3 (atl lst)<br />   (if (null atl)<br />     nil<br />     (if        (null (-f1 (car atl) lst))<br />       (-f3 (cdr atl) (-f2 (car atl) lst))<br />       (append (-f1 (car atl) lst) (-f3 (cdr atl) (-f2 (car atl) lst))))))<br /> (defun -f32 (atl lst) (apply 'append (mapcar '(lambda (x) (-f12 x lst)) atl)))<br /> ;|<br /> _$$ (-f4 '((6 7) (6 5) (7 8)) '((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10)))<br /> ((4 "A") (1 2) (3 4) (2 3) ("A" 9) ("B" 10))<br /> |;<br /> (defun -f4 (atl lst)<br />   (if (null atl)<br />     (list lst)<br />     (if        (null lst)<br />       nil<br />       (if (null (-f1 (car lst) atl))<br />         (cons (car lst) (-f4 atl (cdr lst)))<br />         (-f4 atl (cdr lst))))))<br /> (defun -f42 (atl lst / tmp ret)<br />   (setq tmp (-f32 atl lst))<br />   (while lst<br />     (if (null (member (car lst) tmp))<br />       (setq ret (append ret (list (car lst)))))<br />     (setq lst (cdr lst)))<br />   ret<br />   )<br /> ;|<br /> _$$ (-f5 '((6 7)) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))<br /> (((6 7) (6 5) (7 8) (8 "B") ("B" 10)) ((4 "A") (1 2) (3 4) (2 3) ("A" 9)))<br /> _$$ (-f5 '((4 "A")) '((1 2) (3 4) (2 3) ("A" 9)))<br /> (((4 "A") (3 4) ("A" 9) (2 3) (1 2)))<br /> |;<br /> (defun -f5 (l1 l2)<br />   (if (null l2)<br />     (list l1)<br />     (if        (null (-f3 l1 l2))<br />       (list l1 l2)<br />       (-f5 (append l1 (-f3 l1 l2)) (-f4 l1 l2)))))<br /> (defun -f52  (l1 l2 / tmp)<br />   (while (setq tmp (-f32 l1 l2))<br />     (setq l2 (-f42 l1 l2)<br />           l1 (append l1 tmp)))<br />   (if (null l2)<br />     (list l1)<br />     (list l1 l2)))<br /> ;|<br /> _$$ (-f6 '((6 7) (4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))<br /> (((6 7) (6 5) (7 8) (8 "B") ("B" 10)) ((4 "A") (3 4) ("A" 9) (2 3) (1 2)))<br /> |;<br /> (defun -f6 (lst / tmp)<br />   (if (null (cdr lst))<br />     (list lst)<br />     (progn (setq tmp (-f5 (list (car lst)) (cdr lst)))<br />            (if (null (cdr tmp))<br />              tmp<br />              (append (list (car tmp)) (-f6 (cadr tmp)))))))<br /> (defun -f62  (lst / tmp ret)<br />   (while (and lst (setq tmp (-f52 (list (car lst)) (cdr lst))))<br />     (setq ret (append ret (list (car tmp)))<br />           lst (cadr tmp)))<br />   ret)<br />

wzg356

活络，看着神奇，也只能挑些来用了。

guankuiwu

太强大了！

阳阳阳

这个是好东西！1

阳阳阳

谢谢，楼主分享！！

479274135

这学习精神  值得我们学习