关于连线的一种方法

newer · 发表于 2016-6-7 21:38:02

杜流浪人发表于 2016-6-7 20:25
xdrx_getpropertyvalue这个函数是什么功能啊

强大的函数，几乎可以查询所有AUTOCAD对象的各种属性。更多去看XDRX_API用户手册吧。

liuyj · 发表于 2016-6-8 09:49:03

S形连接那个确实强

st788796 · 发表于 2016-6-8 10:14:45

Lisphk 发表于 2016-6-6 22:16
这个依据是什么，ST大师，是最短路径吗？还有其他的连法吗？

这个算法简单，效率高，没有特殊要求只是联在一起够用了
别的算法复杂

aimisiyou · 发表于 2016-6-8 10:38:14

如果同时满足最短路径那就更好了

st788796 · 发表于 2016-6-8 10:42:39

aimisiyou 发表于 2016-6-8 10:38
如果同时满足最短路径那就更好了

最短路径在mjtd上有个帖子可以，其中影响效率的是凸包计算，这部分可以用api函数

st788796 · 发表于 2016-6-8 22:40:53

源帖 http://bbs.mjtd.com/thread-96730-1-1.html

用 XDRXAPI 修改后如下（未经测试)

;;;------------------------TSP------------------------------------------------------------;;;
;;;---------------------------------------------------------------------------------------;;;
(defun c:test (/ foo f2 ptl lst l n i d0 l0 l1 d1 ss)
;;by GSLS(SS)
;;refer ElpanovEvgeniy's method from http://www.theswamp.org/index.php?topic=30434.75
;;2012-8-10
(defun foo (l / D D0 D1)
(setq l0 (mapcar (function list) (cons (last l) l) l))
(setq d0 (pnts:length l))
(while (> d0
(progn
(foreach a l0
(setq d (pnts:length l)
l1 (vl-remove (car a) (vl-remove (cadr a) l))
l1 (f1 (car a) l1)
l1 (f1 (cadr a) l1)
)
(if (> d (setq d1 (pnts:length l1)))
(setq d d1
l l1
) ;_ setq
) ;_ if
(setq l1 (vl-remove (car a) (vl-remove (cadr a) l))
l1 (f1 (cadr a) l1)
l1 (f1 (car a) l1)
)
(if (> d
(setq d1 (pnts:length l1))
)
(setq d d1
l l1
)
)
)
d
) ;_ progn
) ;_ <
(setq d0 d)
) ;_ while
(setq d (pnts:length l))
l
)
(defun f1 (a l) (ins-lst a (get-closest-i l a) l))
(defun f2 (lst)
(mapcar (function (lambda (p0 p p1 / a)
(setq a (- (angle p p0) (angle p p1)))
(if (< a (- pi))
(abs (+ a pi pi))
(if (> a pi)
(abs (- a pi pi))
(abs a)
)
)
)
)
(cons (last lst) lst)
lst
(reverse (cons (car lst) (reverse (cdr lst))))
)
)
(if (setq ss (ssget '((0 . "point"))))
(progn
(setq ptl (mapcar (function (lambda (x) (xdrx_getpropertyvalue x "Position")))
(xdrx_pickset->ents ss)
)
ptl (mapcar (function (lambda (p) (list (car p) (cadr p)))) ptl)
t1 (getvar "MilliSecs")
lst (apply 'xdrx_points_ghull ptl)
)
(foreach a lst (setq ptl (vl-remove a ptl)))
(while (and (> (length ptl) 2)
(setq l (apply 'xdrx_points_ghull ptl))
)
(foreach p l
(setq ptl (vl-remove p ptl))
(setq n (get-minadddist-i lst p))
(setq lst (ins-lst p n lst))
)
)
(if ptl
(foreach p ptl
(setq n (get-minadddist-i lst p))
(setq lst (ins-lst p n lst))
)
)
(setq lst (foo lst))
(setq l (f2 lst))
(setq i 0
l0 lst
n (length lst)
d0 (pnts:length lst)
)
(foreach a l
(if (and (< a _pi3) (= (setq p (nth i lst)) (nth i l0)))
(progn
(if (= i 0)
(setq p0 (last lst))
(setq p0 (nth (1- i) lst))
)
(if (= i (1- n))
(setq p1 (car lst))
(setq p1 (nth (1+ i) lst))
)
(setq m (list (list p0 p1 p)
(list p1 p p0)
(list p1 p0 p)
(list p p0 p1)
(list p p1 p0)
)
)
(setq l1
(car (vl-sort (mapcar (function (lambda (x)
(ch-para-lst x i lst)
)
)
m
)
(function (lambda (e1 e2)
(< (pnts:length e1)
(pnts:length e2)
)
)
)
)
)
)
(setq d1 (pnts:length l1))
(if (< d1 d0)
(setq d0 d1
lst l1
)
)
)
)
(setq i (1+ i))
)
(setq l (f2 lst)
i 0
l0 lst
d0 (pnts:length lst)
)
(foreach a l
(if (and (< a _pi2) (setq p (nth i l0)))
(progn
(setq l1 (f1 p (vl-remove p lst)))
(setq d1 (pnts:length l1))
(if (< d1 d0)
(setq d0 d1
lst l1
)
)
)
)
(setq i (1+ i))
)
(apply 'xdrx_polyline_make lst)
(setq t2 (getvar "MilliSecs"))
(princ (strcat "\nTSP Length :" (rtos d0 2 0) "."))
(princ (strcat "\nUse Time :" (rtos (- t2 t1) 2 0) "ms."))
)
)
(princ)
)
;;;以最下面的点为基点，按照角度和距离分类点集
(defun sort-ad (pl pt)
(vl-sort pl
(function (lambda (e1 e2 / an1 an2)
(setq an1 (angle pt e1)
an2 (angle pt e2)
)
(if (equal an1 an2 1e-6) ;_这里降低误差，以适应工程需求
(< (distance pt e1) (distance pt e2))
(< an1 an2)
)
)
)
)
)
;;;------------------------
;;(ins-lst 10 5 '(1 2 3 4 5))
;; i 为新插入元素的位置
(defun ins-lst (new i lst / len fst)
(cond
((minusp i)
lst
)
((> i (setq len (length lst)))
lst
)
((> i (/ len 2))
(reverse (ins-lst new (- len i) (reverse lst)))
)
(t
(append
(progn
(setq fst nil)
(repeat (rem i 4)
(setq fst (cons (car lst) fst)
lst (cdr lst)
)
)
(repeat (/ i 4)
(setq fst (cons (cadddr lst)
(cons (caddr lst)
(cons
(cadr lst)
(cons
(car lst)
fst
)
)
)
)
lst (cddddr lst)
)
)
(reverse fst)
)
(list new)
lst
)
)
)
)
;;;------------------------
;;(ch-para-lst '(7 8 9) 3 '(1 2 3 4 5))
(defun ch-para-lst (para i lst / len fst)
(setq len (length lst))
(cond
((minusp i)
lst
)
((> i (1- len))
lst
)
((= i 0)
(cons (cadr para)
(cons (caddr para)
(reverse (cons (car para) (cdr (reverse (cddr lst)))))
)
)
)
((= i (1- len))
(reverse
(append (cdr (reverse para))
(cddr (reverse (cons (last para) (cdr lst))))
)
)
)
((> i (/ len 2))
(reverse
(ch-para-lst (reverse para) (- len i 1) (reverse lst))
)
)
(t
(append
(progn
(setq fst nil)
(repeat (rem i 4)
(setq fst (cons (car lst) fst)
lst (cdr lst)
)
)
(repeat (/ i 4)
(setq fst (cons (cadddr lst)
(cons (caddr lst)
(cons
(cadr lst)
(cons
(car lst)
fst
)
)
)
)
lst (cddddr lst)
)
)
(reverse
(cons (caddr para)
(cons (cadr para) (cons (car para) (cdr fst)))
)
)
)
(cdr lst)
)
)
)
)
;;;------------------------
;;两边长度和减去第三边，差最小的位置
(defun get-minadddist-i (lst p)
(car
(vl-sort-i
(mapcar (function (lambda (p1 p2)
(- (+ (distance p p1) (distance p p2))
(distance p1 p2)
)
)
)
(cons (last lst) lst)
lst
)
'<
)
)
)
;;;------------------------
;;最近的点位置
(defun get-closest-i (lst p)
(car
(vl-sort-i
(mapcar
(function
(lambda (p1 p2 / v)
(if (or (equal p p1 1e-8) (equal p p2 1e-8))
1e99
(progn
(setq v (trans (mapcar '- p p1) 0 (mapcar '- p2 p1)))
(if (< (abs (car v)) 1e-8)
0.0
(distance p p2)
)
)
)
)
)
(cons (last lst) lst)
lst
)
'<
)
)
)
;;;------------------------
(defun pnts:length (l / dis)
(setq dis (distance (car l) (last l)))
(while l
(setq dis (+ (distance (car l) (cadr l)))
l (cddr l)
)
)
dis
)

;;;------------------------TSP------------------------------------------------------------;;; 
;;;---------------------------------------------------------------------------------------;;; 
(defun c:test (/ foo f2 ptl lst l n i d0 l0 l1 d1 ss) 
  ;;by GSLS(SS) 
  ;;refer ElpanovEvgeniy's method from  http://www.theswamp.org/index.php?topic=30434.75 
  ;;2012-8-10 
  (defun foo (l / D D0 D1) 
    (setq l0 (mapcar (function list) (cons (last l) l) l)) 
    (setq d0 (pnts:length l)) 
    (while (> d0 
              (progn 
                (foreach a l0 
                  (setq        d  (pnts:length l) 
                        l1 (vl-remove (car a) (vl-remove (cadr a) l)) 
                        l1 (f1 (car a) l1) 
                        l1 (f1 (cadr a) l1) 
                  ) 
                  (if (> d (setq d1 (pnts:length l1))) 
                    (setq d d1 
                          l l1 
                    ) ;_  setq 
                  ) ;_  if 
                  (setq        l1 (vl-remove (car a) (vl-remove (cadr a) l)) 
                        l1 (f1 (cadr a) l1) 
                        l1 (f1 (car a) l1) 
                  ) 
                  (if (> d 
                         (setq d1 (pnts:length l1)) 
                      ) 
                    (setq d d1 
                          l l1 
                    ) 
                  ) 
                ) 
                d 
              ) ;_  progn 
           ) ;_  < 
      (setq d0 d) 
    ) ;_  while    
    (setq d (pnts:length l)) 
    l 
  ) 
  (defun f1 (a l) (ins-lst a (get-closest-i l a) l)) 
  (defun f2 (lst) 
    (mapcar (function (lambda (p0 p p1 / a) 
                        (setq a (- (angle p p0) (angle p p1))) 
                        (if (< a (- pi)) 
                          (abs (+ a pi pi)) 
                          (if (> a pi) 
                            (abs (- a pi pi)) 
                            (abs a) 
                          ) 
                        ) 
                      ) 
            ) 
            (cons (last lst) lst) 
            lst 
            (reverse (cons (car lst) (reverse (cdr lst)))) 
    ) 
  ) 
  (if (setq ss (ssget '((0 . "point")))) 
    (progn 
      (setq ptl        (mapcar        (function (lambda (x) (xdrx_getpropertyvalue x "Position"))) 
                        (xdrx_pickset->ents ss) 
                ) 
            ptl        (mapcar (function (lambda (p) (list (car p) (cadr p)))) ptl) 
            t1        (getvar "MilliSecs") 
            lst        (apply 'xdrx_points_ghull ptl) 
      ) 
      (foreach a lst (setq ptl (vl-remove a ptl))) 
      (while (and (> (length ptl) 2) 
                  (setq l (apply 'xdrx_points_ghull ptl)) 
             ) 
        (foreach p l 
          (setq ptl (vl-remove p ptl)) 
          (setq n (get-minadddist-i lst p)) 
          (setq lst (ins-lst p n lst)) 
        ) 
      ) 
      (if ptl 
        (foreach p ptl 
          (setq n (get-minadddist-i lst p)) 
          (setq lst (ins-lst p n lst)) 
        ) 
      ) 
      (setq lst (foo lst)) 
      (setq l (f2 lst)) 
      (setq i  0 
            l0 lst 
            n  (length lst) 
            d0 (pnts:length lst) 
      ) 
      (foreach a l 
        (if (and (< a _pi3) (= (setq p (nth i lst)) (nth i l0))) 
          (progn 
            (if        (= i 0) 
              (setq p0 (last lst)) 
              (setq p0 (nth (1- i) lst)) 
            ) 
            (if        (= i (1- n)) 
              (setq p1 (car lst)) 
              (setq p1 (nth (1+ i) lst)) 
            ) 
            (setq m (list (list p0 p1 p) 
                          (list p1 p p0) 
                          (list p1 p0 p) 
                          (list p p0 p1) 
                          (list p p1 p0) 
                    ) 
            ) 
            (setq l1 
                   (car        (vl-sort (mapcar (function (lambda (x) 
                                                     (ch-para-lst x i lst) 
                                                   ) 
                                         ) 
                                         m 
                                 ) 
                                 (function (lambda (e1 e2) 
                                             (<        (pnts:length e1) 
                                                (pnts:length e2) 
                                             ) 
                                           ) 
                                 ) 
                        ) 
                   ) 
            ) 
            (setq d1 (pnts:length l1)) 
            (if        (< d1 d0) 
              (setq d0        d1 
                    lst        l1 
              ) 
            ) 
          ) 
        ) 
        (setq i (1+ i)) 
      ) 
      (setq l  (f2 lst) 
            i  0 
            l0 lst 
            d0 (pnts:length lst) 
      ) 
      (foreach a l 
        (if (and (< a _pi2) (setq p (nth i l0))) 
          (progn 
            (setq l1 (f1 p (vl-remove p lst))) 
            (setq d1 (pnts:length l1)) 
            (if        (< d1 d0) 
              (setq d0        d1 
                    lst        l1 
              ) 
            ) 
          ) 
        ) 
        (setq i (1+ i)) 
      ) 
      (apply 'xdrx_polyline_make lst) 
      (setq t2 (getvar "MilliSecs")) 
      (princ (strcat "\nTSP Length :" (rtos d0 2 0) ".")) 
      (princ (strcat "\nUse Time :" (rtos (- t2 t1) 2 0) "ms.")) 
    ) 
  ) 
  (princ) 
) 
;;;以最下面的点为基点，按照角度和距离分类点集 
(defun sort-ad (pl pt) 
  (vl-sort pl 
           (function (lambda (e1 e2 / an1 an2) 
                       (setq an1 (angle pt e1) 
                             an2 (angle pt e2) 
                       ) 
                       (if (equal an1 an2 1e-6) ;_这里降低误差，以适应工程需求 
                         (< (distance pt e1) (distance pt e2)) 
                         (< an1 an2) 
                       ) 
                     ) 
           ) 
  ) 
) 
;;;------------------------ 
;;(ins-lst 10 5 '(1 2 3 4 5)) 
;; i 为新插入元素的位置 
(defun ins-lst (new i lst / len fst) 
  (cond 
    ((minusp i) 
     lst 
    ) 
    ((> i (setq len (length lst))) 
     lst 
    ) 
    ((> i (/ len 2)) 
     (reverse (ins-lst new (- len i) (reverse lst))) 
    ) 
    (t 
     (append 
       (progn 
         (setq fst nil) 
         (repeat (rem i 4) 
           (setq fst (cons (car lst) fst) 
                 lst (cdr lst) 
           ) 
         ) 
         (repeat (/ i 4) 
           (setq fst (cons (cadddr lst) 
                           (cons (caddr lst) 
                                 (cons 
                                   (cadr lst) 
                                   (cons 
                                     (car lst) 
                                     fst 
                                   ) 
                                 ) 
                           ) 
                     ) 
                 lst (cddddr lst) 
           ) 
         ) 
         (reverse fst) 
       ) 
       (list new) 
       lst 
     ) 
    ) 
  ) 
) 
;;;------------------------ 
;;(ch-para-lst '(7 8 9) 3 '(1 2 3 4 5)) 
(defun ch-para-lst (para i lst / len fst) 
  (setq len (length lst)) 
  (cond 
    ((minusp i) 
     lst 
    ) 
    ((> i (1- len)) 
     lst 
    ) 
    ((= i 0) 
     (cons (cadr para) 
           (cons (caddr para) 
                 (reverse (cons (car para) (cdr (reverse (cddr lst))))) 
           ) 
     ) 
    ) 
    ((= i (1- len)) 
     (reverse 
       (append (cdr (reverse para)) 
               (cddr (reverse (cons (last para) (cdr lst)))) 
       ) 
     ) 
    ) 
    ((> i (/ len 2)) 
     (reverse 
       (ch-para-lst (reverse para) (- len i 1) (reverse lst)) 
     ) 
    ) 
    (t 
     (append 
       (progn 
         (setq fst nil) 
         (repeat (rem i 4) 
           (setq fst (cons (car lst) fst) 
                 lst (cdr lst) 
           ) 
         ) 
         (repeat (/ i 4) 
           (setq fst (cons (cadddr lst) 
                           (cons (caddr lst) 
                                 (cons 
                                   (cadr lst) 
                                   (cons 
                                     (car lst) 
                                     fst 
                                   ) 
                                 ) 
                           ) 
                     ) 
                 lst (cddddr lst) 
           ) 
         ) 
         (reverse 
           (cons (caddr para) 
                 (cons (cadr para) (cons (car para) (cdr fst))) 
           ) 
         ) 
       ) 
       (cdr lst) 
     ) 
    ) 
  ) 
) 
 
;;;------------------------ 
;;两边长度和减去第三边，差最小的位置 
(defun get-minadddist-i        (lst p) 
  (car 
    (vl-sort-i 
      (mapcar (function        (lambda        (p1 p2) 
                          (- (+ (distance p p1) (distance p p2)) 
                             (distance p1 p2) 
                          ) 
                        ) 
              ) 
              (cons (last lst) lst) 
              lst 
      ) 
      '< 
    ) 
  ) 
) 
;;;------------------------ 
;;最近的点位置 
(defun get-closest-i (lst p) 
  (car 
    (vl-sort-i 
      (mapcar 
        (function 
          (lambda (p1 p2 / v) 
            (if        (or (equal p p1 1e-8) (equal p p2 1e-8)) 
              1e99 
              (progn 
                (setq v (trans (mapcar '- p p1) 0 (mapcar '- p2 p1))) 
                (if (< (abs (car v)) 1e-8) 
                  0.0 
                  (distance p p2) 
                ) 
              ) 
            ) 
          ) 
        ) 
        (cons (last lst) lst) 
        lst 
      ) 
      '< 
    ) 
  ) 
) 
;;;------------------------ 
(defun pnts:length (l / dis) 
  (setq dis (distance (car l) (last l))) 
  (while l 
    (setq dis (+ (distance (car l) (cadr l))) 
          l   (cddr l) 
    ) 
  ) 
  dis 
)

aeo · 发表于 2016-6-8 23:45:38

-----发表于 1 小时前-----
:lol:lol:lol:lol

悠着点

aeo · 发表于 2016-6-8 23:55:41

回复后看了下算法，我觉得你的算法是赶巧了吧。
随机测试出现错误的概率反而比较低，
平时画的图，因为都是"特殊情况",所以出现问题的概率比较高。（我指自相交）

st788796 · 发表于 2016-6-8 23:58:45

aeo 发表于 2016-6-8 23:55
回复后看了下算法，我觉得你的算法是赶巧了吧。
随机测试出现错误的概率反而比较低，
平时画的图，因为都 ...

你发个不赶巧的图测试下

LoveArx · 发表于 2016-6-9 02:06:13

st788796 发表于 2016-6-8 22:40
源帖 http://bbs.mjtd.com/thread-96730-1-1.html

用 XDRXAPI 修改后如下（未经测试)

用XD API 竟然写了这么长的代码？不纯的吧。

st788796 · 发表于 2016-6-9 02:27:54

LoveArx 发表于 2016-6-9 02:06
用XD API 竟然写了这么长的代码？不纯的吧。

API主要是处理Autocad实体简化代码，这个是有区别的

小龙龙 · 发表于 2016-6-9 09:11:17

来看一看，学习一下LISP

st788796 · 发表于 2016-6-9 10:55:56

学习了下mjtd那个帖子算法，大致是搜出凸包后逐渐向内“塌陷”连接，测试中也会出现多义线自交情况
一楼算法仅仅用了扫描法凸包的一个预处理函数，所以从效率上应该是最高的了，而且具有对称性和放射性，绝对不会出现自相交

newer · 发表于 2016-6-9 13:35:01

st788796 发表于 2016-6-9 10:55
学习了下mjtd那个帖子算法，大致是搜出凸包后逐渐向内“塌陷”连接，测试中也会出现多义线自交情况
一楼算 ...

也是哈，最短路径算法只是要求不走重复路和路径最短，但没限制两个路不能自交啊。

newer · 发表于 2016-6-9 16:33:34

st788796 发表于 2016-6-8 22:40
源帖 http://bbs.mjtd.com/thread-96730-1-1.html

用 XDRXAPI 修改后如下（未经测试)

初略看了下，可以优化的函数有：

ins-list ----> xd::list:insert
get-closest-i ---> 最近点？

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

[教学] 关于连线的一种方法

点评

点评