如果根据距离最近的点自动生成Pline线？

xfbar · 发表于 2010-12-29 20:28:35

本帖最后由 xfbar 于 2010-12-30 07:38 编辑

指定起始点和终点，从左边第一个点开始，自动与最近点相连生成一条PLine线，用LISP程序怎么实现？

完整的程序咋写的！？

461045462 · 发表于 2010-12-31 20:38:47

ZZXXQQ 发表于 2010-12-31 20:24
10楼已改。再试试。

谢谢版主
重新下载，可以连接了。
要有规律的点连接才好，如果是较密的点，需要手动修改连接.
学习了
谢谢

永不言弃 · 发表于 2017-8-11 09:02:29

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=169571

前生 · 发表于 2017-8-10 13:12:44

加工中心在加工孔的时候,找最近的点加工,是最近的路径,

xfbar · 发表于 2010-12-29 21:20:58

本帖最后由 xfbar 于 2010-12-29 22:11 编辑

示例点都在图上！

露水2 · 发表于 2010-12-30 11:45:37

取点成表起点和其他的点的距离 ((dis1 ptstart pt1) (dis2 ptstart pt2) -------) 排序
求出第二个点将第二个点定义成第一个点以此循环

xfbar · 发表于 2010-12-30 12:44:24

思路是这样！想要代码，下面运行有问题，帮看看

