Gu_xl 发表于 2012-2-22 16:58 static/image/common/back.gif
先发个演示图和编译的程序，程序仅对Line有效！
G版，简直爱死你了，太棒了！
安静等待G版的核心代码！
学习了 非常感谢
思路和核心代码在二楼公布！
G版
(GXL-BREAK_SSFuzz ss Fuzz)子程序没有发上来，出错
Gu_xl 发表于 2012-2-23 19:51 static/image/common/back.gif
思路和核心代码在二楼公布！
现在才能轻松打开网页，对G版感激涕零，老泪纵横啊
本帖最后由 chlh_jd 于 2012-2-25 01:32 编辑
之前有见过求2点间的最短距离，效率非常高，也用了穷举法了，稍微修改下应该能满足楼主的要求。
;;;来自网络，谁写的，我回头查下补上
(defun c:2pt-min-dis (/ show getss@ getconnect main getconnect pt1 pt2 ss1 ss2 complete zhf_time_dot)
;;;相关函数
(defun show (lst stop)
(mapcar (function(lambda (x) (redraw (vlax-vla-object->ename x) 3)))
lst
)
(if stop
(progn (getpoint)
(mapcar (function (lambda (x) (redraw (vlax-vla-object->ename x) 4)))
lst
)
)
)
)
(defun getss@ (p)
(ssget "c"
p
(polar p (/ pi 4) (/ (getvar "viewsize") 5000))
(list (cons 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 getconnect (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
(function(lambda (x)
(if (member x sse)
(setq
complete (append complete (list (list x (get:len x))))
)
)
))
ss
)
(if complete
(setq complete (vl-sort complete
(function (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) (quote 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
(function (lambda (a b) (< (cadr a) (cadr b))))
)
shortest (cadar complete)
dist-ss(mapcar (function (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 (function (lambda (x) (list x (car now)))) ss)
)
dist-ss (append
dist-ss
(mapcar
(function (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
(function (lambda (a b) (< (cadr a) (cadr b))))
)
)
)
)
)
;;;_____________________________
;;;_____________________________
;;;_____________________________
(if show
(progn
(mapcar (function (lambda (x) (vlax-put x (quote color) 0))) passed-ss)
(mapcar (function (lambda (x) (vla-update x))) passed-ss)
)
)
;;;_____________________________
;;;_____________________________
;;;_____________________________
(if complete
(progn
(setq
complete (vl-sort complete
(function(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
)
)
;;;___________________________________________
(redraw)
(setq pt1 (getpoint "\n起点:")
pt2 (getpoint "\n终点:")
)
(mapcar
(function(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 ss1 (main pt1 pt2 t))
(if ss1
(progn
(setq ss2 (ssadd))
(mapcar (function(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)
)
;;;两点最短路径结束
;;;---------------------------------------------------------------------;;;
chlh_jd的程序好像缺了两个函数，get:len和z_timer，先找个替代一下，z_timer就直接删了吧。
(defun get:len (en / len)
(if (vl-catch-all-error-p
(setq len (vl-catch-all-apply
'vlax-curve-getdistatparam
(list en
(vl-catch-all-apply
'vlax-curve-getendparam
(list en)
)
)
)
)
)
nil
len
)
)
干啥用的
这样子啊，回复只为看贴，神奇的代码