文件名称：将wkai的最短路径由经典改为A星算法
文件大小：9KB
文件格式：LSP
更新时间：2012-04-26 01:05:29
最短路径 算法 A星
;;时间计算 (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 (- 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 2) "秒" ) ) ) ) ;;路径颜色标示 (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 ) ) ) ) ;;vla是真的情况下，将选择集转换成vla-object实体表 ;;vla是假的情况下，将选择集转换成lisp实体表 (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 ) ;;获得点所在位置的线(line,pline,spline)、圆弧、椭圆弧 (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 dist-other (ent pt / pta ptb pta2 ptb2) (setq pta (vlax-curve-getStartpoint ent)) (setq pta2 (list (fix (* 10 (car pta)))(fix (* 10 (cadr pta))))) (setq ptb (vlax-curve-getEndpoint ent)) (if (member pta2 pt-list) (distance ptb pt) (distance pta pt) ) ) ;;获得实体的另一个端点 (defun getotherpt (ent / pta ptb pta2 ptb2) (setq pta (vlax-curve-getStartpoint ent)) (setq pta2 (list (fix (* 10 (car pta)))(fix (* 10 (cadr pta))))) (setq ptb (vlax-curve-getEndpoint ent)) (if (member pta2 pt-list) (setq pt-other ptb) (setq pt-other pta) ) ) ;;;________________________________________________ ;;;________________________________________________ ;;;________________________________________________ ;;;________________________________________________ ;;;A星算法 (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 ;;起点处的实体表，作为延伸后获得的实体表中要去除的实体 pt-list (list (list (fix (* 10 (car pt1)))(fix (* 10 (cadr pt1))))) path-ss (mapcar '(lambda (x) (list x)) ss) ;;;路径表 dist-ss (mapcar '(lambda (x) (list x (get:len x)(dist-other x pt2))) ss) ;;;路径表，带长度 dist-ss (vl-sort dist-ss '(lambda (a b) (< (+ (cadr a)(caddr a)) (+ (cadr b)(caddr b))))) ;;;排序后 complete nil ) (if complete (setq complete (vl-sort complete '(lambda (a b) (< (cadr a) (cadr b))) ) shortest (cadar complete) ;;shortest最短路径 ) ) (if (and shortest (= shortest (distance pt1 pt2))) (progn ;;起止点有直接联通，并且是直线连接(mapcar '(lambda (x) (if (member x sse);;判断起止点之间是否有直接的连接 (setq complete (append complete (list (list x (get:len x)))) ) ) ) ss ) (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))) ) ) (setq shortest (cadar complete)) (setq dist-ss (mapcar '(lambda (x) (if (< (cadr x) shortest) x nil ) ) dist-ss ) ) (setq dist-ss (vl-remove nil dist-ss)) ;;;__________________________________________________ ;;;__________________________________________________ ) (progn (setq count (1+ count)) (setq pt-other (getotherpt (car now))) (setq ss (ss2lst (getss@ pt-other) t)) (setq pt-list (cons (list (fix (* 10 (car pt-other)))(fix (* 10 (cadr pt-other)))) pt-list)) ;; (mapcar '(lambda (x) (setq ss (vl-remove x ss))) ;; passed-ss ;; ) ;;上句替换为下面一句 passed-ss较长时，不如直接处理ss (foreach n ss ;;去掉已走过的路径 (if (member n passed-ss) (setq ss (vl-remove n ss)) ) ) (if ss (progn ;; (setq passed-ss (append passed-ss ss) ;; path-ss (append ;; path-ss ;; (mapcar '(lambda (x) (list x (car now))) ss) ;; ) ;; ) ;; (setq dist-ss (append ;; dist-ss ;; (mapcar ;; '(lambda (x) ;; (if (or (not shortest) ;; (< (get:len x) shortest) ;; ) ;; (list x (+ (cadr now) (get:len x))) ;; ) ;; ) ;; ss ;; ) ;; ) ;; ) ;;上两句替换为下面循环结构 mapcar+append->foreach+cons (foreach n ss (setq passed-ss (cons n passed-ss)) ;;把新路径增加到已走过的路径 (setq path-ss (cons (list n (car now)) path-ss)) ;;把新路由增加到已有路由表中 (if (or (not shortest) (< (get:len n) shortest)) (setq dist-ss (cons (list n (+ (cadr now) (get:len n))(dist-other n pt2)) dist-ss)) ) ) ;; (setq dist-ss (vl-remove nil dist-ss)) (setq dist-ss (vl-sort dist-ss ;;按距离排序 '(lambda (a b) (< (+ (cadr a)(caddr a)) (+ (cadr b)(caddr 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:ttz (/ 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测试命令:ttz\n") (princ)