(defun z_timer (/ stime h m s)
(if (not zhf_time_dot)
(setq zhf_time_dot
(getvar "date")
h nil
)
(progn
(setq stime (getvar "date"))
(setq stime (- stime zhf_time_dot))
(setq stime (* 86400.0 (- stime (fix stime))))
(setq h (fix (/ stime 3600)))
(setq m (fix (/ (- stime (* h 3600)) 60)))
(setq s (fix (- stime (* m 60) (* h 3600))))
(setq zhf_time_dot nil)
(strcat (if (> h 0)
(strcat (rtos h 2 0) "小时")
""
)
(if (> m 0)
(strcat (rtos m 2 0) "分钟")
""
)
(rtos s 2 0)
"秒"
)
)
)
)
(defun show (lst stop)
(mapcar '(lambda (x) (redraw (vlax-vla-object->ename x) 3))
lst
)
(if stop
(progn (getpoint)
(mapcar '(lambda (x) (redraw (vlax-vla-object->ename x) 4))
lst
)
)
)
)
(defun ss2lst (ss vla / re e)
(if ss
(repeat (setq n (sslength ss))
(if vla
(setq e (vlax-ename->vla-object (ssname ss (setq n (1- n)))))
(setq e (ssname ss (setq n (1- n))))
)
(setq re (append re (list e)))
)
)
re
)
(defun getss@ (p)
(ssget "c"
p
(polar p (/ pi 4) (/ (getvar "viewsize") 5000))
'((0 . "arc,ellipse,*line"))
)
)
(defun getconnect (e)
(vl-remove e
(append (ss2lst (getss@ (vlax-curve-getStartpoint e)) t)
(ss2lst (getss@ (vlax-curve-getEndpoint e)) t)
)
)
)
(defun remove:same (lst / re)
(foreach n lst
(if (member n re)
()
(setq re (append re (list re)))
)
)
re
)
(defun get:len (e)
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
(defun main (pt1 pt2 show / ss sse line path paths shortlen shortlst ss1
shortest)
(setq count 0)
(setq ss (ss2lst (getss@ pt1) t)
sse (ss2lst (getss@ pt2) t)
)
(if (and ss sse)
(progn
(setq passed-ss ss
path-ss (mapcar '(lambda (x) (list x)) ss)
dist-ss (mapcar '(lambda (x) (list x (get:len x))) ss)
dist-ss (vl-sort dist-ss '(lambda (a b) (< (cadr a) (cadr b))))
complete nil
)
(mapcar '(lambda (x)
(if (member x sse)
(setq
complete (append complete (list (list x (get:len x))))
)
)
)
ss
)
(if complete
(setq complete (vl-sort complete
'(lambda (a b) (< (cadr a) (cadr b)))
)
shortest (cadar complete)
)
)
(if (and shortest (= shortest (distance pt1 pt2)))
(progn
(list (cadar complete) (list (caar complete)))
)
(progn
(while (and dist-ss (> (length sse) (length complete)))
(setq now (car dist-ss)
dist-ss (cdr dist-ss)
)
;;;_____________________________
;;;_____________________________
;;;_____________________________
(if show
(progn
(vlax-put (car now) 'color (+ 21 (* 10 (rem count 20))))
(vla-update (car now))
)
)
;;;_____________________________
;;;_____________________________
;;;_____________________________
(if (member (car now) sse)
(progn
(setq complete (append complete (list now)))
;;;__________________________________________________
;;;到达终点后剔出所有距离已经超出最小路由长度的未完成方向
(setq complete
(vl-sort complete
'(lambda (a b) (< (cadr a) (cadr b)))
)
shortest (cadar complete)
dist-ss (mapcar '(lambda (x)
(if (< (cadr x) shortest)
x
nil
)
)
dist-ss
)
dist-ss (vl-remove nil dist-ss)
)
;;;__________________________________________________
;;;__________________________________________________
)
(progn
(setq count (1+ count))
(setq ss (getconnect (car now)))
(mapcar '(lambda (x) (setq ss (vl-remove x ss)))
passed-ss
)
(setq passed-ss (append passed-ss ss)
path-ss (append
path-ss
(mapcar '(lambda (x) (list x (car now))) ss)
)
dist-ss (append
dist-ss
(mapcar
'(lambda (x)
(if (or (not shortest)
(< (get:len x) shortest)
)
(list x (+ (cadr now) (get:len x)))
)
)
ss
)
)
dist-ss (vl-remove nil dist-ss)
dist-ss (vl-sort dist-ss
'(lambda (a b) (< (cadr a) (cadr b)))
)
)
)
)
)
;;;_____________________________
;;;_____________________________
;;;_____________________________
(if show
(progn
(mapcar '(lambda (x) (vlax-put x 'color 0)) passed-ss)
(mapcar '(lambda (x) (vla-update x)) passed-ss)
)
)
;;;_____________________________
;;;_____________________________
;;;_____________________________
(if complete
(progn
(setq
complete (vl-sort complete
'(lambda (a b) (< (cadr a) (cadr b)))
)
n (car complete)
)
(setq len (cadr n)
n (car n)
)
(while n
(setq ss1 (append ss1 (list n)))
(setq n (cadr (assoc n path-ss)))
)
(list len (reverse ss1))
)
nil
)
)
)
)
nil
)
)
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
(defun c:ttt (/ pt1 pt2 ss1 ss2 complete)
(redraw)
(setq pt1 (getpoint "\n起点:")
pt2 (getpoint "\n终点:")
)
(mapcar
'(lambda (pt)
(grdraw (polar pt (* pi 0.25) (/ (getvar "viewsize") 40))
(polar pt (* pi -0.75) (/ (getvar "viewsize") 40))
1
)
(grdraw (polar pt (* pi 0.75) (/ (getvar "viewsize") 40))
(polar pt (* pi -0.25) (/ (getvar "viewsize") 40))
1
)
)
(list pt1 pt2)
)
(setq zhf_time_dot nil)
(z_timer)
(setq ss1 (main pt1 pt2 t))
(if ss1
(progn
(setq ss2 (ssadd))
(mapcar '(lambda (x)
(setq ss2 (ssadd (vlax-vla-object->ename x) ss2))
)
(cadr ss1)
)
(princ (strcat "\n虚线显示最短路线, 共需"
(itoa (sslength ss2))
"步,总长度为:"
(rtos (car ss1))
" 历时:"
(z_timer)
)
)
(show (cadr ss1) nil)
)
(princ (strcat "\n两点间没有可连通路径,历时:" (z_timer)))
)
(princ)
)
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
(princ "\n寻找连接两点的最近路线,by wkai @ xdcad ")
(princ
"\n前提所有路线只在交点处交叉,起点和终点选择路线的端点."
)
(princ "\n核心函数 (main 起点终点是否显示搜索过程) ")
(princ "\n返回值 (最短路线长度最短路线途径实体表)")
(princ "\n测试命令:ttt\n")
(princ)

