寻找线段回路

kkq0305 · 发表于 2022-8-22 23:11:32

本帖最后由 kkq0305 于 2022-8-23 07:05 编辑

输入线段点表，输出回路表

例：(setq lst '((0 . 1) (1 . 2) (2 . 4) (5 . 6) (6 . 1) (1 . 8) (8 . 9) (10 . 6) (6 . 2) (2 . 8) (8 . 10)))
(tt1 lst)--->>>(((6 . 10) (10 . 8) (8 . 2) (2 . 6)) ((6 . 2) (2 . 1) (1 . 6)) ((1 . 2) (2 . 8) (8 . 1)) ((1 . 8) (8 . 10) (10 . 6) (6 . 1)))

(defun tt1 (lst)
(setq lst4 (tt lst)
lst5 nil
)
(while lst4
(setq e1 (car lst4)
lst6 (list (list e1))
loop t
)
(while loop
(setq a (cdr e1)
b (cons a (car e1))
e2lst (vl-remove-if-not
'(lambda (x) (or (equal b x) (= (car x) a)))
lst4
)
e2 (car e2lst)
)
(cond ((null e2)
(if (cdr lst6)
(setq lst4 (vl-remove e1 lst4)
lst6 (if (cdar lst6)
(cons (cdar lst6) (cdr lst6))
(cdr lst6)
)
e1 (caar lst6)
)
(setq lst4 (vl-remove e1 lst4)
e1 (car lst4)
)
)
)
((assoc (cdr e2) (apply 'append lst6))
(setq lst5 (cons (setq lst6 (ff2 (reverse lst6) e2)) lst5)
loop nil
)
(foreach n lst6 (setq lst4 (vl-remove n lst4)))
)
(t
(setq e1 e2
lst6 (cons e2lst lst6)
)
)
)
)
)
lst5
)
(defun tt (lst / lst1 lst2 lst3 lst4)
(setq lst1 (mapcar 'car lst)
lst2 (mapcar 'cdr lst)
lst3 (vl-remove-if-not '(lambda (x) (member x lst2)) lst1)
lst4 (vl-remove-if-not
'(lambda (x)
(and (member (car x) lst3) (member (cdr x) lst3))
)
lst
)
)
(append lst4
(mapcar '(lambda (x) (cons (cdr x) (car x))) lst4)
)
)
(defun ff2 (lst6 e2 / lst6 y lst1 lst2)
(setq ff (lambda (lst a)

(defun tt1 (lst) 
  (setq  lst4 (tt lst) 
  lst5 nil 
  ) 
  (while lst4 
    (setq e1   (car lst4) 
    lst6 (list (list e1)) 
    loop t 
    ) 
    (while loop 
      (setq a    (cdr e1) 
      b    (cons a (car e1)) 
      e2lst (vl-remove-if-not 
        '(lambda (x) (or (equal b x) (= (car x) a))) 
        lst4 
      ) 
      e2    (car e2lst) 
      ) 
      (cond ((null e2) 
       (if (cdr lst6) 
         (setq lst4 (vl-remove e1 lst4) 
         lst6 (if (cdar lst6) 
          (cons (cdar lst6) (cdr lst6)) 
          (cdr lst6) 
        ) 
         e1    (caar lst6) 
         ) 
         (setq lst4 (vl-remove e1 lst4) 
         e1    (car lst4) 
         ) 
       ) 
      ) 
      ((assoc (cdr e2) (apply 'append lst6)) 
       (setq lst5  (cons (setq lst6 (ff2 (reverse lst6) e2)) lst5) 
       loop  nil 
       ) 
       (foreach n lst6 (setq lst4 (vl-remove n lst4))) 
      ) 
      (t 
       (setq e1  e2 
       lst6  (cons e2lst lst6) 
       ) 
      ) 
      ) 
    ) 
  ) 
  lst5 
) 
(defun tt (lst / lst1 lst2 lst3 lst4) 
  (setq  lst1 (mapcar 'car lst) 
  lst2 (mapcar 'cdr lst) 
  lst3 (vl-remove-if-not '(lambda (x) (member x lst2)) lst1) 
  lst4 (vl-remove-if-not 
         '(lambda  (x) 
      (and (member (car x) lst3) (member (cdr x) lst3)) 
    ) 
         lst 
       ) 
  ) 
  (append lst4 
    (mapcar '(lambda (x) (cons (cdr x) (car x))) lst4) 
  ) 
) 
(defun ff2 (lst6 e2 / lst6 y lst1 lst2) 
  (setq ff   (lambda (lst a)

kkq0305 · 发表于 2022-8-23 07:06:02

ff函数加载顺序错了

xuningxu · 发表于 2022-8-23 15:22:46

最小围区算法，费脑；
最后FF函数代码没贴全

llsheng_73 · 发表于 2022-8-25 13:27:30

xuningxu 发表于 2022-8-23 15:22
最小围区算法，费脑；
最后FF函数代码没贴全

感觉不加入坐标或提前计算出“最小角”（不包含其它方向）的话，无法判断是不是最小环，纯数学只能解决到这里

正能量的一诺 · 发表于 2022-9-5 17:09:39

ff2码不全吧

账号		自动登录	找回密码
密码			注册

[函数] 寻找线段回路

本帖子中包含更多资源

评分