如果根据距离最近的点自动生成Pline线？
本帖最后由 xfbar 于 2010-12-30 07:38 编辑指定起始点和终点，从左边第一个点开始，自动与最近点相连生成一条PLine线，用LISP程序怎么实现？
完整的程序咋写的！？
ZZXXQQ 发表于 2010-12-31 20:24 static/image/common/back.gif
10楼已改。再试试。
谢谢版主
重新下载，可以连接了。
要有规律的点连接才好，如果是较密的点，需要手动修改连接.
学习了
谢谢
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=169571 加工中心在加工孔的时候,找最近的点加工,是最近的路径,
本帖最后由 xfbar 于 2010-12-29 22:11 编辑
示例 点都在 图上！ 取点成表 起点和其他的点的距离 ((dis1 ptstart pt1) (dis2 ptstart pt2) -------) 排序
求出第二个点 将第二个点定义成第一个点 以此循环 思路是这样！想要代码，下面运行有问题，帮看看 (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))))
completenil
)
(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) 好长 谁帮写 个 简洁有效LSP程序！ 露水2 发表于 2010-12-30 11:45 static/image/common/back.gif
取点成表 起点和其他的点的距离 ((dis1 ptstart pt1) (dis2 ptstart pt2) -------) 排序
求出第二个点 将 ...
你说的此方法，对于例图有效，如果是无规则的点，这样得到的并不是最短的路径，院长和老迈好像已经做到，见过演示图。 谢谢提醒 我没有仔细想
每次都是最近点 路径不知道是不是最短的 本帖最后由 xfbar 于 2010-12-30 22:54 编辑
不是杂乱无章的离散掉点。数据有规则性，大致朝一个方向。 是地下管道的焊口坐标，是分批采集的！所以想实现自动生成一条线！ 本帖最后由 ZZXXQQ 于 2010-12-31 21:06 编辑
;最近点画线 明经 ZZXXQQ 2010.12.30
(DEFUN C:TT ()
(SETVAR "CMDECHO" 0)
(SETQ OLDOS (GETVAR "OSMODE"))
(PRINC "\nSelect Points :")
(IF (SETQ SS (SSGET '((0 . "POINT")))) (PROGN
(SETQ I -1 PTL (LIST))
(REPEAT (SSLENGTH SS)
(SETQ PTL (CONS (CDR (ASSOC 10 (ENTGET (SSNAME SS (SETQ I (1+ I)))))) PTL))
)
(SETQ PTL (REVERSE PTL) I -1 TMP (LIST) PT1 (LIST 0 0) PSL (LENGTH PTL))
(WHILE (< I (- PSL 2))
(SETQ J I K nil DIS 1E8)
(WHILE (< J (1- PSL))
(SETQ PT2 (NTH (SETQ J (1+ J)) PTL) DS1 (DISTANCE PT2 PT1))
(IF (< DS1 DIS) (SETQ DIS DS1 K J))
)
(IF K
(SETQ PT (NTH (SETQ I (1+ I)) PTL) PT1 (NTH K PTL)
PTL (SUBST (LIST 'AA) PT1 PTL)
PTL (SUBST PT1 PT PTL)
PTL (SUBST PT (LIST 'AA) PTL))
(SETQ I (1+ I))
)
)
(SETVAR "OSMODE" 0)
(SETQ I 0)
(COMMAND "PLINE" (NTH 0 PTL))
(REPEAT PSL
(SETQ PT (NTH (SETQ I (1+ I)) PTL))
(COMMAND PT)
)
(COMMAND "")
))
(SETVAR "OSMODE" OLDOS)
(SETVAR "CMDECHO" 1)
(PRINC)
)