(defun z_timer (/ stime h m s) 
  (if (not zhf_time_dot) 
    (setq zhf_time_dot 
    (getvar "date") 
   h nil 
    ) 
    (progn 
      (setq stime (getvar "date")) 
      (setq stime (- stime zhf_time_dot)) 
      (setq stime (* 86400.0 (- stime (fix stime)))) 
      (setq h (fix (/ stime 3600))) 
      (setq m (fix (/ (- stime (* h 3600)) 60))) 
      (setq s (fix (- stime (* m 60) (* h 3600)))) 
      (setq zhf_time_dot nil) 
 
      (strcat (if (> h 0) 
  (strcat (rtos h 2 0) "小时") 
  "" 
       ) 
       (if (> m 0) 
  (strcat (rtos m 2 0) "分钟") 
  "" 
       ) 
       (rtos s 2 0) 
       "秒" 
      ) 
    ) 
  ) 
) 
(defun show (lst stop) 
  (mapcar '(lambda (x) (redraw (vlax-vla-object->ename x) 3)) 
   lst 
  ) 
  (if stop 
    (progn (getpoint) 
    (mapcar '(lambda (x) (redraw (vlax-vla-object->ename x) 4)) 
     lst 
    ) 
    ) 
  ) 
) 
(defun ss2lst (ss vla / re e) 
  (if ss 
    (repeat (setq n (sslength ss)) 
      (if vla 
(setq e (vlax-ename->vla-object (ssname ss (setq n (1- n))))) 
(setq e (ssname ss (setq n (1- n)))) 
      ) 
      (setq re (append re (list e))) 
    ) 
  ) 
  re 
) 
(defun getss@ (p) 
  (ssget "c" 
  p 
  (polar p (/ pi 4) (/ (getvar "viewsize") 5000)) 
  '((0 . "arc,ellipse,*line")) 
  ) 
) 
(defun getconnect (e) 
  (vl-remove e 
      (append (ss2lst (getss@ (vlax-curve-getStartpoint e)) t) 
       (ss2lst (getss@ (vlax-curve-getEndpoint e)) t) 
      ) 
  ) 
) 
(defun remove:same (lst / re) 
  (foreach n lst 
    (if (member n re) 
      () 
      (setq re (append re (list re))) 
    ) 
  ) 
  re 
) 
(defun get:len (e) 
  (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 
) 
;;;________________________________________________ 
;;;________________________________________________ 
;;;________________________________________________ 
;;;________________________________________________ 
(defun main (pt1 pt2 show / ss sse line path paths shortlen shortlst ss1 
      shortest) 
  (setq count 0) 
  (setq ss  (ss2lst (getss@ pt1) t) 
sse (ss2lst (getss@ pt2) t) 
  ) 
  (if (and ss sse) 
    (progn 
      (setq passed-ss ss 
     path-ss   (mapcar '(lambda (x) (list x)) ss) 
     dist-ss   (mapcar '(lambda (x) (list x (get:len x))) ss) 
     dist-ss   (vl-sort dist-ss '(lambda (a b) (< (cadr a) (cadr b)))) 
     complete  nil 
 
      ) 
      (mapcar '(lambda (x) 
   (if (member x sse) 
     (setq 
       complete (append complete (list (list x (get:len x)))) 
     ) 
   ) 
        ) 
       ss 
      ) 
      (if complete 
(setq complete (vl-sort complete 
    '(lambda (a b) (< (cadr a) (cadr b))) 
         ) 
       shortest (cadar complete) 
) 
      ) 
 
      (if (and shortest (= shortest (distance pt1 pt2))) 
(progn 
   (list (cadar complete) (list (caar complete))) 
) 
(progn 
   (while (and dist-ss (> (length sse) (length complete))) 
     (setq now   (car dist-ss) 
    dist-ss (cdr dist-ss) 
     ) 
;;;_____________________________ 
;;;_____________________________ 
;;;_____________________________ 
     (if show 
       (progn 
  (vlax-put (car now) 'color (+ 21 (* 10 (rem count 20)))) 
  (vla-update (car now)) 
       ) 
     ) 
;;;_____________________________ 
;;;_____________________________ 
;;;_____________________________ 
     (if (member (car now) sse) 
       (progn 
  (setq complete (append complete (list now))) 
;;;__________________________________________________ 
;;;到达终点后剔出所有距离已经超出最小路由长度的未完成方向 
  (setq complete 
          (vl-sort complete 
     '(lambda (a b) (< (cadr a) (cadr b))) 
          ) 
        shortest (cadar complete) 
        dist-ss  (mapcar '(lambda (x) 
       (if (< (cadr x) shortest) 
         x 
         nil 
       ) 
     ) 
           dist-ss 
          ) 
        dist-ss  (vl-remove nil dist-ss) 
  ) 
;;;__________________________________________________ 
;;;__________________________________________________ 
       ) 
       (progn 
  (setq count (1+ count)) 
  (setq ss (getconnect (car now))) 
  (mapcar '(lambda (x) (setq ss (vl-remove x ss))) 
   passed-ss 
  ) 
  (setq passed-ss (append passed-ss ss) 
        path-ss (append 
      path-ss 
      (mapcar '(lambda (x) (list x (car now))) ss) 
    ) 
        dist-ss (append 
      dist-ss 
      (mapcar 
        '(lambda (x) 
           (if (or (not shortest) 
            (< (get:len x) shortest) 
        ) 
      (list x (+ (cadr now) (get:len x))) 
           ) 
         ) 
        ss 
      ) 
    ) 
        dist-ss (vl-remove nil dist-ss) 
        dist-ss (vl-sort dist-ss 
      '(lambda (a b) (< (cadr a) (cadr b))) 
    ) 
  ) 
       ) 
     ) 
   ) 
;;;_____________________________ 
;;;_____________________________ 
;;;_____________________________ 
   (if show 
     (progn 
       (mapcar '(lambda (x) (vlax-put x 'color 0)) passed-ss) 
       (mapcar '(lambda (x) (vla-update x)) passed-ss) 
     ) 
   ) 
;;;_____________________________ 
;;;_____________________________ 
;;;_____________________________ 
   (if complete 
     (progn 
       (setq 
  complete (vl-sort complete 
      '(lambda (a b) (< (cadr a) (cadr b))) 
    ) 
  n  (car complete) 
 
       ) 
       (setq len (cadr n) 
      n (car n) 
       ) 
       (while n 
  (setq ss1 (append ss1 (list n))) 
  (setq n (cadr (assoc n path-ss))) 
       ) 
       (list len (reverse ss1)) 
     ) 
     nil 
   ) 
) 
      ) 
    ) 
    nil 
  ) 
) 
;;;________________________________________________ 
;;;________________________________________________ 
;;;________________________________________________ 
;;;________________________________________________ 
(defun c:ttt (/ pt1 pt2 ss1 ss2 complete) 
  (redraw) 
  (setq pt1 (getpoint "\n起点:") 
pt2 (getpoint "\n终点:") 
  ) 
  (mapcar 
    '(lambda (pt) 
       (grdraw (polar pt (* pi 0.25) (/ (getvar "viewsize") 40)) 
        (polar pt (* pi -0.75) (/ (getvar "viewsize") 40)) 
        1 
       ) 
       (grdraw (polar pt (* pi 0.75) (/ (getvar "viewsize") 40)) 
        (polar pt (* pi -0.25) (/ (getvar "viewsize") 40)) 
        1 
       ) 
     ) 
    (list pt1 pt2) 
  ) 
  (setq zhf_time_dot nil) 
  (z_timer) 
  (setq ss1 (main pt1 pt2 t)) 
  (if ss1 
    (progn 
      (setq ss2 (ssadd)) 
      (mapcar '(lambda (x) 
   (setq ss2 (ssadd (vlax-vla-object->ename x) ss2)) 
        ) 
       (cadr ss1) 
      ) 
      (princ (strcat "\n虚线显示最短路线, 共需" 
       (itoa (sslength ss2)) 
       "步,总长度为:" 
       (rtos (car ss1)) 
       "  历时:" 
       (z_timer) 
      ) 
      ) 
      (show (cadr ss1) nil) 
 
    ) 
    (princ (strcat "\n两点间没有可连通路径,历时:" (z_timer))) 
  ) 
  (princ) 
) 
;;;________________________________________________ 
;;;________________________________________________ 
;;;________________________________________________ 
;;;________________________________________________ 
(princ "\n寻找连接两点的最近路线,by wkai @ xdcad ") 
(princ 
  "\n前提 所有路线只在交点处交叉,起点和终点选择路线的端点." 
) 
(princ "\n核心函数 (main 起点 终点 是否显示搜索过程) ") 
(princ "\n返回值   (最短路线长度  最短路线途径实体表)") 
(princ "\n测试命令:ttt\n") 
(princ)

