- 积分
- 206
- 明经币
- 个
- 注册时间
- 2014-4-18
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
发表于 2014-4-21 15:50:59
|
显示全部楼层
最短路径的问题？我在网上看到过类似的代码，贴出来给大家看看，先声明，这是别人的作品。
(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:tt (/ 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测试命令:tt\n")
(princ) |
|
[复制链接]
显身卡