本帖最后由 q3_2006 于 2014-5-6 19:00 编辑
lanjqka 发表于 2014-1-11 12:46 http://bbs.mjtd.com/static/image/common/back.gif
;;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有相等的情况就分为同一组...
感觉用递归写比较方便...但我还是写不好...拜托大师抽空指点下...谢谢了!
希望对你有所帮助;|
_$$ (-f1 '(6 7) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))
((6 5) (7 8))
|;
(defun -f1 (at lst)
(if (null at)
nil
(if (null lst)
nil
(if (or (equal (car at) (caar lst))
(equal (cadr at) (cadar lst))
(equal (car at) (cadar lst))
(equal (cadr at) (caar lst)))
(cons (car lst) (-f1 at (cdr lst)))
(-f1 at (cdr lst))))))
(defun -f12 (at lst) (vl-remove-if-not '(lambda (x) (or (member (car at) x) (member (cadr at) x))) lst))
;|
_$$ (-f2 '(6 7) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))
((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10))
|;
(defun -f2 (at lst)
(if (null at)
(list lst)
(if (null lst)
nil
(if (or (equal (car at) (caar lst))
(equal (cadr at) (cadar lst))
(equal (car at) (cadar lst))
(equal (cadr at) (caar lst)))
(-f2 at (cdr lst))
(cons (car lst) (-f2 at (cdr lst)))))))
(defun -f22 (at lst) (vl-remove-if '(lambda (x) (or (member (car at) x) (member (cadr at) x))) lst))
;|
_$$ (-f3 '((6 7) (6 5) (7 8)) '((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10)))
((8 "B"))
|;
(defun -f3 (atl lst)
(if (null atl)
nil
(if (null (-f1 (car atl) lst))
(-f3 (cdr atl) (-f2 (car atl) lst))
(append (-f1 (car atl) lst) (-f3 (cdr atl) (-f2 (car atl) lst))))))
(defun -f32 (atl lst) (apply 'append (mapcar '(lambda (x) (-f12 x lst)) atl)))
;|
_$$ (-f4 '((6 7) (6 5) (7 8)) '((4 "A") (8 "B") (1 2) (3 4) (2 3) ("A" 9) ("B" 10)))
((4 "A") (1 2) (3 4) (2 3) ("A" 9) ("B" 10))
|;
(defun -f4 (atl lst)
(if (null atl)
(list lst)
(if (null lst)
nil
(if (null (-f1 (car lst) atl))
(cons (car lst) (-f4 atl (cdr lst)))
(-f4 atl (cdr lst))))))
(defun -f42 (atl lst / tmp ret)
(setq tmp (-f32 atl lst))
(while lst
(if (null (member (car lst) tmp))
(setq ret (append ret (list (car lst)))))
(setq lst (cdr lst)))
ret
)
;|
_$$ (-f5 '((6 7)) '((4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))
(((6 7) (6 5) (7 8) (8 "B") ("B" 10)) ((4 "A") (1 2) (3 4) (2 3) ("A" 9)))
_$$ (-f5 '((4 "A")) '((1 2) (3 4) (2 3) ("A" 9)))
(((4 "A") (3 4) ("A" 9) (2 3) (1 2)))
|;
(defun -f5 (l1 l2)
(if (null l2)
(list l1)
(if (null (-f3 l1 l2))
(list l1 l2)
(-f5 (append l1 (-f3 l1 l2)) (-f4 l1 l2)))))
(defun -f52(l1 l2 / tmp)
(while (setq tmp (-f32 l1 l2))
(setq l2 (-f42 l1 l2)
l1 (append l1 tmp)))
(if (null l2)
(list l1)
(list l1 l2)))
;|
_$$ (-f6 '((6 7) (4 "A") (8 "B") (1 2) (3 4) (6 5) (2 3) ("A" 9) ("B" 10) (7 8)))
(((6 7) (6 5) (7 8) (8 "B") ("B" 10)) ((4 "A") (3 4) ("A" 9) (2 3) (1 2)))
|;
(defun -f6 (lst / tmp)
(if (null (cdr lst))
(list lst)
(progn (setq tmp (-f5 (list (car lst)) (cdr lst)))
(if (null (cdr tmp))
tmp
(append (list (car tmp)) (-f6 (cadr tmp)))))))
(defun -f62(lst / tmp ret)
(while (and lst (setq tmp (-f52 (list (car lst)) (cdr lst))))
(setq ret (append ret (list (car tmp)))
lst (cadr tmp)))
ret)
活络，看着神奇，也只能挑些来用了。
太强大了！
这个是好东西！1
谢谢，楼主分享！！
这学习精神值得我们学习