crazylsp · 发表于 2010-12-30 17:13:05

好长

xfbar · 发表于 2010-12-30 17:43:56

谁帮写个简洁有效LSP程序！

xiaotao · 发表于 2010-12-30 21:50:27

露水2 发表于 2010-12-30 11:45
取点成表起点和其他的点的距离 ((dis1 ptstart pt1) (dis2 ptstart pt2) -------) 排序
求出第二个点将 ...

你说的此方法，对于例图有效，如果是无规则的点，这样得到的并不是最短的路径，院长和老迈好像已经做到，见过演示图。

露水2 · 发表于 2010-12-30 21:56:48

谢谢提醒我没有仔细想
每次都是最近点路径不知道是不是最短的

xfbar · 发表于 2010-12-30 22:44:03

本帖最后由 xfbar 于 2010-12-30 22:54 编辑

不是杂乱无章的离散掉点。数据有规则性，大致朝一个方向。是地下管道的焊口坐标，是分批采集的！所以想实现自动生成一条线！

ZZXXQQ · 发表于 2010-12-30 22:54:42

本帖最后由 ZZXXQQ 于 2010-12-31 21:06 编辑

游客，本帖隐藏的内容需要发帖数高于 5 才可浏览，你当前发帖数只有 0

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

如果根据距离最近的点自动生成Pline线？

本帖子中包含更多资源

浏览过的版块